(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")

(FILECREATED "20-Oct-86 22:38:32" {ERIS}<LISPCORE>SOURCES>APRINT.;52
 67955  

      previous date%: "16-Oct-86 21:28:06" {ERIS}<LISPCORE>SOURCES>APRINT.;51)


(* "
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* ':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* ':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 'FDEV (\GETDEVICEFROMHOSTNAME '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
                                                                                   )))))



(* ; "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 'OUTPUT))
           (OBEY-PRINT-LEVEL (OR (ffetch
 (READTABLEP COMMONLISP) of
 (\DTEST *READTABLE* '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 '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 'OUTPUT))
           (OBEY-PRINT-LEVEL (OR (ffetch
 (READTABLEP COMMONLISP) of
 (\DTEST *READTABLE* '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 '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 'OUTPUT)))
         (PRIN2
 X STRM RDTBL)
         (\OUTCHAR
 STRM (CHARCODE EOL))
         X)))

(PRINTCCODE

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

    (\OUTCHAR
 (\GETSTREAM FILE '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 '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 '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 '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 '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*
 ':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*
 ':UPCASE)

(RPAQ? \DEFPRINTFNS
 NIL)



(* ; "PRINT internals")


(DEFINEQ

(PRINT-CIRCLE-LOOKUP

  (LAMBDA (OBJECT)
                                           (* Pavel "16-Oct-86 21:13")

    (LET ((TABLEENTRY (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)))
         (CASE TABLEENTRY ((T1 NIL)
                           (CL:VALUES NIL NIL))
               (T2 (CL:VALUES (PROG1 (CONCAT (CHARACTER (fetch
 (READTABLEP HASHMACROCHAR)
                                                           of
 *READTABLE*))
                                            *PRINT-CIRCLE-NUMBER* "=")
                                     (CL:SETF (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
                                            *PRINT-CIRCLE-NUMBER*)
                                     (CL:INCF *PRINT-CIRCLE-NUMBER*))
                          T))
               (CL:OTHERWISE (CL:IF (NUMBERP TABLEENTRY)
                                    (CL: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
 (CL:SPECIAL *PRINT-CIRCLE-HASHTABLE*))
         (CL:BLOCK PRINT-CIRCLE-LABEL-P (LET ((TABLEENTRY (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)))
                                             (COND
                                                ((EQ TABLEENTRY 'T2))
                                                ((CL:INTEGERP TABLEENTRY)
                                                 TABLEENTRY)
                                                (T NIL))))))

(PRINT-CIRCLE-SCAN

  (CL:LAMBDA (OBJECT)
                                        (* Pavel "16-Oct-86 21:17")

         (DECLARE
 (CL:SPECIAL *PRINT-ARRAY*))
         (CL:TYPECASE OBJECT (CONS (CL:WHEN (NOT (PRINT-CIRCLE-ENTER
 OBJECT))
                                          (PRINT-CIRCLE-SCAN
 (CAR OBJECT))
                                          (PRINT-CIRCLE-SCAN
 (CDR OBJECT))))
                ((CL: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 (CL:ARRAY-TOTAL-SIZE OBJECT))
                               (VARRAY (CL:IF (> (CL:ARRAY-RANK OBJECT)
                                                 1)
                                              (CL:MAKE-ARRAY ASIZE :DISPLACED-TO OBJECT)
                                              OBJECT)))
                              (CL:DOTIMES (X ASIZE)
                                     (PRINT-CIRCLE-SCAN
 (CL:AREF VARRAY X)))))))))

(PRINT-CIRCLE-ENTER

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

                                                             (* Pavel "16-Oct-86 21:27")

         (CASE (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
               (NIL (CL:SETF (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
                           'T1)
                    NIL)
               (T1 (CL:SETF (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*)
                          'T2)
                   (SETQ THERE-ARE-CIRCLES T)
                   T)
               (T2 T)
               (CL: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
 (CL: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 '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)
                          (* Pavel "16-Oct-86 21:02")


                                                  (* ;;; "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 '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)
                         (LET ((N (IABS N)))
                              (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
 (CL: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* ':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 (CL:SYMBOL RDTBL STREAM PKGNAME PKGSEPR CHECKLENGTH)

                                                             (* bvm%: " 9-May-86 23:07")

          
          (* * Print CL: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 CL: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
 CL: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
 CL: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 CL: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
 CL:SYMBOL bind
 (FIRSTFLG _ T)
                                            (DOWNCASE _ (AND (fetch
 (READTABLEP CASEINSENSITIVE)
                                                                of
 RDTBL)
                                                             (EQ *PRINT-CASE* ':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 (CL: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
 CL: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 CL: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
 CL: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 (CL:SYMBOL RADIX)
                                  (* bvm%: " 4-Aug-86 14:56")

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

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


    (LET
     ((LASTCHARTYPE '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
 CL: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)

                                        '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 'FIRST)
                                          then
               (* Can't start with ratio marker)

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

                              (SETQ SEENDIGITS T)
                              '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))
                     '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 '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 '(\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 '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 'DRIBBLESTREAM)))
              (if
 DRIBBLESTREAM
                  then
 (\OUTCHAR
 DRIBBLESTREAM CH)))
         (CL:FUNCALL (LISTGET OP '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* '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 'STREAM)
         (EQ (fetch
 (STREAM DEVICE) of
 STRM)
             \PNAMEDEVICE))))
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 
(PUTDEF '\MAPPNAMESTREAM 'RESOURCES
       '(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 '\\MAPPNAMESTREAM.GLOBALRESOURCE)

(RPAQ? \PNAMEDEVICE
 (NCREATE 'FDEV (\GETDEVICEFROMHOSTNAME '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 CL: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 CL:NUMBER)
                                    NILNUMPRINTFLG))
                              (FLOATFLAG (\CONVERT.FLOATING.NUMBER (FLOAT CL:NUMBER)
                                                \NUMSTR \NUMSTR1 (\CHECKFLTFMT
 FORMAT)))
                              (T (\CONVERTNUMBER
 (OR (FIXP CL:NUMBER)
                                                     (FIXR CL: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 CL: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)
                     '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)
)
(PUTPROPS APRINT COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3612 12561 (PRIN1 3622 . 5076) (PRIN2 5078 . 6245) (PRIN3 6247 . 7219) (PRIN4 7221 . 
8394) (PRINT 8396 . 8639) (PRINTCCODE 8641 . 8922) (PRINTLEVEL 8924 . 9690) (RADIX 9692 . 9870) (
SPACES 9872 . 10225) (TERPRI 10227 . 10416) (FRESHLINE 10418 . 11099) (DEFPRINT 11101 . 11618) (
LINELENGTH 11620 . 12559)) (13223 16937 (PRINT-CIRCLE-LOOKUP 13233 . 14468) (PRINT-CIRCLE-LABEL-P 
14470 . 15072) (PRINT-CIRCLE-SCAN 15074 . 16245) (PRINT-CIRCLE-ENTER 16247 . 16935)) (16938 58089 (
\PRINDATUM 16948 . 24710) (\ELIDE.PRINT.ELEMENT 24712 . 24888) (\ELIDE.ELEMENT.CHAR 24890 . 25180) (
\ELIDE.PRINT.TAIL 25182 . 25658) (\ELIDE.TAIL.STRING 25660 . 25887) (\CKPOSBOUT 25889 . 26059) (
\CKPOSSOUT 26061 . 26281) (\CONVERTNUMBER 26283 . 29848) (\LITPRIN 29850 . 34319) (\LITPRIN.INTERNAL 
34321 . 40699) (\SYMBOL.ESCAPE.COUNT 40701 . 46561) (\NUMERIC.PNAMEP 46563 . 51451) (\PRINSTACKP 51453
 . 52721) (\PRINTADDR 52723 . 53808) (\PRINSTRING 53810 . 55178) (\SOUT 55180 . 55351) (\OUTCHAR 55353
 . 55514) (\FILEOUTCHARFN 55516 . 57574) (\TTYOUTCHARFN 57576 . 58087)) (59444 59617 (\INVALID.RADIX 
59454 . 59615)) (59721 61940 (\MAPPNAME 59731 . 60891) (\MAPPNAME.INTERNAL 60893 . 61546) (
PNAMESTREAMP 61548 . 61938)) (62565 62987 (\MAPCHARS 62575 . 62985)) (63310 67354 (PRINTNUM 63320 . 
66407) (FLTFMT 66409 . 66743) (\CHECKFLTFMT 66745 . 67352)))))
STOP