LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031497. :SYSTEM-TYPE :LOGICAL :VERSION 13. :TYPE "LISP" :NAME "PRINT" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758643865. :AUTHOR "REL3" :LENGTH-IN-BYTES 45502. :LENGTH-IN-BLOCKS 45. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               ; -*- Mode:Common-Lisp; Package:si; Cold-load:t; Base:8 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.;** (c) Copyright 1980 Massachusetts Institute of Technology **(defmacro print-circle (&body body)  `(if (not *print-circle*) (progn                              . ,body)     (let ((print-label-number 0)           (print-hash-table NIL))       (unwind-protect (progn                        (setq print-hash-table (get-print-hash-table))                        (clrhash print-hash-table)                        (print-record-occurrences object)                        . ,body)                       (when print-hash-table          (setq reusable-print-hash-table print-hash-table)))))) (defvar print-hash-table :unbound        "Hash table that records objects printed when *PRINT-CIRCLE*, for detecting shared structure.Key is the object printed, value is its label number.") (defvar reusable-print-hash-table ()) (defmacro get-print-hash-table ()  '(or   (do (old)       ((%store-conditional (locf reusable-print-hash-table) (setq old reusable-print-hash-table)                         ())     old))   (make-hash-table))) (defvar print-label-number :unbound) (defvar character-attribute-table nil);;; You will notice that there are no constant strings in the printer.;;; All the strings come out of a part of the current readtable;;; called the "printtable".  For example, the character to start a list;;; comes from (PTTBL-OPEN-PAREN READTABLE).;;; See the file RDDEFS for the definitions and the default contents of these slots.;Main entries.;These are the external entrypoints which are in the usual documentation.;They are compatible with Maclisp.(defun print (object &optional stream)  "Print OBJECT on STREAM with quoting if needed, with a Return before and a Space after."  (setq stream (decode-print-arg stream))  (funcall stream :tyo (pttbl-newline *readtable*))  (let ((*print-escape* t)(character-attribute-table (character-attribute-table *readtable*)))    (if *print-pretty*(pprint object stream)(progn   (print-circle (print-object object 0 stream))  (funcall stream :tyo (pttbl-space *readtable*)))))  object)(defun prin1 (object &optional stream)  "Print OBJECT on STREAM with quoting if needed."  (setq stream (decode-print-arg stream))  (let ((*print-escape* t)(character-attribute-table (character-attribute-table *readtable*)))    (if *print-pretty*(pprin1 object stream)(print-circle (print-object object 0 stream ))))  object) ;; PPrint is defined in pprint.lisp;(DEFUN PPRINT (OBJECT &OPTIONAL STREAM);  "Print OBJECT on STREAM, with quoting and with extra whitespace to make it look pretty.;Returns zero values.";  (LET ((*PRINT-ESCAPE* T));    (GRIND-TOP-LEVEL OBJECT NIL (DECODE-PRINT-ARG STREAM)));  (VALUES))(defun write (object &key &optional (stream *standard-output*) ((:escape *print-escape*) *print-escape*)  ((:radix *print-radix*) *print-radix*) ((:base *print-base*) *print-base*)  ((:circle *print-circle*) *print-circle*) ((:pretty *print-pretty*) *print-pretty*)  ((:level *print-level*) *print-level*) ((:length *print-length*) *print-length*)  ((:case *print-case*) *print-case*) ((:gensym *print-gensym*) *print-gensym*)  ((:array *print-array*) *print-array*))  "Print OBJECT on STREAM.  Keyword args control parameters affecting printing.The argument ESCAPE specifies the value for the flag *PRINT-ESCAPE*, and so on.For any flags not specified by keyword arguments, the current special binding is used."  (let ((character-attribute-table (character-attribute-table *readtable*)))    (if *print-pretty*(let ((*standard-output* (decode-print-arg stream)))  (output-pretty-object object))(print-circle (print-object object 0 (decode-print-arg stream))))  object))  (defun prin1-then-space (object &optional stream)  "Print OBJECT on STREAM with quoting if needed, followed by a Space character."  (setq stream (decode-print-arg stream))  (let ((*print-escape* t)(character-attribute-table (character-attribute-table *readtable*)))    (if *print-pretty*(pprin1 object stream)(print-circle (print-object object 0 stream)))  (funcall stream :tyo (pttbl-space *readtable*)))  object) (defun princ (object &optional stream)  "Print OBJECT with no quoting, on STREAM.Strings and characters print just their contents with no delimiters or quoting.Pathnames, editor buffers, host objects, and many other hairy things print as their names with no delimiters."  (setq stream (decode-print-arg stream))  (let ((*print-escape* NIL)(character-attribute-table (character-attribute-table *readtable*)))    (if *print-pretty*(pprinc object stream)(print-circle (print-object object 0 stream))))  object) (defun write-to-string (&rest args)  "Like WRITE but conses up a string to contain the output from printing OBJECT."  (declare   (arglist object &key &optional :escape :radix :base :circle :pretty :level :length :case            :gensym :array))  (format:output () (apply 'write args))) (defun prin1-to-string (object)  "Like PRIN1 but conses up a string to contain the output from printing OBJECT."  (format:output () (prin1 object))) (defun princ-to-string (object)  "Like PRINC but conses up a string to contain the output from printing OBJECT."  (format:output () (princ object))) ;SUBROUTINES;PREVENT LOSSAGE BEFORE THE DEFINITIONS OF RATIONALP AND COMPLEXP ARE LOADED.(unless (fboundp 'rationalp)  (fset 'rationalp 'fixp)) (unless (fboundp 'complexp)  (fset 'complexp '(lambda (ignore)                     ()))) (defun print-record-occurrences (object)  (when (and (%pointerp object) (or (not (symbolp object)) (not (symbol-package object)))        (not         (modifyhash object print-hash-table                #'(lambda (object                          value                          found-p)                   object                   value                   found-p))))    (typecase object      (list       (do ((tail object (cdr tail))            (first t ()))           ((atom tail) (when tail                       (print-record-occurrences tail)))         (unless first           (if            (modifyhash tail  print-hash-table                  #'(lambda (object                             value                             found-p)                      object                      value                      found-p))            (return)))         (print-record-occurrences (car tail))))      (array       (let (tem)         (unless (if (setq tem (named-structure-p object))              (and               (setq tem                     (or (get tem 'named-structure-invoke) (get tem :named-structure-invoke)))               (member :print-self (funcall tem :which-operations object) :test #'eq))              (null *print-array*))           (dotimes (i (array-total-size object))             (print-record-occurrences (ar-1-force object i))))))))) ;; This arg is only used to MEMQ for :PRINT or :STRING-OUT,;; so eliminate all other elements to make that faster.(defun which-operations-for-print (stream &aux tem)  (setq tem (funcall stream :which-operations))  (if (member :print tem :test #'eq)      (if (member :string-out tem :test #'eq) '(:print :string-out) '(:print))      (if (member :string-out tem :test #'eq) '(:string-out) (quote ())))) ;;PHD 2/9/87 Print mouse and keypad bit.;Main routine, to print any lisp object.;The WHICH-OPERATIONS argument is provided as an efficiency hack.  It also used;by streams that have a :PRINT handler, and recursively call PRINT-OBJECT, to;prevent themselves from being called again (they pass NIL or (:STRING-OUT)).(defun print-object (exp i-prindepth stream &optional (which-operations (which-operations-for-print stream)) &aux      nss       ;(character-attribute-table (character-attribute-table *readtable*))      )  (catch-continuation-if t 'print-object                         #'(lambda ()                             (format stream "...error printing ")                             (printing-random-object (exp stream :typep :fastp t ))                             (format stream "..."))                         ()                         (condition-resume                          '((error) :abort-printing t ("Give up trying to print this object.")                           catch-error-restart-throw print-object)                          (or                           (and (member :print which-operations :test #'eq);Allow stream to intercept print operation                                (send stream :print exp i-prindepth *print-escape*))                           (and *print-circle* (%pointerp exp)                                (or (not (symbolp exp)) (not (symbol-package exp)));; This is a candidate for circular or shared structure printing.                                ;; See what the hash table says about the object:                                ;; NIL - occurs only once.                                ;; T - occurs more than once, but no occurrences printed yet.                                ;;  Allocate a label this time and print #label= as prefix.                                ;; A number - that is the label.  Print only #label#.                                                                (catch 'label-printed                                  (modifyhash exp print-hash-table                                         #'(lambda (key                                                   value                                                   key-found-p                                                   stream)                                            key                                            key-found-p                                            (cond                                              ((null value) NIL)                                              ((eq value t)                                               (let ((label (incf print-label-number))                                                     (*print-base* 10.)                                                     (*print-radix* NIL)                                                     (*nopoint t))                                                 (send stream :tyo #\#)                                                 (print-fixnum label stream)                                                 (send stream :tyo #\=)                                                 label))                                              (t                                               (let ((*print-base* 10.)                                                     (*print-radix* NIL)                                                     (*nopoint t))                                                 (send stream :tyo #\#)                                                 (print-fixnum value stream)                                                 (send stream :tyo #\#)                                                 (throw 'label-printed                                                        t)))))                                        stream)                                  ()))                           (typecase exp                             (fixnum (print-fixnum exp stream))                             (symbol (print-pname-string exp stream t ))                             (list                              (if (and *print-level* (>= i-prindepth *print-level*))                                  (print-raw-string (pttbl-prinlevel *readtable*) stream t )  (progn    (if *print-pretty*(if *print-escape*    (pprin1 exp stream)    (pprinc exp stream)))    (print-list exp i-prindepth stream which-operations))))                             (string                              (if (<= (array-active-length exp) (array-total-size exp))                                  (print-quoted-string exp stream t)                                  (print-random-object exp stream t i-prindepth                                                       which-operations)))                             (instance                              (send exp :print-self stream i-prindepth *print-escape*))                             (named-structure                              (ignore-errors (setq nss (named-structure-p exp)))                              (cond                                ((and (symbolp nss)                                      (or (get nss 'named-structure-invoke)                                          (get nss :named-structure-invoke))                                      (member :print-self                                              (named-structure-invoke exp :which-operations)                                              :test #'eq))                                 (named-structure-invoke exp :print-self stream i-prindepth                                                         *print-escape*))                                (t;Named structure that doesn't print itself                                                                  (print-named-structure nss exp i-prindepth stream                                                        which-operations))))                             (array (print-array exp stream t  i-prindepth which-operations))                             (float (print-flonum exp stream ()))                             (bignum (print-bignum exp stream t ))                             (rational (print-rational exp stream t))                             (complex (print-complex exp stream t))                             (character                              (if (not *print-escape*)  (write-char exp stream)                                  (progn                                    (send stream :string-out                                          (pttbl-character-before-font *readtable*))                                    (if (ldb-test %%ch-font exp)                                        (let ((*print-base* 10.)                                              (*print-radix* NIL)                                              (*nopoint t))                                          (prin1 (ldb %%ch-font exp) stream)))                                    (send stream :string-out                                          (pttbl-character-prefix *readtable*))                                    (let ((real-bits (ldb  %%kbd-control-meta exp))                                          (char (char-code exp)))                                      (send stream :string-out                                            (nth real-bits                                                 '("" "c-" "m-" "c-m-" "s-" "c-s-" "m-s-"                                                  "c-m-s-" "h-" "c-h-" "m-h-" "c-m-h-" "s-h-"                                                  "c-s-h-" "m-s-h-" "c-m-s-h-")))                                      (let ((chname (ochar-get-character-name (dpb 0 %%kbd-control-meta   (dpb 0 %%ch-font exp)))))                                        (if chname (send stream :string-out chname)                                            (progn      (when (char-bit exp :mouse)(write-string "mouse-" stream))      (when (char-bit exp :keypad)(write-string "keypad-" stream))                                              (when (and (/= (char-bits exp) 0) (character-needs-quoting-p char))(princ (pttbl-slash *readtable*)  stream))                                              (send stream :tyo char))))))))                             (number                              (print-raw-string (pttbl-open-random *readtable*) stream t)                              (print-raw-string (symbol-name (data-type exp)) stream t)                              (send stream :tyo (pttbl-space *readtable*))                              (let ((*print-base* 8.)                                    (*print-radix* NIL))                                (print-fixnum (%pointer exp) stream))                              (print-raw-string (pttbl-close-random *readtable*) stream t))                             (t;Some random type we don't know about                                                            (print-random-object exp stream t i-prindepth which-operations))))))  exp) (defun print-random-object (exp stream fastp i-prindepth which-operations)  (declare (ignore fastp))  (printing-random-object (exp stream :fastp t)                          (print-raw-string (string (data-type exp)) stream t)                          (typecase exp                            ((or compiled-function microcode-function stack-group)                             (funcall stream :tyo (pttbl-space *readtable*))                             (print-object (function-name exp) i-prindepth stream                                           which-operations))))) ;Print a list, hacking prinlength and prinlevel.(defun print-list (exp i-prindepth stream which-operations)  (funcall stream :tyo #\()  (do ((i-prinlength 1 (1+ i-prinlength))       (first t ()))      ((or (atom exp) (and *print-circle* (not first) (gethash exp print-hash-table)))       (cond ((not (null exp))  (print-raw-string " . " stream t)  (print-object exp (1+ i-prindepth) stream which-operations)))       (funcall stream :tyo #\)))    (or first (funcall stream :tyo #\space))    (print-object (car exp) (1+ i-prindepth) stream which-operations)    (setq exp (cdr exp))    (and *print-length* (>= i-prinlength *print-length*);One frob gets printed before test.                     (not (atom exp));Don't do it uselessly                                                           (progn           (send stream :tyo #\space)           (print-raw-string "..." stream t)           (send stream :tyo #\))           (return ()))))) (defun print-vector (exp i-prindepth stream which-operations)  (funcall stream :string-out (pttbl-open-vector *readtable*))  (do ((i-prinlength 0 (1+ i-prinlength))       (length (length exp))       (first t ()))      ((= i-prinlength length) (funcall stream :string-out (pttbl-close-vector *readtable*)))    (or first (funcall stream :tyo (pttbl-space *readtable*)))    (print-object (aref exp i-prinlength) (1+ i-prindepth) stream which-operations)    (and *print-length* (>= i-prinlength *print-length*);One frob gets printed before test.                             (progn           (send stream :tyo (pttbl-space *readtable*))           (print-raw-string (pttbl-prinlength *readtable*) stream t)           (send stream :tyo (pttbl-close-paren *readtable*))           (return ()))))) (defun print-bit-vector (exp stream)  (funcall stream :string-out (pttbl-open-bit-vector *readtable*))  (dotimes (i (length exp))    (send stream :tyo (+ #\0 (aref exp i))))) (defun print-array (exp stream fastp i-prindepth &optional (which-operations (which-operations-for-print stream))      &aux (rank (array-rank exp)))    (declare (ignore fastp))  (if *print-array*      (if (and (= rank 1) (eq (array-type exp) 'art-1b)) (print-bit-vector exp stream)          (if *print-pretty* (pprin1 exp stream)              (if (= rank 1) (print-vector exp i-prindepth stream which-operations)                  (print-multidimensional-array exp i-prindepth stream which-operations))))      (printing-random-object (exp stream :fastp t)                              (print-raw-string (symbol-name (array-type exp)) stream t)                              (dotimes (i rank)                                (send stream :tyo #\-)                                (print-fixnum (array-dimension exp i) stream))))) (defun print-multidimensional-array (exp i-prindepth stream which-operations)  (dolist (elt (pttbl-array *readtable*))    (cond      ((stringp elt) (send stream :string-out elt))      ((eq elt :rank)       (let ((*print-base* 10.)             (*print-radix* NIL)             (*nopoint t))         (print-fixnum (array-rank exp) stream)))      ((eq elt :sequences) (print-array-contents exp 0 0 i-prindepth stream which-operations))))) (defvar array-contents-array ()) (defun print-array-contents (array dimension index-so-far i-prindepth stream w-o &aux tem)  (if (and *print-level* (>= i-prindepth *print-level*))      (send stream :string-out (pttbl-prinlevel *readtable*))      (if (zerop (array-rank array)) (print-object (aref array) i-prindepth stream w-o)          (let ((index (* index-so-far (array-dimension array dimension)))                (mode                 (car (member (array-type array) '(art-1b art-string art-fat-string) :test #'eq)))                (length (array-dimension array dimension))                (rank (array-rank array)))            (cond              ((and mode (= (1+ dimension) rank))               (let ((kludge                      (if                       (and                        (%store-conditional (locf array-contents-array)                                            (setq tem array-contents-array) ())                        tem)                       (change-indirect-array tem mode length array index)                       (make-array length :type mode :displaced-to array                                   :displaced-index-offset index))))                 (if (eq mode 'art-1b) (print-bit-vector kludge stream);                                                            (print-quoted-string kludge stream (member :string-out w-o :test #'eq)))                 (setq array-contents-array kludge)));massachusetts                            (t (send stream :tyo (pttbl-open-paren *readtable*))               (dotimes (i (array-dimension array dimension))                 (or (zerop i) (send stream :tyo (pttbl-space *readtable*)))                 (cond                   ((and *print-length* (= i *print-length*))                    (send stream :string-out (pttbl-prinlength *readtable*)) (return))                   ((= (1+ dimension) (array-rank array))                    (print-object (ar-1-force array (+ index i)) (1+ i-prindepth) stream w-o))                   ((and *print-level* (>= (1+ i-prindepth) *print-level*))                    (send stream :string-out (pttbl-prinlevel *readtable*)))                   (t                    (print-array-contents array (1+ dimension) (+ index i) (1+ i-prindepth)                                          stream w-o))))               (send stream :tyo (pttbl-close-paren *readtable*)))))))) ;;PHD 3/26/87 Fixed it by ignoring dummy slots (those that have name-slot-p non nil)(defun print-named-structure (nss exp i-prindepth stream which-operations)  (declare (special *print-structure*))  (let ((description (get nss 'defstruct-description)))    (if (or (not description)    (if (boundp '*print-structure* ) (null *print-structure*) (null *print-array*)))(printing-random-object (exp stream :typep))        (progn          (funcall stream :string-out "#S")          (let ((slot-alist (defstruct-description-slot-alist))                (l (list nss)))            (dolist (s slot-alist)      (unless (defstruct-slot-description-name-slot-p (cdr s))(let* ((kwd (intern (symbol-name (car s)) pkg-keyword-package))       (fun (defstruct-slot-description-ref-macro-name (cdr s)))       (init (defstruct-slot-description-init-code (cdr s)))       (val (eval1 `(,fun ,exp))));watch out for macros!    (unless (equal val init)    (push kwd l)    (push val l)))))            (print-object (nreverse l) i-prindepth stream which-operations)))        ))) (defun print-base-subscript (minus-number stream)  "Print a subscript after a number."  (let ((beginning-of-number (truncate minus-number 10.)))    (if (not (zerop beginning-of-number)) (print-base-subscript beginning-of-number stream)))  (let ((saved-font-map (send stream :font-map))        (saved-character-width (tv:font-char-width (send stream :current-font))))    (send stream :set-font-map *base-font-map*)    (setf (tv:font-char-width fonts:base-font) saved-character-width)    (funcall stream :tyo (aref print-fixnum-digits (- (rem minus-number 10.))))    (send stream :set-font-map saved-font-map))) ;Print a fixnum, possibly with negation, decimal point, etc.(defun print-fixnum (x stream &aux tem)  (and *print-radix* (numberp *print-base*) (neq *print-base* 10.)       (cond         ((eq *print-base* 8.) (send stream :string-out "#o"))         ((eq *print-base* 2) (send stream :string-out "#b"))         ((eq *print-base* 16.) (send stream :string-out "#x"))         (t (send stream :tyo #\#)          (let ((*print-base* 10.)                (*print-radix* NIL)                (*nopoint t)                (tem *print-base*))            (print-fixnum tem stream))          (send stream :tyo #\r))))  (cond    ((minusp x) (funcall stream :tyo (pttbl-minus-sign *readtable*)))    (t (setq x (- x))))  (cond    ((and (numberp *print-base*) (< 1 *print-base* 37.)) (print-fixnum-1 x *print-base* stream))    ((and (symbolp *print-base*) (setq tem (get *print-base* 'princ-function))) (funcall tem x stream))    (t (ferror () "A *PRINT-BASE* of ~S is meaningless." *print-base*)))  (if (and (or *print-radix* (not *nopoint)) (eq *print-base* 10.))      (funcall stream :tyo (pttbl-decimal-point *readtable*)))  (if   (and *print-base-subscript* (not *print-radix*) (neq (symeval-globally '*print-base*) *print-base*)        (<= *print-base* (abs x)) (send stream :operation-handled-p :font-map)        (<= (tv:font-char-width fonts:base-font) (tv:font-char-width (send stream :current-font))))   (print-base-subscript (- *print-base*) stream))  x) (defparameter print-fixnum-digits "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"              "Characters used as digits when printing fixnums (if *PRINT-BASE* is big enough).") ;Print the digits of the fixnum.  NUM is MINUS the fixnum to be printed!(defun print-fixnum-1 (num radix stream &aux tem)  (setq tem (truncate num radix))  (or (zerop tem) (print-fixnum-1 tem radix stream))  (funcall stream :tyo (aref print-fixnum-digits (- (rem num radix))))) ;; Printing flonums. ;; Note how the same code works for small flonums without consing and;; for big flonums with a certain amount of flonum and bignum consing.;; This code probably loses accuracy for large exponents.  Needs investigation.(defun print-flonum (x stream &optional max-digits (force-e-format NIL) &aux expt)  (when (minusp (float-sign x))    (funcall stream :tyo (pttbl-minus-sign *readtable*))    (setq x (- x))); Print -0.0 correctly too....  (cond    ((zerop x) (send stream :string-out "0.0")     (if (not (typep x *read-default-float-format*))         (send stream :string-out       (typecase x (short-float  "s0") (single-float "f0") (double-float "d0")))))    (t     (cond       ((or (< x 0.001s0) (>= x 1.0s7) force-e-format); Must go to E format.(multiple-value-setq (x expt)     (scale-flonum x))        (let ((place-moved (print-flonum-internal x stream max-digits t)))          (when place-moved            (incf expt)))(send stream :tyo      (if (not (typep x *read-default-float-format*))  (typecase x    (short-float  #\s)    (single-float #\f)    (double-float #\d))                  #\e))        (if (minusp expt)    (funcall stream :tyo (pttbl-minus-sign *readtable*))    (setq expt (- expt)));Wind up with a NEGATIVE expt        (print-fixnum-1 expt 10. stream))       (t; It is in range, don't use E-format.         (print-flonum-internal x stream max-digits)        (if (not (typep x *read-default-float-format*))            (send stream :string-out  (typecase x    (short-float  "s0")    (single-float "f0")    (double-float "d0")))))))));Scale a positive flonum so that it is >= 1.0 and < 10.0;Returns two values, the new flonum and the exponent scaled by,;which is positive if the number was large and negative if it was small.;Tries to minimize loss of precision.  Can lose up to 3 bits of precision;for humongous numbers, but usually loses at most 1 bit.;This still needs more work; perhaps it should do the scaling;in fixed-point double-precision rather than in floating point;;the result is consistently too low when expt is large and negative.(defun scale-flonum (x &aux (expt 0))  (cond    ((zerop x) (return-from scale-flonum (values x 0)))    ;;If we're far off, first guess the exponent via logarithms    ((or (< x 1.0s-15) (> x 1.0s15))     (setq expt (truncate (log x) 2.30258s0); 2.30258s0=(Log 10.0s0) (rough estimate)   x (if (minusp expt) (* x (expt 10. (- expt))) (/ x (expt 10. expt))))))  ;; Divide by powers of 10. to make it less than 10.  (do ((div 10. (* 10. div))       (y x (/ x div)))      ((< y 10.) (setq x y))    (setq expt (1+ expt)))  ;; Multiply by powers of 10. to make it not less than 1.  (do ((mpy 10. (* 10. mpy))       (y x (* x mpy)))      ((>= y 1) (return (values y expt)))    (setq expt (1- expt)))) ;Print the mantissa.;X is a positive non-zero flonum.;Although X's magnitude is constrained to be between 0.1 and 100000.;when called from the normal printer, this code should work for any X;for the benefit of FORMAT.;Note that ASH is the same as LSH except that it works for bignums and;arbitrary amounts of shifting.  It is implemented with multiply and divide.;Documentation in AI:QUUX;RADIX >;Except that the bletcherous E-FORMAT hair in there has been flushed.;It served only to avoid scaling the flonum to between 1 and 10 when;printing in E-format, which this code wasn't using anyway.;The MAX-DIGITS argument allows rounding off to a smaller precision;than the true value.  However, it will only do this after the decimal point.(defun print-flonum-internal (x stream max-digits &optional move-decimal-point)  (let (place-moved)    (multiple-value-bind (bufer decimal-place) (flonum-to-string x () max-digits ())      (when (and move-decimal-point (= decimal-place 2))        (setf (aref bufer 2) (aref bufer 1))        (setf (aref bufer 1) #\.)        (if (= (aref bufer (1- (length bufer))) #\0) (decf (fill-pointer bufer)))        (setq place-moved t))      (funcall stream :string-out bufer)      (return-array (prog1                      bufer                      (setq bufer ())))      place-moved))) ;FORMAT also calls this;;PHD Added bufer as an optional argument, so we don't have to cons it up.(defun flonum-to-string (flonum ignore max-digits fraction-digits &optional drop-leading-zero bufer)  "Return a string containing the printed representation of FLONUM.At most MAX-DIGITS are printed if MAX-DIGITS is non-NIL.If FRACTION-DIGITS is non-NIL, exactly FRACTION-DIGITS digits are printed after the decimal point.  This overrides the effect of MAX-DIGITS.The second value is the number of digits that preceded the decimal point.DROP-LEADING-ZERO means print .123 rather than 0.123 ."  (declare (VALUES bufer integer-digits))  (let ((exponent (si:flonum-exponent flonum))        (mantissa (si:flonum-mantissa flonum))        (bas 10.)        k        m        r        q        u        s        decimal-place;; BUFER is needed when MAX-DIGITS is supplied because the rounding        ;; can generate a carry that has to propagate back through the digits.                (bufer (or bufer (make-array 64. :element-type 'string-char :leader-list '(0)))))    (or max-digits (setq max-digits 1000.));Cause no effect.    ;; Get integer part        (setq r (ash mantissa exponent))    (setq q r)    (setq m (ash 1 (1- exponent)));Actually 0 in most normal cases.    ;; Instead of using a pdl, precompute S and K.    ;; S gets the highest power of BAS <= R, and K is its logarithm.        (setq s 1 k 0 u bas)    (do ()        ((> u r))      (setq s u u (* u bas) k (1+ k)))    (do ()        (NIL)      (setf (values u r) (truncate r s))      (cond        ((or (< r m) (> r (- s m))) (if (> (* 2 r) s) (setq u (1+ u)))  ;Round up as necessary (cond ((= u 10.) (setq u 1) (incf k)))  ;Handle the overflow case (ZLC:array-push bufer (+ #\0 u))         (decf max-digits);; This is the LEFTFILL routine in the paper.                  (do ((i 0 (1+ i)))             ((>= i k) NIL)           (ZLC:array-push bufer #\0)  ;Fill with trailing zeroes           (decf max-digits)) (return ())));; If number is < 1, and we want all digits as fraction digits,      ;; optionally omit the usual single leading zero before the decimal point.            (unless (and fraction-digits drop-leading-zero (zerop u) (zerop (fill-pointer bufer))   (eq max-digits fraction-digits))        (ZLC:array-push bufer (+ #\0 u)))      (decf max-digits)      (decf k)      (if (minusp k) (return ()))      (setq s (truncate s 10.)))    (setq decimal-place (array-active-length bufer))    (ZLC:array-push bufer (si:pttbl-decimal-point *readtable*))    (if fraction-digits (setq max-digits fraction-digits))    (if (or (null max-digits) (plusp max-digits))        (if (minusp exponent);; There is a fraction part.                        (let ((z (- exponent)));; R/S is the fraction, M/S is the error tolerance                  ;; The multiplication by 2 causes initial M to be 1/2 LSB                                (setq r (* (if (<= z 23.) (ldb z mantissa);If fraction bits fit in a fixnum                                        (logand mantissa (1- (ash 1 z)))) 2) s                    (ash 2 z) m 1)              (do ()                  (NIL)                (setq r (* r bas))                (setf (values u r) (truncate r s))                (setq m (* m bas))                (and (or (< r m) (> r (- s m)) (< max-digits 2)) (return ()))                (ZLC:ARRAY-PUSH bufer (+ u #\0))                (decf max-digits))              (ZLC:ARRAY-PUSH bufer (setq z (+ (if (<= (* 2 r) s) u (1+ u)) #\0)))              (cond                ((> z #\9);Oops, propagate carry backward (MAX-DIGITS case)                                  (do ((i (- (array-leader bufer 0) 2) (1- i)))                     ((minusp i) NIL)                   (setf(aref bufer (1+ i)) #\0)                   skip-decimal                   (setq z (aref bufer i))                   (cond                     ((= z (si:pttbl-decimal-point *readtable*)) (setq i (1- i)) (go skip-decimal))                     ((/= z #\9) (setf (aref bufer i) (1+ z)) (return ()))                     ((zerop i);;Double oops, the carry has added a new digit                                            (let ((len (- (array-leader bufer 0) 2)))                        (and (= (aref bufer len) (si:pttbl-decimal-point *readtable*));;Must have some fraction part                                                          (ZLC:ARRAY-PUSH bufer #\0))                        (do ((i len (1- i)))                            ((<= i 0) NIL)                          (setf (aref bufer (1+ i)) (aref bufer i)))                        (incf decimal-place))                      (setf (aref bufer 1) #\0)      (setf (aref bufer 0) #\1)       (return ()))));Now truncate trailing zeros, except for one after the decimal point                                  (loop for i from (1- (array-active-length bufer)) downto (+ decimal-place 2)                       while (= (aref bufer i) #\0) do (store-array-leader i bufer 0)))));; There is no fraction part at all.                        (ZLC:ARRAY-PUSH bufer #\0)));; Now add trailing zeros if requested        (if (and fraction-digits (plusp fraction-digits))        (loop repeat (- (+ decimal-place fraction-digits 1) (array-active-length bufer)) do              (ZLC:array-push bufer #\0)))    (values bufer decimal-place)))(defun print-bignum (bignum stream fastp &aux tem)  (declare (ignore fastp))  (and *print-radix* (numberp *print-base*) (neq *print-base* 10.)       (cond         ((eq *print-base* 8.) (send stream :string-out "#o"))         ((eq *print-base* 2) (send stream :string-out "#b"))         ((eq *print-base* 16.) (send stream :string-out "#x"))         (t (send stream :tyo #\#)    (let ((*print-base* 10.)  (*print-radix* NIL)  (*nopoint t)  (tem *print-base*))      (print-fixnum tem stream))    (send stream :tyo #\r))))  (cond    ((minusp bignum) (funcall stream :tyo (pttbl-minus-sign *readtable*))))  (cond    ((and (integerp *print-base*) (< 1 *print-base* 37.)) (print-bignum-1 bignum *print-base* stream))    ((and (symbolp *print-base*) (setq tem (get *print-base* 'princ-function))) (funcall tem (- bignum) stream))    (t (ferror () "A *PRINT-BASE* of ~S is meaningless" *print-base*)))  (if (and (or *print-radix* (not *nopoint)) (eq *print-base* 10.))      (funcall stream :tyo (pttbl-decimal-point *readtable*)))  (if   (and *print-base-subscript* (not *print-radix*) (neq (symeval-globally '*print-base*) *print-base*)        (send stream :operation-handled-p :font-map)        (<= (tv:font-char-width fonts:base-font) (tv:font-char-width (send stream :current-font))))   (print-base-subscript (- *print-base*) stream))  bignum) ;;; Print the digits of a bignum(defun print-bignum-1 (num radix stream &aux length max-radix digits-per-q)  (setq digits-per-q (floor 24. (haulong radix)) max-radix (expt radix digits-per-q) num        (bignum-to-array num max-radix) length (array-length num))  (do ((index (1- length) (1- index))       (ndigits -1 digits-per-q))      ((minusp index))    (print-bignum-piece (aref num index) radix stream ndigits))  (return-array num)) (defun print-bignum-piece (piece radix stream ndigits)  (cond    ((or (> ndigits 1) (>= piece radix))     (print-bignum-piece (truncate piece radix) radix stream (1- ndigits))))  (funcall stream :tyo (aref print-fixnum-digits (rem piece radix)))) ;The following functions print out strings, in three different ways.(defmacro dostring (varform &rest body)  ;; Varform looks like (variable init-form terminate-form)  (let ((variable (car varform))(init-form (cadr varform))(terminate-form (caddr varform)))    `(do ((,variable)  (index 0 (1+ index))  (terminate-index (length (the string ,init-form)))) ((= index terminate-index)  ,terminate-form)       (setq ,variable (char ,init-form index))       ,@body)));Print out a symbol's print-name.  If slashification is on, try slashify it;so that if read in the right thing will happen.(proclaim '(inline funny-symbol-char-p));; given that character-attribute-table is bound during the print or print-pname-string(defun funny-symbol-char-p (char)  "Determines whether or not the character should be proceded by a slash when   outputing the printed representation of a symbol containing it."  (let ((att (svref character-attribute-table (char-code char))))    (declare (special character-attribute-table ))    (or (<= #\a (char-code char) #\z)         (>= att #.sharp-sign)          (> #.constituent att))))(defmacro symbol-quote-char-p (char)  "Determines whether or not the character is a symbol quoter."  `(or (= (svref character-attribute-table (char-int ,char)) #.escape)       (= (svref character-attribute-table (char-int ,char)) #.multiple-escape)))(defun output-case-symbol (pname stream)  (if *print-escape*      (let ((vertical-bar-flag  (or (do* ((index 0 (1+ index))    (length (length pname)))   ((= index length) nil)(if (funny-symbol-char-p  (char pname index))    (return t)))      (do* ((index 0 (1+ index))    (length (length pname)))   ((= index length) t)(if (not (digit-char-p (char pname index)  *print-base*))    (return ()))))))    ;;If we will be using vertical bars to quote instead slashes(if  vertical-bar-flag      (progn        (funcall stream :tyo #\| )       (dostring (char pname) ;;If it needs slashing, do it. (if (symbol-quote-char-p char)     (funcall stream :tyo  #\\)) (funcall stream :tyo char))       (funcall stream :tyo  #\| ))          (case *print-case*   (:upcase (send stream :string-out pname))   (:downcase (dostring (char pname) (send stream :tyo  (char-downcase char))))   (:capitalize (do ((index 0 (1+ index))     (pname-length (length (the string pname))))    ((= index pname-length))  (let ((char (char pname index)))    (send stream :tyo  (if (= index 0) char (char-downcase char)))))))))     (write-string pname stream)));;PHD 1/1/87allow *package* to be NIL (old idiom).(defun print-pname-string  (symbol stream fastp &optional no-package-prefixes &aux    (character-attribute-table (character-attribute-table *readtable*)))  (declare (ignore fastp))  (when (symbolp symbol)    (let ((sym-pkg (symbol-package symbol))  (pname   (symbol-name symbol)))      (when (and *print-escape* (not no-package-prefixes))(cond       ((null sym-pkg)       (when *print-gensym* (send stream :string-out (pttbl-uninterned-symbol-prefix *readtable*))))      ((eq sym-pkg *package*))      ((eq sym-pkg *keyword-package*)       (send stream :string-out (pttbl-package-prefix *readtable*)))      (t       ;; At this point, we know the symbol is interned and       ;;that it is interned in some package other than *package*.       ;; If the symbol is inherited, no prefix will be necessary.       (multiple-value-bind (sym flag)   (and *package* (find-symbol pname *package*)) (if (and flag (eq sym symbol))     ;; inherited     (when (assoc symbol *reader-symbol-substitutions* :test #'eq)       ;; There  is a substitution going on at reading time that shadows the symbol,       ;; So we have to print the package prefix to force the reading.       (send stream :string-out (package-prefix-print-name sym-pkg))       (send stream :string-out     (if (eq flag :internal) (pttbl-package-internal-prefix *readtable*) (pttbl-package-prefix *readtable*))))     ;; Else symbol is not inherited [it could be shadowed]. Print prefix     ;; and use either ":" or "::" accordingly as external or internal.     (unless (and sym (eq sym (car (rassoc symbol *reader-symbol-substitutions* :test #'eq))))       ;;If the symbol is shadowing an accessible symbol because of *reader-symbol-substitutions*       ;;then we don't need to print the prefix.       ;;If the symbol is shadowing another one, then it does not need any package prefix.       (multiple-value-bind (fsym flag-1)   (find-symbol pname sym-pkg)  ;; <fsym> is eq to <symbol> so we ignore it (declare (ignore fsym)) (send stream :string-out (package-prefix-print-name sym-pkg)) (send stream :string-out       (if (eq flag-1 :internal)   (pttbl-package-internal-prefix *readtable*)   (pttbl-package-prefix *readtable*))))))))))      (output-case-symbol pname stream))))    ;Print a string, and if slashification is on, slashify it appropriately.    (defun print-quoted-string (string stream fastp &aux tem char (slash (pttbl-slash *readtable*)))    (declare (ignore fastp))    (cond      ((not *print-escape*) (print-raw-string string stream t))      (t (funcall stream :tyo (pttbl-open-quote-string *readtable*)) (setq tem (length string)) (cond   ((and (eq (array-type string) 'art-string) (do ((i 0 (1+ i))      (ch))     ((>= i tem) t)   (And (or (char= (setq ch (aref string i)) slash)    (char= ch #\"))(return ()))))    ;; There are no double quotes, and so no slashifying.        (funcall stream :string-out string))   (t    (do ((i 0 (1+ i)))((>= i tem) NIL)      (setq char (ldb %%ch-char (aref string i)))      (when (or (char= char slash) (char= char #\"))(funcall stream :tyo slash))      (funcall stream :tyo char)))) (funcall stream :tyo (pttbl-close-quote-string *readtable*)))))  ;Print the string, with no slashification at all.    (defun print-raw-string (string stream fastp &aux tem)    (declare (ignore fastp))    (cond      ((and t (eq (array-type string) 'art-string)) (funcall stream :string-out string))      (t (setq tem (array-active-length string)) (do ((i 0 (1+ i)))     ((>= i tem) NIL)   (funcall stream :tyo (ldb %%ch-char (aref string i)))))))       (defprop print-not-readable t :error-reporter)       (defun print-not-readable (exp)    (let ((print-readably NIL))      (cerror :no-action () 'print-not-readable "Can't print ~S readably." exp)))       (defun character-needs-quoting-p (char &optional (rdtbl *readtable*))    "Returns T if CHAR needs to be quoted to be read in as a symbol using readtable RDTBL."    (let ((character-attribute-table (character-attribute-table rdtbl)))      (funny-symbol-char-p char)))(LET* ((conflicts (THE list       (REMOVE 'nil       (THE list    (MAPCAR       #'(lambda (p)   (MULTIPLE-VALUE-BIND (csym type)       (FIND-SYMBOL-LOCALLY symbol p)    (WHEN (EQ type :EXTERNAL)  (CONS csym p))))      (PACK-USE-LIST pkg)))))))  (IF (CDR conflicts)       (signal-proceed-case ((ignore) 'eh:name-conflict    (format t "~%Attempting to unintern the shadowing symbol ~s from the ~a ~package ~%would introduce the following name conflicts:" symbol (package-name pkg))    symbol    (packag