(FILECREATED "30-Sep-86 12:08:50" {ERIS}<LISPCORE>SOURCES>APRINT.;46
 71559  

      changes to:  (VARS APRINTCOMS)
                   (MACROS NUMFORMATCODE)
                   (FNS PRIN1 PRIN2 PRIN3 PRIN4 \LITPRIN)

      previous date: "18-Sep-86 11:41:01" {ERIS}<LISPCORE>SOURCES>APRINT.;44)


(* "
Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT APRINTCOMS)

(RPAQQ APRINTCOMS
 
       [(COMS (* ; "User-level print functions")
              (FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT PRINTCCODE PRINTLEVEL RADIX SPACES TERPRI FRESHLINE 
                   DEFPRINT LINELENGTH))
        (INITVARS (PLVLFILEFLG NIL)
               (\LINELENGTH 82)
               (\FLOATFORMAT T)
               (PRXFLG NIL)
               (*PRINT-BASE* 10)
               (*READ-BASE* 10)
               (*PRINT-RADIX* NIL)
               (*PRINT-ESCAPE* T)
               (*PRINT-CASE* (QUOTE :UPCASE))
               (*PRINT-GENSYM* T)
               (*PRINT-LEVEL* NIL)
               (*PRINT-LENGTH* NIL)
               (*PRINT-PRETTY* NIL)
               (*PRINT-CIRCLE* NIL)
               (*PRINT-ARRAY* NIL)
               (*PRINT-CIRCLE-HASHTABLE* NIL)
               (*PACKAGE* NIL)
               (*KEYWORD-PACKAGE* NIL)
               (*INTERLISP-PRIN1-CASE* (QUOTE :UPCASE))
               (\DEFPRINTFNS NIL))
        (COMS (* ; "PRINT internals")
              (FNS PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-SCAN PRINT-CIRCLE-ENTER)
              (FNS \PRINDATUM \ELIDE.PRINT.ELEMENT \ELIDE.ELEMENT.CHAR \ELIDE.PRINT.TAIL 
                   \ELIDE.TAIL.STRING \CKPOSBOUT \CKPOSSOUT \CONVERTNUMBER \LITPRIN \LITPRIN.INTERNAL 
                   \SYMBOL.ESCAPE.COUNT \NUMERIC.PNAMEP \PRINSTACKP \PRINTADDR \PRINSTRING \SOUT 
                   \OUTCHAR \FILEOUTCHARFN \TTYOUTCHARFN)
              (DECLARE: EVAL@COMPILE DONTCOPY (MACROS .FILELINELENGTH.)
                     (EXPORT (MACROS .SPACECHECK. \CHECKRADIX)))
              (FNS \INVALID.RADIX)
              (SPECVARS \THISFILELINELENGTH))
        (COMS (* ; "Internal printing")
              (FNS \MAPPNAME \MAPPNAME.INTERNAL PNAMESTREAMP)
              (DECLARE: DONTCOPY (RESOURCES \MAPPNAMESTREAM)
                     (MACROS PNAMESTREAMP))
              (INITRESOURCES \MAPPNAMESTREAM)
              [INITVARS (\PNAMEDEVICE (NCREATE (QUOTE FDEV)
                                             (\GETDEVICEFROMHOSTNAME (QUOTE NULL)
                                                    T]
              (GLOBALVARS \PNAMEDEVICE))
        (COMS (* ; "Obsolete")
              (FNS \MAPCHARS))
        (DECLARE: EVAL@COMPILE DOCOPY
               (ADDVARS (SYSSPECVARS *PRINT-BASE* *READ-BASE* *PRINT-RADIX* *PRINT-ESCAPE* 
                               *PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH* 
                               *PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE*)))
        (COMS (* ; "PRINTNUM and friends")
              (FNS PRINTNUM FLTFMT \CHECKFLTFMT)
              (MACROS NUMFORMATCODE)
              (INITVARS (NILNUMPRINTFLG)))
        (LOCALVARS . T)
        (GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS)
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML)
                      (LAMA PRINT-CIRCLE-ENTER PRINT-CIRCLE-SCAN PRINT-CIRCLE-LABEL-P 
                            PRINT-CIRCLE-LOOKUP])



(* ; "User-level print functions")


(DEFINEQ

(PRIN1

  [LAMBDA (X FILE)
                                           (* bvm: "29-Sep-86 23:59")


                                                  (* ;;; "Like PRIN2 but no escaping.  Also implies no radix qualifiers, although Common Lisp separates *PRINT-RADIX* from *PRINT-ESCAPE* -- might want to bind *PRINT-RADIX* to (AND (fetch (READTABLEP COMMONLISP) of *READTABLE*) *PRINT-RADIX*)")

    (LET* [(STRM (\GETSTREAM FILE (QUOTE OUTPUT)))
           (OBEY-PRINT-LEVEL (OR (ffetch
 (READTABLEP COMMONLISP) of
 (\DTEST *READTABLE* (QUOTE 
                                                                                           READTABLEP
                                                                                               )))
                                 (OR (\OUTTERMP STRM)
                                     PLVLFILEFLG]
          (LET ((*PRINT-ESCAPE* NIL)
                (*PRINT-RADIX* NIL)
                (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
                (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
                (*PRINT-CASE* (OR *INTERLISP-PRIN1-CASE* *PRINT-CASE*))
                \THISFILELINELENGTH)
               (DECLARE
 (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-LEVEL* *PRINT-LENGTH* 
                               *PRINT-CASE* \THISFILELINELENGTH))

                                                  (* ; 

        "*PRINT-CASE* because too many things in Interlisp prin1 things expecting the symbol's pname")

               (SETQ \THISFILELINELENGTH (.FILELINELENGTH. STRM))
               (\PRINDATUM
 X STRM 0)
               X])

(PRIN2

  [LAMBDA (X FILE RDTBL)
                                     (* bvm: "30-Sep-86 00:02")

    (LET* [(STRM (\GETSTREAM FILE (QUOTE OUTPUT)))
           (OBEY-PRINT-LEVEL (OR (fetch
 (READTABLEP COMMONLISP) of
 (SETQ RDTBL (\GTREADTABLE RDTBL)))
                                 (OR (\OUTTERMP STRM)
                                     PLVLFILEFLG]
          (LET ((*READTABLE* RDTBL)
                (*PRINT-ESCAPE* T)
                (*PRINT-RADIX* (NEQ *PRINT-BASE* 10))
                (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
                (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
                (*PACKAGE* (if
 (fetch
 (READTABLEP USESILPACKAGE) of
 RDTBL)
                               then
 *INTERLISP-PACKAGE*
                             else
 *PACKAGE*))
                \THISFILELINELENGTH)
               (DECLARE
 (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *READTABLE* *PRINT-LEVEL* 
                               *PRINT-LENGTH* *PACKAGE* \THISFILELINELENGTH))
               (SETQ \THISFILELINELENGTH (.FILELINELENGTH. STRM))
               (\PRINDATUM
 X STRM 0)
               X])

(PRIN3

  [LAMBDA (X FILE)
                                           (* bvm: "29-Sep-86 23:59")

          
          (* * Like PRIN1 but no linelength checking)


    (LET* [(STRM (\GETSTREAM FILE (QUOTE OUTPUT)))
           (OBEY-PRINT-LEVEL (OR (ffetch
 (READTABLEP COMMONLISP) of
 (\DTEST *READTABLE* (QUOTE 
                                                                                           READTABLEP
                                                                                               )))
                                 (OR (\OUTTERMP STRM)
                                     PLVLFILEFLG]
          (LET ((*PRINT-ESCAPE* NIL)
                (*PRINT-RADIX* NIL)
                (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
                (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
                (*PRINT-CASE* (OR *INTERLISP-PRIN1-CASE* *PRINT-CASE*))
                \THISFILELINELENGTH)
               (DECLARE
 (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-LEVEL* *PRINT-LENGTH* 
                               \THISFILELINELENGTH))
               (\PRINDATUM
 X STRM 0)
               X])

(PRIN4

  [LAMBDA (X FILE RDTBL)
                                     (* bvm: "30-Sep-86 00:03")

          
          (* * Like PRIN2 but doesn't check linelength)


    (LET* [(STRM (\GETSTREAM FILE (QUOTE OUTPUT)))
           (OBEY-PRINT-LEVEL (OR (fetch
 (READTABLEP COMMONLISP) of
 (SETQ RDTBL (\GTREADTABLE RDTBL)))
                                 (OR (\OUTTERMP STRM)
                                     PLVLFILEFLG]
          (LET ((*READTABLE* RDTBL)
                (*PRINT-ESCAPE* T)
                (*PRINT-RADIX* (NEQ *PRINT-BASE* 10))
                (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*))
                (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*))
                (*PACKAGE* (if
 (fetch
 (READTABLEP USESILPACKAGE) of
 RDTBL)
                               then
 *INTERLISP-PACKAGE*
                             else
 *PACKAGE*))
                \THISFILELINELENGTH)
               (DECLARE
 (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *READTABLE* *PRINT-LEVEL* 
                               *PRINT-LENGTH* *PACKAGE* \THISFILELINELENGTH))
               (\PRINDATUM
 X STRM 0)
               X])

(PRINT

  [LAMBDA (X FILE RDTBL)
                                     (* bvm: " 9-May-86 23:08")

    (LET [(STRM (\GETSTREAM FILE (QUOTE OUTPUT]
         (PRIN2
 X STRM RDTBL)
         (\OUTCHAR
 STRM (CHARCODE EOL))
         X])

(PRINTCCODE

  [LAMBDA (CHARCODE FILE)
                                    (* bvm: " 9-May-86 22:44")

    (\OUTCHAR
 (\GETSTREAM FILE (QUOTE OUTPUT))
           (COND
              ((\CHARCODEP CHARCODE)
               CHARCODE)
              (T (\ILLEGAL.ARG CHARCODE])

(PRINTLEVEL

  [LAMBDA (CARVAL CDRVAL)
                                    (* bvm: " 9-May-86 22:47")

          
          (* * Sets Interlisp print level to the given values in CAR and CDR directions.

          These correspond to *PRINT-LEVEL* and *PRINT-LENGTH* in Common Lisp)


    [COND
       ((LISTP CARVAL)
        (SETQ CDRVAL (CDR CARVAL))
        (SETQ CARVAL (CAR CARVAL]
    (PROG1 (CONS (OR *PRINT-LEVEL* -1)
                 (OR *PRINT-LENGTH* -1))
           [COND
              (CARVAL (SETQ *PRINT-LEVEL* (AND (IGEQ CARVAL 0)
                                               CARVAL]
           (COND
              (CDRVAL (SETQ *PRINT-LENGTH* (AND (IGEQ CDRVAL 0)
                                                CDRVAL])

(RADIX

  [LAMBDA (N)
                                                (* bvm: " 5-May-86 10:56")

    (PROG1 *PRINT-BASE* (AND N (SETQ *PRINT-BASE* (\CHECKRADIX N])

(SPACES

  [LAMBDA (N FILE)
                                           (* rmk: "21-OCT-83 12:32")

    [PROG ((STREAM (\GETSTREAM FILE (QUOTE OUTPUT)))
           \THISFILELINELENGTH)
          (SETQ \THISFILELINELENGTH (.FILELINELENGTH. STREAM))
          (.SPACECHECK. STREAM N)
          (FRPTQ N (\OUTCHAR
 STREAM (CHARCODE SPACE]
    NIL])

(TERPRI

  [LAMBDA (FILE)
                                             (* rmk: "21-OCT-83 12:31")

    (\OUTCHAR
 (\GETSTREAM FILE (QUOTE OUTPUT))
           (CHARCODE EOL))
    NIL])

(FRESHLINE

  [LAMBDA (STREAM)
                                           (* rmk: "22-AUG-83 13:48")

                                                             (* Adjusts the STREAM to be at a new 

                                                             line -- does equivalent of TERPRI 

                                                             unless it is already 

                                                             "sitting at the beginning of a line")

    (COND
       ([NEQ 0 (fetch
 CHARPOSITION of
 (COND
                                         ((AND (type?
 STREAM STREAM)
                                               (WRITEABLE STREAM))
                                          STREAM)
                                         (T (SETQ STREAM (GETSTREAM STREAM (QUOTE OUTPUT]
        (\OUTCHAR
 STREAM (CHARCODE EOL))
        T])

(DEFPRINT

  [LAMBDA (TYPE FN)
                                          (* rmk: "28-APR-80 12:04")

    (AND (FIXP TYPE)
         (SETQ TYPE (\TYPENAMEFROMNUMBER TYPE)))             (* The FIXP case should never occur)

    (PROG ((F (FASSOC TYPE \DEFPRINTFNS)))
          [COND
             (F (SETQ \DEFPRINTFNS (DREMOVE F \DEFPRINTFNS]
          [COND
             (FN (SETQ \DEFPRINTFNS (CONS (CONS TYPE FN)
                                          \DEFPRINTFNS]
          (RETURN (CDR F])

(LINELENGTH

  [LAMBDA (N FILE)
                                           (* bvm: "11-Mar-86 14:56")

          
          (* * Sets to N the linelength of FILE --

          defaults to primary output file)


    (LET [(STREAM (\GETSTREAM FILE (QUOTE OUTPUT]
         (PROG1 (fetch
 (STREAM LINELENGTH) of
 STREAM)
                (AND N (COND
                          ((AND (NUMBERP N)
                                (ILESSP N 1))
                           (\ILLEGAL.ARG N))
                          (T (replace
 (STREAM LINELENGTH) of
 STREAM with
 (COND
                                                                            ((EQ N T)
                                                             (* Infinite)

                                                                             MAX.SMALLP)
                                                                            (T (FIX N])
)

(RPAQ? PLVLFILEFLG
 NIL)

(RPAQ? \LINELENGTH
 82)

(RPAQ? \FLOATFORMAT
 T)

(RPAQ? PRXFLG
 NIL)

(RPAQ? *PRINT-BASE*
 10)

(RPAQ? *READ-BASE*
 10)

(RPAQ? *PRINT-RADIX*
 NIL)

(RPAQ? *PRINT-ESCAPE*
 T)

(RPAQ? *PRINT-CASE*
 (QUOTE :UPCASE))

(RPAQ? *PRINT-GENSYM*
 T)

(RPAQ? *PRINT-LEVEL*
 NIL)

(RPAQ? *PRINT-LENGTH*
 NIL)

(RPAQ? *PRINT-PRETTY*
 NIL)

(RPAQ? *PRINT-CIRCLE*
 NIL)

(RPAQ? *PRINT-ARRAY*
 NIL)

(RPAQ? *PRINT-CIRCLE-HASHTABLE*
 NIL)

(RPAQ? *PACKAGE*
 NIL)

(RPAQ? *KEYWORD-PACKAGE*
 NIL)

(RPAQ? *INTERLISP-PRIN1-CASE*
 (QUOTE :UPCASE))

(RPAQ? \DEFPRINTFNS
 NIL)



(* ; "PRINT internals")


(DEFINEQ

(PRINT-CIRCLE-LOOKUP

  [CL:LAMBDA (OBJECT)
         (DECLARE
 (SPECVARS *PRINT-CIRCLE-HASHTABLE* *PRINT-CIRCLE-NUMBER* *READTABLE*))

                                                             (* jrb: "17-Jun-86 13:51")

         (CL:BLOCK PRINT-CIRCLE-LOOKUP 
                      (* jrb: " 9-Jun-86 18:21")

                (LET ((TABLEENTRY (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)))
                     (CASE TABLEENTRY (T1 (VALUES NIL NIL))
                           (T2 (VALUES (PROG1 (CONCAT (CHARACTER (fetch
 (READTABLEP HASHMACROCHAR)
                                                                    of
 *READTABLE*))
                                                     *PRINT-CIRCLE-NUMBER* "=")
                                              (SETF (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
                                                    *PRINT-CIRCLE-NUMBER*)
                                              (INCF *PRINT-CIRCLE-NUMBER*))
                                      T))
                           (OTHERWISE (CL:IF (NUMBERP TABLEENTRY)
                                             (VALUES (CONCAT (CHARACTER (fetch
 (READTABLEP 
                                                                                      HASHMACROCHAR)
                                                                           of
 *READTABLE*))
                                                            TABLEENTRY "#")
                                                    NIL)
                                             (CL:ERROR "Print-circle-lookup hashtable error!"])

(PRINT-CIRCLE-LABEL-P

  [CL:LAMBDA (OBJECT)
                                        (* jrb: "30-Jun-86 23:04")

         (DECLARE
 (SPECIAL *PRINT-CIRCLE-HASHTABLE*))
         (CL:BLOCK PRINT-CIRCLE-LABEL-P (LET ((TABLEENTRY (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)))
                                             (COND
                                                ((EQ TABLEENTRY (QUOTE T2)))
                                                ((INTEGERP TABLEENTRY)
                                                 TABLEENTRY)
                                                (T NIL])

(PRINT-CIRCLE-SCAN

  [CL:LAMBDA (OBJECT)
                                        (* jrb: "17-Jun-86 13:56")

         (DECLARE
 (SPECIAL *PRINT-ARRAY*))
         (CL:BLOCK PRINT-CIRCLE-SCAN (TYPECASE OBJECT [CONS (CL:WHEN (NOT (PRINT-CIRCLE-ENTER
 OBJECT)
                                                                          )
                                                                   (PRINT-CIRCLE-SCAN
 (CAR OBJECT))
                                                                   (PRINT-CIRCLE-SCAN
 (CDR OBJECT]
                                            ((ARRAY T)
                                             (CL:WHEN (AND *PRINT-ARRAY* (NOT (PRINT-CIRCLE-ENTER

                                                                               OBJECT)))
                                                             (* 

                                                   "No need to walk array if we're not printing them")

                                                    (LET* ((ASIZE (ARRAY-TOTAL-SIZE OBJECT))
                                                           (VARRAY (CL:IF (> (ARRAY-RANK OBJECT)
                                                                             1)
                                                                          (MAKE-ARRAY ASIZE 
                                                                                 :DISPLACED-TO OBJECT
                                                                                 )
                                                                          OBJECT)))
                                                          (DOTIMES (X ASIZE)
                                                                 (PRINT-CIRCLE-SCAN
 (AREF VARRAY X])

(PRINT-CIRCLE-ENTER

  [CL:LAMBDA (OBJECT)
         (DECLARE
 (SPECIAL *PRINT-CIRCLE-HASHTABLE* THERE-ARE-CIRCLES))

                                                             (* jrb: "17-Jun-86 13:59")

         (CL:BLOCK PRINT-CIRCLE-ENTER 
                       (* jrb: " 9-Jun-86 18:26")

                (CASE (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
                      (NIL (SETF (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
                                 (QUOTE T1))
                           NIL)
                      (T1 (SETF (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
                                (QUOTE T2))
                          (SETQ THERE-ARE-CIRCLES T)
                          T)
                      (T2 T)
                      (OTHERWISE (CL:ERROR "Print-circle-enter hashtable error!"])
)
(DEFINEQ

(\PRINDATUM

  [LAMBDA (X STREAM CPL)
                                     (* gbn " 7-Aug-86 16:20")

    (SELECTC (NTYPX X)
        (\LITATOM (\LITPRIN
 X STREAM))
        (\LISTP (OR CPL (SETQ CPL 0))
                [LET (LABEL FIRSTTIME)
                     (if
 *PRINT-CIRCLE-HASHTABLE*
                         then
 (MULTIPLE-VALUE-SETQ (LABEL FIRSTTIME)
                                     (PRINT-CIRCLE-LOOKUP
 X)))
                     [if
 LABEL
                         then
 (\CKPOSSOUT
 STREAM LABEL)
                              (CL:WHEN FIRSTTIME (\CKPOSBOUT
 STREAM (CHARCODE SPACE]
                     (COND
                        ((AND LABEL (NOT FIRSTTIME))         (* Second reference -

                                                             just print label)

                         NIL)
                        ((AND *PRINT-LEVEL* (ILEQ *PRINT-LEVEL* CPL))
                         (\ELIDE.PRINT.ELEMENT
 STREAM))
                        (T (PROG (CDRCNT)
                                 [COND
                                    (*PRINT-LENGTH* (SETQ CDRCNT (COND
                                                                    ((fetch
 (READTABLEP COMMONLISP)
                                                                        of
 *READTABLE*)
                                                                     0)
                                                                    (T 
                                                             (* Interlisp print depth is 

                                                             triangular, Common Lisp isn't)

                                                                       [COND
                                                                          ((IGEQ CPL *PRINT-LENGTH*)
                                                             (* We would just print "(--)" so it's 

                                                             nicer to print "&")

                                                                           (RETURN (

                                                                                 \ELIDE.PRINT.ELEMENT

                                                                                    STREAM]
                                                                       CPL]
                                 (add
 CPL 1)                 (* Recursive calls will be at 1 

                                                             greater depth)

                                 (\CKPOSBOUT
 STREAM (CHARCODE %())
                             LP  [COND
                                    ((AND CDRCNT (IGREATERP (add
 CDRCNT 1)
                                                        *PRINT-LENGTH*))
                                                             (* have printed as many elements as 

                                                             allowed)

                                     (\ELIDE.PRINT.TAIL
 STREAM T))
                                    (T (\PRINDATUM
 (CAR X)
                                              STREAM CPL)
                                       (COND
                                          ((LISTP (SETQ X (CDR X)))
                                           (\CKPOSBOUT
 STREAM (CHARCODE SPACE))
                                           (if
 (AND *PRINT-CIRCLE-HASHTABLE* (PRINT-CIRCLE-LABEL-P

                                                                              X))
                                               then
          (* "Must print as a dotted tail")

                                                    (\CKPOSSOUT
 STREAM ". ")
                                                    (\PRINDATUM
 X STREAM CPL)
                                             else
 (GO LP)))
                                          (X                 (* Dotted tail)

                                             (\CKPOSSOUT
 STREAM " . ")
                                             (\PRINDATUM
 X STREAM]
                                 (\CKPOSBOUT
 STREAM (CHARCODE ")"])
        ((LIST \SMALLP \FIXP) 
             (WITH-RESOURCES (\NUMSTR \NUMSTR1)
                    (\CKPOSSOUT
 STREAM (\CONVERTNUMBER
 X (\CHECKRADIX *PRINT-BASE*)
                                              T
                                              (AND *PRINT-RADIX* *READTABLE*)
                                              \NUMSTR \NUMSTR1))))
        (\FLOATP [WITH-RESOURCES (\NUMSTR \NUMSTR1)
                        (\CKPOSSOUT
 STREAM (\CONVERT.FLOATING.NUMBER X \NUMSTR \NUMSTR1
                                                  (COND
                                                     ((AND (PNAMESTREAMP
 STREAM)
                                                           (NOT PRXFLG))
                                                             (* The pname of a number is unaffected 

                                                             by RADIX unless PRXFLG is true.

                                                             This seems silly, but assorted code 

                                                             will break otherwise)

                                                      T)
                                                     (T \FLOATFORMAT])
        (\STRINGP (\PRINSTRING
 X STREAM))
        (\STACKP (\PRINSTACKP
 X STREAM))
        (COND
           ((\INSTANCE-P X (QUOTE T))                        (* this is a common-loops object, 

                                                             since it is a sub-class of t)

            (PRINT-INSTANCE X STREAM 0))
           (T (LET* ((TYPE (TYPENAME X))
                     (FN (FASSOC TYPE \DEFPRINTFNS)))
                    (COND
                       [[OR (NULL FN)
                            (NULL (SETQ FN (LET [(*PRINT-LEVEL* (AND *PRINT-LEVEL*
                                                                     (IDIFFERENCE *PRINT-LEVEL*
                                                                            (OR CPL 0]
                                                             (* This way recursive calls to PRINT 

                                                             etc will be at the "right" level)

                                                (APPLY* (CDR FN)
                                                       X STREAM 0]
                                                             (* No defined printer, or printer 

                                                             declined to do anything)

                        (COND
                           ((fetch
 (READTABLEP COMMONLISP) of
 *READTABLE*)
                            (.SPACECHECK. STREAM 2)
                            (\OUTCHAR
 STREAM (fetch
 (READTABLEP HASHMACROCHAR) of
 *READTABLE*))
                            (\OUTCHAR
 STREAM (CHARCODE "<"))
                            (AND TYPE (\LITPRIN
 TYPE STREAM))
                            (\CKPOSSOUT
 STREAM " @ ")
                            (\PRINTADDR
 X STREAM)
                            (\CKPOSBOUT
 STREAM (CHARCODE ">")))
                           (T (\CKPOSBOUT
 STREAM (CHARCODE {))
                              (AND TYPE (\LITPRIN
 TYPE STREAM))
                              (\CKPOSBOUT
 STREAM (CHARCODE }))
                              (\OUTCHAR
 STREAM (CHARCODE "#"))
                              (\PRINTADDR
 X STREAM]
                       ((LISTP FN)
          
          (* PRIN1 the CAR (usually a macro char) and PRIN2 the CDR.

          Nowadays there is little reason for a defprint fn to not do its own printing)


                        (AND (CAR FN)
                             (LET (*PRINT-ESCAPE*)
                                  (\PRINDATUM
 (CAR FN)
                                         STREAM)))
                        (AND (CDR FN)
                             (\PRINDATUM
 (CDR FN)
                                    STREAM CPL])

(\ELIDE.PRINT.ELEMENT

  [LAMBDA (STREAM)
                                           (* jrb: "29-Jun-86 21:05")

    (\OUTCHAR
 STREAM (\ELIDE.ELEMENT.CHAR
])

(\ELIDE.ELEMENT.CHAR

  [LAMBDA NIL
                                                (* jrb: "29-Jun-86 21:04")

    (COND
       ((fetch
 (READTABLEP COMMONLISP) of
 *READTABLE*)
        (fetch
 (READTABLEP HASHMACROCHAR) of
 *READTABLE*))
       (T (CHARCODE "&"])

(\ELIDE.PRINT.TAIL

  [LAMBDA (STREAM NOSPACEP)
                                  (* jrb: "29-Jun-86 21:06")

          
          (* * Prints the appropriate elision indicator for elements beyond *PRINT-DEPTH* 

          according to the read table we're using.

          Prints first a space unless NOSPACEP)


    [COND
       ((NOT NOSPACEP)
        (\OUTCHAR
 STREAM (CHARCODE SPACE]
    (\SOUT
 (\ELIDE.TAIL.STRING
)
           STREAM])

(\ELIDE.TAIL.STRING

  [LAMBDA NIL
                                                (* jrb: "29-Jun-86 21:05")

    (COND
       ((fetch
 (READTABLEP COMMONLISP) of
 *READTABLE*)
        "...")
       (T "--"])

(\CKPOSBOUT

  [LAMBDA (STREAM X)
                                         (* rmk: "21-OCT-83 12:32")

    (.SPACECHECK. STREAM 1)
    (\OUTCHAR
 STREAM X])

(\CKPOSSOUT

  [LAMBDA (STREAM X)
                                         (* rmk: "21-OCT-83 12:32")

    (.SPACECHECK. STREAM (\NSTRINGCHARS X))
    (for
 I instring
 X do
 (\OUTCHAR
 STREAM I])

(\CONVERTNUMBER

  [LAMBDA (N R IGNORE RDTBL NS NSB)
                          (* bvm: "11-May-86 15:05")

          
          (* * Convert integer N to a string in radix R.

          RDTBL governs whether radix qualifiers appear.

          NS is a scratch promised to be of sufficient length;

          NSB is a scratch string pointer. IGNORE is obsolete flag for printing unsigned 

          numbers)


    (COND
       ((EQ N 0)
        "0")
       (T (LET* ((SIGN)
                 [X (COND
                       ((GEQ N 0)
                        N)
                       (T (SETQ SIGN (IMINUS N]
                 [POS (\NSTRINGCHARS (\DTEST NS (QUOTE STRINGP]
                 (END (SUB1 POS))
                 DIDQ)
                (COND
                   ((AND (EQ R 8)
                         RDTBL
                         (NOT (fetch
 (READTABLEP COMMONLISP) of
 RDTBL))
                         (IGREATERP X 7))                    (* Octal numbers have Q suffix)

                    (RPLCHARCODE NS (add
 END 1)
                           (CHARCODE Q))
                    (SETQ DIDQ T)))
                (repeatuntil
 (EQ X 0) do
 [RPLCHARCODE NS (add
 POS -1)
                                                (LET ((DIGIT (IREMAINDER X R)))
                                                     (COND
                                                        ((ILESSP DIGIT 10)
                                                         (IPLUS DIGIT (CHARCODE 0)))
                                                        (T   (* For radices higher than 10, use 

                                                             letters of alphabet from A on up)

                                                           (IPLUS (IDIFFERENCE DIGIT 10)
                                                                  (CHARCODE A]
                                         (SETQ X (IQUOTIENT X R)))
                [COND
                   (SIGN (RPLCHARCODE NS (add
 POS -1)
                                (CHARCODE -
]
                [COND
                   ((AND (NEQ R 10)
                         RDTBL
                         (NOT DIDQ)
                         (OR (GREATERP N 9)
                             (GEQ N R)))                     (* Prepend a radix qualifier)

                    [SELECTQ R
                        (16 (RPLCHARCODE NS (add
 POS -1)
                                   (CHARCODE x)))
                        (8 (RPLCHARCODE NS (add
 POS -1)
                                  (CHARCODE o)))
                        (2 (RPLCHARCODE NS (add
 POS -1)
                                  (CHARCODE b)))
                        (PROGN (RPLCHARCODE NS (add
 POS -1)
                                      (CHARCODE r))
                               (RPLCHARCODE NS (add
 POS -1)
                                      (IPLUS (CHARCODE 0)
                                             (IMOD R 10)))
                               (COND
                                  ((GEQ R 10)
                                   (RPLCHARCODE NS (add
 POS -1)
                                          (IPLUS (CHARCODE 0)
                                                 (IQUOTIENT R 10]
                    (RPLCHARCODE NS (add
 POS -1)
                           (fetch
 (READTABLEP HASHMACROCHAR) of
 RDTBL]
                (SUBSTRING NS POS END NSB])

(\LITPRIN

  [LAMBDA (X STREAM)
                                         (* bvm: "30-Sep-86 00:12")

    (DECLARE
 (USEDFREE \THISFILELINELENGTH *PRINT-ESCAPE* *READTABLE* *PACKAGE* *PRINT-GENSYM* 
                    *PRINT-CASE*))
    (COND
       (*PRINT-ESCAPE* (LET ((RDTBL *READTABLE*)
                             PKG PKGSEPR)
                            [COND
                               (*PACKAGE* 
          (* ; "This is NIL until packages get turned on")

                                      (COND
                                         ((EQ *PACKAGE* (SETQ PKG (fetch
 (SYMBOL PACKAGE)
                                                                     of
 X)))

                                                         (* ; "No prefix needed in current package")

                                          (SETQ PKG NIL))
                                         [(NULL PKG)

                                                  (* ; "Uninterned.  Print something if flag is on")

                                          (COND
                                             (*PRINT-GENSYM* 

                                                  (* ; 

         "Print #: as prefix.  Not PACKAGECHAR here because colon hardwired into hashmacro dispatch.")

                                                    (RPLCHARCODE (SETQ PKGSEPR (ALLOCSTRING
                                                                                2
                                                                                (CHARCODE ":")))
                                                           1
                                                           (fetch
 (READTABLEP HASHMACROCHAR)
                                                              of
 RDTBL]
                                         ((EQ PKG *KEYWORD-PACKAGE*)

                                                        (* ; "Keywords get single colon, no prefix")

                                          (SETQ PKGSEPR (ALLOCSTRING 1 (fetch
 (READTABLEP PACKAGECHAR
                                                                                     ) of
 RDTBL)))
                                          (SETQ PKG NIL))
                                         ((FIND-EXACT-SYMBOL X *PACKAGE*)

                                                  (* ;; "Symbol is accessible in current package, either by being imported or by inheritance.  This is a messy test, which is why we test for special case of PKG being the current package first above.  No prefix needed here.")

                                          (SETQ PKG NIL))
                                         (T 
      (* ;; "Package qualifier is needed; we need only know now whether symbol is  internal or external in its home package.")

                                            (SETQ PKGSEPR (ALLOCSTRING (COND
                                                                          ((EQ X (
                                                                                 FIND-EXTERNAL-SYMBOL
                                                                                  X PKG))

                                                      (* ; "X is external in PKG, use single colon")

                                                                           1)
                                                                          (T 2))
                                                                 (fetch
 (READTABLEP PACKAGECHAR)
                                                                    of
 RDTBL]
                            (\LITPRIN.INTERNAL
 X RDTBL STREAM (AND PKG (PACKAGE-NAME-AS-SYMBOL PKG))
                                   PKGSEPR \THISFILELINELENGTH)))
       (T (.SPACECHECK. STREAM (\NATOMCHARS X))
          (for
 C inatom
 X bind
 (DOWNCASE _ (AND (EQ *PRINT-CASE* (QUOTE :DOWNCASE))
                                                (fetch
 (READTABLEP CASEINSENSITIVE) of
 *READTABLE*)))
             do
 (\OUTCHAR
 STREAM (COND
                                    [(AND DOWNCASE (LEQ C (CHARCODE Z))
                                          (GEQ C (CHARCODE A)))
                                     (IPLUS C (IDIFFERENCE (CHARCODE a)
                                                     (CHARCODE A]
                                    (T C])

(\LITPRIN.INTERNAL

  [LAMBDA (SYMBOL RDTBL STREAM PKGNAME PKGSEPR CHECKLENGTH)
  (* bvm: " 9-May-86 23:07")

          
          (* * Print SYMBOL to STREAM according to RDTBL, preceded by PKGNAME

          (if non-NIL) and/or PKGSEPR. PKGNAME is a symbol, PKGSEPR is a string.

          If CHECKLENGTH is true, need to check that there is room for printing all three 

          parts on this line; else caller has verified that there is room)


    (LET ((PNAMELENGTH (\NATOMCHARS SYMBOL))
          (ESCAPE (fetch
 (READTABLEP ESCAPECHAR) of
 RDTBL))
          (MULTESCAPE (fetch
 (READTABLEP MULTESCAPECHAR) of
 RDTBL))
          USEMULTESCAPE CASEBASE SA SYN NESCAPES CHECKESCAPE FIRSTESCAPE)
         (COND
            [(OR CHECKLENGTH (NEQ MULTESCAPE 0))             (* have to check now if linelength 

                                                             matters or we plan to use multiple 

                                                             escapes)

             (SETQ NESCAPES (\SYMBOL.ESCAPE.COUNT
 SYMBOL RDTBL (NULL CHECKLENGTH)))
             (COND
                ((EQ NESCAPES -1)                            (* Pname is numeric and we don't have 

                                                             a multiple escape available--need to 

                                                             escape first char)

                 (SETQ NESCAPES 1)
                 (SETQ FIRSTESCAPE T))
                ((ILESSP NESCAPES 0)                         (* Use multiple escapes)

                 (SETQ NESCAPES (IMINUS NESCAPES))
                 (SETQ USEMULTESCAPE T))
                ((NEQ NESCAPES 0)
                 (SETQ CHECKESCAPE T]
            (T                                               (* if we don't check now then have to 

                                                             check while printing)

               (SETQ CHECKESCAPE T)))
         [COND
            (CHECKLENGTH                                     (* Verify space for everything)

                   (.SPACECHECK. STREAM (IPLUS PNAMELENGTH NESCAPES (COND
                                                                       (PKGNAME 
                                                             (* How much space to print package 

                                                             name)

                                                                              (IABS (

                                                                                 \SYMBOL.ESCAPE.COUNT

                                                                                     PKGNAME RDTBL)))
                                                                       (T 0))
                                               (COND
                                                  (PKGSEPR   (* Extra characters between pkg name 

                                                             and symbol name)

                                                         (\NSTRINGCHARS PKGSEPR))
                                                  (T 0]
          
          (* * First print any needed package qualifier)


         (COND
            (PKGNAME                                         (* Print package name, don't check 

                                                             length)

                   (\LITPRIN.INTERNAL
 PKGNAME RDTBL STREAM)))
         (COND
            (PKGSEPR (\SOUT
 PKGSEPR STREAM)))
         (COND
            (FIRSTESCAPE                                     (* Need an escape character at start 

                                                             to keep atom from being interpreted as 

                                                             number)

                   (\OUTCHAR
 STREAM ESCAPE)))
         (COND
            (USEMULTESCAPE                                   (* Surround pname with multiple escape 

                                                             char, only escape internal escapes)

                   (\OUTCHAR
 STREAM MULTESCAPE)
                   (for
 C inatom
 SYMBOL do
 (COND
                                              ((OR (EQ C MULTESCAPE)
                                                   (EQ C ESCAPE))
                                               (\OUTCHAR
 STREAM ESCAPE)))
                                           (\OUTCHAR
 STREAM C))
                   (\OUTCHAR
 STREAM MULTESCAPE))
            ((AND (EQ PNAMELENGTH 1)
                  (EQ (CHCON1 SYMBOL)
                      (CHARCODE ".")))                       (* have to handle period special 

                                                             because it is only special in a dotted 

                                                             context)

             (\OUTCHAR
 STREAM ESCAPE)
             (\OUTCHAR
 STREAM (CHARCODE ".")))
            (T [COND
                  (CHECKESCAPE (SETQ CASEBASE (AND (fetch
 (READTABLEP CASEINSENSITIVE) of
 RDTBL)
                                                   (fetch
 (ARRAYP BASE) of
 UPPERCASEARRAY)))
                         (SETQ SA (fetch
 READSA of
 RDTBL]
               (for
 C inatom
 SYMBOL bind
 (FIRSTFLG _ T)
                                         [DOWNCASE _ (AND (fetch
 (READTABLEP CASEINSENSITIVE)
                                                             of
 RDTBL)
                                                          (EQ *PRINT-CASE* (QUOTE :DOWNCASE]
                  do
 [COND
                        ([AND CHECKESCAPE (OR (AND CASEBASE (ILEQ C \MAXTHINCHAR)
                                                   (NEQ C (\GETBASEBYTE CASEBASE C)))
                                              (AND (fetch
 (READCODE ESCQUOTE)
                                                      of
 (SETQ SYN (\SYNCODE SA C)))
                                                   (OR FIRSTFLG (fetch
 (READCODE INNERESCQUOTE)
                                                                   of
 SYN]
                                                             (* Need to escape if: character is 

                                                             lower case when case-insensitive, or 

                                                             character intrinsically needs escape.)

                         (\OUTCHAR
 STREAM ESCAPE)
                         (\OUTCHAR
 STREAM C))
                        (T (\OUTCHAR
 STREAM (COND
                                               [(AND DOWNCASE (LEQ C (CHARCODE Z))
                                                     (GEQ C (CHARCODE A)))
                                                (IPLUS C (IDIFFERENCE (CHARCODE a)
                                                                (CHARCODE A]
                                               (T C]
                     (SETQ FIRSTFLG NIL])

(\SYMBOL.ESCAPE.COUNT

  [LAMBDA (SYMBOL RDTBL INEXACTOK)
                           (* bvm: " 8-Aug-86 12:31")

          
          (* * "Counts the number of escape characters needed to print SYMBOL by RDTBL.  If RDTBL has a multiple-escape character, then we return a negative count if we're assuming it is used instead of single escapes;  else a positive count.  The special value -1 means the symbol is numeric, so must be quoted, but no multiple escape is available, so just escape the first character.  If INEXACTOK is true and we discover we want to use multiple escape char, returns -2 immediately.")


    (for
 C inatom
 SYMBOL bind
 (RESULT _ 0)
                              (NESCAPES _ 0)
                              (FIRSTFLG _ T)
                              (MULTESCAPE _ (fetch
 (READTABLEP MULTESCAPECHAR) of
 RDTBL))
                              (ESCAPE _ (fetch
 (READTABLEP ESCAPECHAR) of
 RDTBL))
                              (CASEBASE _ (AND (fetch
 (READTABLEP CASEINSENSITIVE) of
 RDTBL)
                                               (fetch
 (ARRAYP BASE) of
 UPPERCASEARRAY)))
                              (SA _ (fetch
 READSA of
 RDTBL))
                              SYN first
 (if
 (EQ MULTESCAPE 0)
                                            then
             (* "Can't use multiple-escape")

                                                 (SETQ MULTESCAPE NIL))
       do
 [if
 [OR (AND CASEBASE (ILEQ C \MAXTHINCHAR)
                       (NEQ C (\GETBASEBYTE CASEBASE C)))
                  (AND (fetch
 (READCODE ESCQUOTE) of
 (SETQ SYN (\SYNCODE SA C)))
                       (OR FIRSTFLG (fetch
 (READCODE INNERESCQUOTE) of
 SYN]
              then
                                           (* "Need protection if char is lowercase in a case-insensitive read table or the read table says it needs it")

                   (add
 RESULT 1)
                   (if
 MULTESCAPE
                       then
 (if
 (OR (EQ C MULTESCAPE)
                                    (EQ C ESCAPE))
                                then
                         (* 

                                                            "These have to be escaped no matter what")

                                     (add
 NESCAPES 1)
                              elseif
 (AND INEXACTOK (GREATERP (DIFFERENCE RESULT NESCAPES)
                                                           1))
                                then
                         (* 

     "If at least 2 chars need escaping, better to use multiple escape, and we can quit scanning now")

                                     (RETURN -2]
          (SETQ FIRSTFLG NIL)
       finally
 (RETURN (if
 (EQ RESULT 0)
                           then
                              (* 

                                                "No funny chars, check for some other perverse cases")

                                (LET ((LEN (\NATOMCHARS SYMBOL)))
                                     (if
 (EQ LEN 0)
                                         then
                (* 

                        "The bletcherous null symbol.  Shouldn't be allowed to create this, grumble.")

                                              (if
 MULTESCAPE
                                                  then
       (* "Can print as ||")

                                                       -2
                                                else
         (* "Single escape can't work")

                                                     0)
                                       elseif
 (AND (EQ LEN 1)
                                                   (EQ C (CHARCODE ".")))
                                         then
                (* 

                                                 "Special case, dot is always escaped when by itself")

                                              1
                                       elseif
 (\NUMERIC.PNAMEP
 SYMBOL
                                                     (if
 (fetch
 (READTABLEP COMMONLISP) of
 RDTBL)
                                                         then
 *READ-BASE*
                                                       else
 10))
                                         then
                (* "Is numeric, must escape it.  Note that if pname is numeric, there can't be any special chars inside it needing escaping.  We wait until now to test numeric on the grounds that it is more likely we will print a symbol with escapable chars than one that is a potential number.")

                                              (if
 MULTESCAPE
                                                  then
       (* 

                                                   "Nicer to use multiple escape around whole symbol")

                                                       -2
                                                else
         (* "Say to escape first char")

                                                     -1)
                                       else
 0))
                         elseif
 (AND MULTESCAPE (GREATERP (DIFFERENCE RESULT NESCAPES)
                                                       1))
                           then
                              (* "The number of characters needing escaping, not counting the ones that have to be escaped in any case, is at least two.  Use two multiple-escapes and NESCAPES regular escapes for the internal escapes = -(NESCAPES+2) total extra characters")

                                (IDIFFERENCE -2 NESCAPES)
                         else
 RESULT])

(\NUMERIC.PNAMEP

  [LAMBDA (SYMBOL RADIX)
                                     (* bvm: " 4-Aug-86 14:56")

          
          (* * True if the chars in SYMBOL are a potential number in RADIX, which 

          defaults to the current read base (according to current read table))


    (LET
     ((LASTCHARTYPE (QUOTE FIRST))
      (MAXALPHADIGIT (IPLUS (CHARCODE A)
                            (IDIFFERENCE (OR RADIX (if
 (fetch
 (READTABLEP COMMONLISP) of
 *READTABLE*)
                                                       then
 *READ-BASE*
                                                     else
 10))
                                   11)))
      SEENALPHADIGITS SEENDIGITS SEENDECPT SEENTIGHTLETTERS) (* If RADIX is bigger than 10, this 

                                                             allows alphabetic digits)

     (for
 C inpname
 SYMBOL
        do
 
          
          (* The inpname is a nicety so it works on strings too

          (useful for testing) -

          Note that we are assuming a partitioning of character space as follows:

          (-

          + / decpt) (digits) (A-Z) (_ ^) (a-z))


           (SETQ LASTCHARTYPE
            (if
 (ILESSP C (CHARCODE A))
                then
                                         (* Numeric or funny char)

                     (if
 (ILESSP C (CHARCODE 0))
                         then
 (SELCHARQ C
                                   ((- +)                    (* Signs anywhere but end)

                                        (QUOTE SIGN))
                                   (%. (if
 SEENALPHADIGITS
                                           then
              (* Can't have decimal point in other 

                                                             radices, so if we saw combinations of 

                                                             chars that would have been invalid in 

                                                             radix 10, bomb out)

                                                (if
 SEENTIGHTLETTERS
                                                    then
 (RETURN NIL))
                                                (SETQ SEENALPHADIGITS NIL))
                                       (SETQ MAXALPHADIGIT 0)
                                       (SETQ SEENDECPT T))
                                   (/ (if
 (EQ LASTCHARTYPE (QUOTE FIRST))
                                          then
               (* Can't start with ratio marker)

                                               (RETURN NIL)))
                                   (RETURN NIL))
                       elseif
 (ILEQ C (CHARCODE 9))
                         then
                                (* digit)

                              (SETQ SEENDIGITS T)
                              (QUOTE DIGIT)
                       else
 (RETURN NIL))
              elseif
 (IGREATERP C (CHARCODE z))
                then
                                         (* Out in the wilderness.)

                     (RETURN NIL)
              elseif
 (PROGN [if
 (IGEQ C (CHARCODE a))
                                then
                         (* Raise it)

                                     (SETQ C (IDIFFERENCE C (IDIFFERENCE (CHARCODE a)
                                                                   (CHARCODE A]
                            (ILEQ C (CHARCODE Z)))
                then
                                         (* Letter)

                     (if
 (ILEQ C MAXALPHADIGIT)
                         then
                                (* Letter is a digit in this base.

                                                             Can't be digit in number with decimal 

                                                             pt)

                              (SETQ SEENALPHADIGITS T)
                              (SELECTQ LASTCHARTYPE
                                  ((LETTER FIRST)            (* Two letters in a row or started 

                                                             with letter. Notice this in case a dec 

                                                             pt comes along)

                                       (SETQ SEENTIGHTLETTERS T))
                                  NIL)
                       else
                                  (* Potential number marker --

                                                             only if not next to another letter)

                            (SELECTQ LASTCHARTYPE
                                ((LETTER FIRST) 
                                     (RETURN NIL))
                                NIL))
                     (QUOTE LETTER)
              elseif
 (OR (EQ C (CHARCODE _))
                         (EQ C (CHARCODE ^)))
                then
                                         (* Extension chars, not used now but 

                                                             maybe some day. We're supposed to 

                                                             escape these)

                     NIL
              else
 (RETURN NIL))) finally
                    (* Success if there was at least one 

                                                             digit and didn't end in a sign)

                                        (RETURN (AND (OR SEENDIGITS SEENALPHADIGITS)
                                                     (NEQ LASTCHARTYPE (QUOTE SIGN])

(\PRINSTACKP

  [LAMBDA (X STREAM)
                                         (* bvm: "11-May-86 16:09")

          
          (* * Print stackp as addr/framename. If stackp is released or framename is not 

          a symbol, print mumble)


    (.SPACECHECK. STREAM (IPLUS 1 (CONSTANT (NCHARS "<StackP "))
                                (PROGN                       (* Longest stack address is "177,177777")

                                       10)
                                1
                                (COND
                                   ((RELSTKP X)
                                    (CONSTANT (NCHARS "released")))
                                   ((LITATOM (STKNAME X))
                                    (\NATOMCHARS (STKNAME X)))
                                   (T 6))
                                1))
    (\OUTCHAR
 STREAM (fetch
 (READTABLEP HASHMACROCHAR) of
 *READTABLE*))
    (\SOUT
 "<StackP " STREAM)
    (\PRINTADDR
 X STREAM)
    (\OUTCHAR
 STREAM (CHARCODE /))
    (COND
       ((RELSTKP X)
        (\SOUT
 "released" STREAM))
       ((LITATOM (SETQ X (STKNAME X)))
        (\LITPRIN
 X STREAM))
       (T (\SOUT
 "*form*" STREAM)))
    (\OUTCHAR
 STREAM (CHARCODE >])

(\PRINTADDR

  [LAMBDA (X STREAM)
                                         (* bvm: "11-May-86 15:13")

    (WITH-RESOURCES (\NUMSTR \NUMSTR1)
           (SELECTQ (SYSTEMTYPE)
               (D (\CKPOSSOUT
 STREAM (\CONVERTNUMBER
 (\HILOC X)
                                            8 NIL NIL \NUMSTR \NUMSTR1))
                  (\CKPOSBOUT
 STREAM (CHARCODE ,))
                  (\CKPOSSOUT
 STREAM (\CONVERTNUMBER
 (\LOLOC X)
                                            8 NIL NIL \NUMSTR \NUMSTR1)))
               (JERICHO (\CKPOSSOUT
 STREAM (\CONVERTNUMBER
 (LOGAND \ADDRMASK (LOC X))
                                                  8 NIL NIL \NUMSTR \NUMSTR1)))
               (VAX (\CKPOSSOUT
 STREAM (\CONVERTNUMBER
 (LOC X)
                                              16 T NIL \NUMSTR \NUMSTR1)))
               ((TENEX TOPS-20) 
                    (\CKPOSSOUT
 STREAM (\CONVERTNUMBER
 (LOC X)
                                              8 T NIL \NUMSTR \NUMSTR1)))
               (SYSTEMTYPEPUNT (QUOTE (\PRINDATUM X])

(\PRINSTRING

  [LAMBDA (X STREAM)
                                         (* bvm: "11-May-86 15:08")

    (COND
       [*PRINT-ESCAPE*                                       (* Print with double quotes and 

                                                             escaped as needed)

              (LET ((ESC (fetch
 (READTABLEP ESCAPECHAR) of
 *READTABLE*)))
                   [.SPACECHECK. STREAM (IPLUS 2 (\NSTRINGCHARS X)
                                               (for
 C instring
 X
                                                  count
 (OR (EQ C (CHARCODE %"))
                                                            (EQ C ESC]
                   (\OUTCHAR
 STREAM (CHARCODE %"))
                   (for
 C instring
 X do
 (COND
                                           ((OR (EQ C (CHARCODE %"))
                                                (EQ C (CHARCODE LF))
                                                (EQ C ESC))  (* VM says only %" is escaped no 

                                                             matter what stringdelim's are.)

                                            (\OUTCHAR
 STREAM ESC)))
                                        (\OUTCHAR
 STREAM C))
                   (\OUTCHAR
 STREAM (CHARCODE %"]
       (T (.SPACECHECK. STREAM (\NSTRINGCHARS X))
          (\SOUT
 X STREAM])

(\SOUT

  [LAMBDA (X STREAM)
                                         (* rmk: "21-OCT-83 12:32")

    (for
 I instring
 X do
 (\OUTCHAR
 STREAM I])

(\OUTCHAR

  [LAMBDA (STREAM CHARCODE)
                                  (* rmk: " 7-APR-82 00:25")

    (STREAMOP (QUOTE OUTCHARFN)
           STREAM STREAM CHARCODE])

(\FILEOUTCHARFN

  [LAMBDA (STREAM CHARCODE)
                                  (* bvm: "26-Mar-86 10:40")

                                                             (* OUTCHARFN for standard files)

    (COND
       ((EQ CHARCODE (CHARCODE EOL))
        [COND
           [(NOT (\RUNCODED STREAM))                         (* Charset is a constant 0)

            (\BOUT STREAM (\CHARSET (CHARCODE EOL]
           ((EQ (\CHARSET (CHARCODE EOL))
                (ffetch
 CHARSET of
 STREAM)))
           (T (\BOUT STREAM NSCHARSETSHIFT)
              (\BOUT STREAM (freplace
 (STREAM CHARSET) of
 STREAM with
 (\CHARSET (CHARCODE EOL]
        (\BOUT STREAM (SELECTC (ffetch
 EOLCONVENTION of
 STREAM)
                          (CR.EOLC (CHARCODE CR))
                          (LF.EOLC (CHARCODE LF))
                          (CRLF.EOLC (\BOUT STREAM (CHARCODE CR))
          
          (* Don't put out high-order byte preceding LF.

          The CRLF is EOL only if the bytes are immediately adjacent in the stream, with 

          no additional encoding bytes)


                                     (CHARCODE LF))
                          (SHOULDNT)))
        (freplace
 CHARPOSITION of
 STREAM with
 0))
       (T [COND
             ((NOT (\RUNCODED STREAM))
              (\BOUT STREAM (\CHARSET CHARCODE))
              (\BOUT STREAM (\CHAR8CODE CHARCODE)))
             ((EQ (\CHARSET CHARCODE)
                  (ffetch
 CHARSET of
 STREAM))
              (\BOUT STREAM (\CHAR8CODE CHARCODE)))
             (T (\BOUT STREAM NSCHARSETSHIFT)
                (\BOUT STREAM (freplace
 (STREAM CHARSET) of
 STREAM with
 (\CHARSET CHARCODE)))
                (\BOUT STREAM (\CHAR8CODE CHARCODE]
          (freplace
 CHARPOSITION of
 STREAM with
 (PROGN       (* Ugh. Don't overflow)

                                                       (IPLUS16 (ffetch
 CHARPOSITION of
 STREAM)
                                                              1])

(\TTYOUTCHARFN

  [LAMBDA (STREAM CH)
                                        (* hdj "17-Sep-86 19:21")


                                                       (* ;; "OUTCHARFN for TTY when dribble is on")

    (LET ((OP (fetch
 OTHERPROPS of
 STREAM)))
         (LET [(DRIBBLESTREAM (LISTGET OP (QUOTE DRIBBLESTREAM]
              (if
 DRIBBLESTREAM
                  then
 (\OUTCHAR
 DRIBBLESTREAM CH)))
         (FUNCALL (LISTGET OP (QUOTE OLD-OUTCHARFN))
                STREAM CH])
)
(DECLARE: EVAL@COMPILE DONTCOPY 
(DECLARE: EVAL@COMPILE 

[PUTPROPS .FILELINELENGTH. MACRO ((STRM)
                                  (LET ((L (fetch (STREAM LINELENGTH)
                                                  of STRM)))
                                       (SELECTC L (0 (* Some default)
                                                     \LINELENGTH)
                                              (MAX.SMALLP (* Infinite)
                                                     NIL)
                                              L]
)

(* FOLLOWING DEFINITIONS EXPORTED)


(DECLARE: EVAL@COMPILE 

[PUTPROPS .SPACECHECK. MACRO ((STRM N)
                              (AND \THISFILELINELENGTH (IGREATERP (IPLUS N (fetch CHARPOSITION of 
                                                                                  STRM))
                                                              \THISFILELINELENGTH)
                                   (FRESHLINE STRM]
[PUTPROPS \CHECKRADIX MACRO (LAMBDA (R)
                                   (COND ((OR (NOT (SMALLP R))
                                              (ILESSP R 1)
                                              (IGREATERP R 36))
                                          (\INVALID.RADIX R))
                                         (T R]
)


(* END EXPORTED DEFINITIONS)

)
(DEFINEQ

(\INVALID.RADIX

  [LAMBDA (N)
                                                (* bvm: " 5-May-86 10:58")

    (ERROR "Bad value for *print-base*" N])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(SPECVARS \THISFILELINELENGTH)
)



(* ; "Internal printing")


(DEFINEQ

(\MAPPNAME

  [LAMBDA (FN X FLG RDTBL)
                                   (* bvm: "13-May-86 15:05")

          
          (* * Run thru the characters in the pname of X, calling FN on each character.

          For speed, FN is defined to be of the same form as an OUTCHARFN, viz., arglist 

          = (stream char); stream in this case is a dummy)


    (LET ((*PRINT-ESCAPE* FLG)
          [*READTABLE* (COND
                          (FLG (\GTREADTABLE RDTBL))
                          (T (\DTEST *READTABLE* (QUOTE READTABLEP]
          (*PRINT-BASE* (COND
                           (PRXFLG *PRINT-BASE*)
                           (T 10)))
          (*PRINT-RADIX*)
          (*PRINT-LEVEL*)
          (*PRINT-LENGTH*))
         (DECLARE
 (SPECVARS *READTABLE* *PRINT-ESCAPE* *PRINT-BASE* *PRINT-RADIX* *PRINT-LEVEL* 
                         *PRINT-LENGTH*))                    (* numbers print in decimal unless 

                                                             PRXFLG)

         (COND
            ((AND FLG (NEQ *PRINT-BASE* 10))
             (SETQ *PRINT-RADIX* T)))
         (\MAPPNAME.INTERNAL
 FN X])

(\MAPPNAME.INTERNAL

  [LAMBDA (FN X)
                                             (* bvm: "13-May-86 15:01")

    (WITH-RESOURCE (\MAPPNAMESTREAM)
           (replace
 OUTCHARFN of
 \MAPPNAMESTREAM with
 FN)
           (replace
 STRMBOUTFN of
 \MAPPNAMESTREAM with
 FN)   (* Should never use the bout fn, but 

                                                             include it just in case somebody 

                                                             thinks \OUTCHAR = \BOUT)

           (LET (\THISFILELINELENGTH)                        (* Stream has no linelength checks)

                (DECLARE
 (SPECVARS \THISFILELINELENGTH))
                (\PRINDATUM
 X \MAPPNAMESTREAM 0])

(PNAMESTREAMP

  [LAMBDA (STRM)
                                             (* bvm: "24-Mar-86 17:37")

          
          (* * True if STRM is an internal-printing stream for pnames, i.e., one of the 

          values of the \MAPPNAMESTREAM resource)


    (AND (TYPENAMEP STRM (QUOTE STREAM))
         (EQ (fetch
 (STREAM DEVICE) of
 STRM)
             \PNAMEDEVICE])
)
(DECLARE: DONTCOPY 
(DECLARE: EVAL@COMPILE 
[PUTDEF (QUOTE \MAPPNAMESTREAM)
       (QUOTE RESOURCES)
       (QUOTE (NEW (create STREAM DEVICE _ \PNAMEDEVICE ACCESSBITS _ OutputBits LINELENGTH _ 
                          MAX.SMALLP]
)

(DECLARE: EVAL@COMPILE 

(PUTPROPS PNAMESTREAMP DMACRO ((STRM)
                               (EQ (fetch (STREAM DEVICE)
                                          of STRM)
                                   \PNAMEDEVICE)))
)
)
(/SETTOPVAL (QUOTE \\MAPPNAMESTREAM.GLOBALRESOURCE))

(RPAQ? \PNAMEDEVICE
 (NCREATE (QUOTE FDEV)
                           (\GETDEVICEFROMHOSTNAME (QUOTE NULL)
                                  T)))
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \PNAMEDEVICE)
)



(* ; "Obsolete")


(DEFINEQ

(\MAPCHARS

  [LAMBDA (\MAPCHARFN X FLG RDTBL)
                           (* bvm: "13-Mar-86 18:53")

    (DECLARE
 (SPECVARS RDTBL))
          
          (* * Run thru the characters in the pname of X, calling \MAPCHARFN on each 

          character.)


    (\MAPPNAME
 [FUNCTION (LAMBDA (DUMMY CHAR)
                           (SPREADAPPLY* \MAPCHARFN CHAR]
           X FLG RDTBL])
)
(DECLARE: EVAL@COMPILE DOCOPY 

(ADDTOVAR SYSSPECVARS
 *PRINT-BASE* *READ-BASE* *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-CASE* 
                            *PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH* *PRINT-PRETTY* *PRINT-CIRCLE* 
                            *PRINT-ARRAY* *PACKAGE*)
)



(* ; "PRINTNUM and friends")


(DEFINEQ

(PRINTNUM

  [LAMBDA (FORMAT NUMBER FILE)                               (* DECLARATIONS: (RECORD FIXFMT

                                                             (WIDTH RADIX PAD0 LEFTFLUSH))

                                                             (RECORD FLOATFMT (WIDTH DECPART 

                                                             EXPPART PAD0 SIGDIGITS)))

                                                             (* rmk: "17-MAY-82 10:07")

    (DECLARE
 (GLOBALVARS NILNUMPRINTFLG))
    (GLOBALRESOURCE (\NUMSTR \NUMSTR1)
           (PROG (STR WIDTH PAD TEMP RAD (FLOATFLAG (SELECTQ (CAR (LISTP FORMAT))
                                                        (FLOAT T)
                                                        (FIX NIL)
                                                        (LISPERROR "ILLEGAL ARG" FORMAT)))
                      (FMT (CDR FORMAT)))
                 (SETQ WIDTH (fetch
 WIDTH of
 FMT))
                 [SETQ STR (COND
                              ((AND (NULL NUMBER)
                                    NILNUMPRINTFLG))
                              (FLOATFLAG (\CONVERT.FLOATING.NUMBER (FLOAT NUMBER)
                                                \NUMSTR \NUMSTR1 (\CHECKFLTFMT
 FORMAT)))
                              (T (\CONVERTNUMBER
 (OR (FIXP NUMBER)
                                                     (FIXR NUMBER))
                                        (COND
                                           ((SETQ RAD (fetch
 RADIX of
 FMT))
                                            (SETQ TEMP (IABS RAD))
                                            (COND
                                               ((OR (IGREATERP 2 TEMP)
                                                    (IGREATERP TEMP 16))
                                                (\ILLEGAL.ARG RAD)))
                                            TEMP)
                                           (T 10))
                                        (OR (NULL RAD)
                                            (IGREATERP RAD 0))
                                        NIL \NUMSTR \NUMSTR1]
                 (SETQ PAD (COND
                              (WIDTH (IDIFFERENCE WIDTH (NCHARS STR)))
                              (T 0)))
                 [COND
                    ([AND (IGREATERP PAD 0)
                          (OR FLOATFLAG (NULL (fetch
 LEFTFLUSH of
 FMT]
                     (COND
                        ((COND
                            (FLOATFLAG (fetch
 (FLOATFMT PAD0) of
 FMT))
                            (T (fetch
 (FIXFMT PAD0) of
 FMT)))
                         (FRPTQ PAD (PRIN1
 "0" FILE)))
                        (T (SPACES
 PAD FILE]
                 (PRIN1
 STR FILE)
                 (COND
                    ((AND (IGREATERP PAD 0)
                          (NOT FLOATFLAG)
                          (fetch
 LEFTFLUSH of
 FMT))
                     (SPACES
 PAD FILE)))
                 (RETURN NUMBER])

(FLTFMT

  [LAMBDA (FORMAT)
                                           (* bvm: "30-JAN-81 23:20")

                                                             (* numeric arg, as on 10, not allowed)

    (PROG1 \FLOATFORMAT (AND FORMAT (\CHECKFLTFMT
 FORMAT)
                             (SETQ \FLOATFORMAT FORMAT])

(\CHECKFLTFMT

  [LAMBDA (FORMAT)
                                           (* bvm: "29-JAN-81 15:41")

          
          (* * Generates error if FORMAT is not legal FLOAT format:

          (FLOAT WIDTH DECPART EXPPART PAD SIGDIGITS))


    (COND
       ([OR (EQ FORMAT T)
            (AND (EQ (CAR FORMAT)
                     (QUOTE FLOAT))
                 (EVERY (CDR FORMAT)
                        (FUNCTION (LAMBDA (X)
                                    (OR (NULL X)
                                        (FIXP X]
        FORMAT)
       (T (LISPERROR "ILLEGAL ARG" FORMAT])
)
(DECLARE: EVAL@COMPILE 

(PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1))
       (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1)))
)

(RPAQ? NILNUMPRINTFLG
 )
(DECLARE: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 PRINT-CIRCLE-ENTER PRINT-CIRCLE-SCAN PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-LOOKUP)
)
(PUTPROPS APRINT COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (3505 13049 (PRIN1 3515 . 5165) (PRIN2 5167 . 6335) (PRIN3 6337 . 7505) (PRIN4 7507 . 
8681) (PRINT 8683 . 8928) (PRINTCCODE 8930 . 9213) (PRINTLEVEL 9215 . 9969) (RADIX 9971 . 10144) (
SPACES 10146 . 10502) (TERPRI 10504 . 10699) (FRESHLINE 10701 . 11603) (DEFPRINT 11605 . 12112) (
LINELENGTH 12114 . 13047)) (13725 18588 (PRINT-CIRCLE-LOOKUP 13735 . 15351) (PRINT-CIRCLE-LABEL-P 
15353 . 15951) (PRINT-CIRCLE-SCAN 15953 . 17743) (PRINT-CIRCLE-ENTER 17745 . 18586)) (18589 61509 (
\PRINDATUM 18599 . 26822) (\ELIDE.PRINT.ELEMENT 26824 . 26997) (\ELIDE.ELEMENT.CHAR 26999 . 27285) (
\ELIDE.PRINT.TAIL 27287 . 27758) (\ELIDE.TAIL.STRING 27760 . 27984) (\CKPOSBOUT 27986 . 28154) (
\CKPOSSOUT 28156 . 28373) (\CONVERTNUMBER 28375 . 31842) (\LITPRIN 31844 . 36297) (\LITPRIN.INTERNAL 
36299 . 43378) (\SYMBOL.ESCAPE.COUNT 43380 . 49194) (\NUMERIC.PNAMEP 49196 . 54842) (\PRINSTACKP 54844
 . 56109) (\PRINTADDR 56111 . 57192) (\PRINSTRING 57194 . 58596) (\SOUT 58598 . 58766) (\OUTCHAR 58768
 . 58945) (\FILEOUTCHARFN 58947 . 60988) (\TTYOUTCHARFN 60990 . 61507)) (62852 63023 (\INVALID.RADIX 
62862 . 63021)) (63126 65442 (\MAPPNAME 63136 . 64296) (\MAPPNAME.INTERNAL 64298 . 65044) (
PNAMESTREAMP 65046 . 65440)) (66197 66615 (\MAPCHARS 66207 . 66613)) (66937 70943 (PRINTNUM 66947 . 
70004) (FLTFMT 70006 . 70336) (\CHECKFLTFMT 70338 . 70941)))))
STOP