(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)

(FILECREATED "11-Oct-93 16:04:23" "{Pele:mv:envos}<LispCore>Sources>CLTL2>APRINT.;1"
 100667 

      changes to%:  (VARS APRINTCOMS)
                    (FUNCTIONS \PRINDATUM-LISTP)

      previous date%: " 4-Jan-92 15:40:50" {DSK}<mo>usr>users>sybalsky>cltl2>sources>APRINT.;1)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & 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))
        (FNS ALPHANUMCHARARRAY)
        (INITVARS (PLVLFILEFLG NIL)
               (\LINELENGTH 82)
               (\FLOATFORMAT T)
               (PRXFLG NIL)
               (*PRINT-BASE* 10)
               (*READ-BASE* 10)
               (*READ-EVAL* T)
               (*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)
               (*CLTL2-PEDANTIC* NIL)
               (\DEFPRINTFNS NIL)
               (ALPHANUMCHARARRAY (ALPHANUMCHARARRAY)))
        (COMS                                                (* ; "PRINT internals")

              (FNS PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-SCAN PRINT-CIRCLE-ENTER)
              (FNS \PRINDATUM \PRINT-USING-DEFPRINT \PRINT-USING-ADDRESS \ELIDE.PRINT.ELEMENT 
                   \ELIDE.ELEMENT.CHAR \ELIDE.PRINT.TAIL \ELIDE.TAIL.STRING \CKPOSBOUT \CKPOSSOUT 
                   \CONVERTNUMBER \LITPRIN \LITPRIN.INTERNAL \PNAME-CONTAINS-NO-EOL 
                   \SYMBOL.ESCAPE.COUNT \NUMERIC.PNAMEP \PRINSTACKP \PRINTADDR \PRINSTRING \SOUT 
                   \OUTCHAR)
              (FNS \FILEOUTCHARFN \JISFILEOUTCHARFN \SHIFTJISFILEOUTCHARFN \EUCFILEOUTCHARFN 
                   \THROUGHFILEOUTCHARFN)
              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS .FILELINELENGTH.)
                     (FUNCTIONS \PRINDATUM-LISTP)
                     (EXPORT (MACROS .SPACECHECK. \CHECKRADIX)
                            (MACROS \XCCSFILEOUTCHARFN)))
              (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* *READ-EVAL* *PRINT-RADIX* 
                               *PRINT-ESCAPE* *PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* 
                               *PRINT-LENGTH* *PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE* 
                               *CLTL2-PEDANTIC*)))
        (COMS                                                (* ; "PRINTNUM and friends")

              (FNS PRINTNUM FLTFMT \CHECKFLTFMT PRINTNUM-TO-STRING)
              (MACROS NUMFORMATCODE)
              (INITVARS (NILNUMPRINTFLG)))
        (LOCALVARS . T)
        (GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS ALPHANUMCHARARRAY)
        (PROP (FILETYPE APRINT))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA])



(* ; "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)                                     (* ; "Edited 20-Jan-87 17:04 by bvm:")

    (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-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-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)                                     (* ; "Edited 20-Jan-87 17:05 by bvm:")


(* ;;; "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-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-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])])
)
(DEFINEQ

(ALPHANUMCHARARRAY

  [LAMBDA NIL                                                (* ; "Edited 19-Sep-91 19:46 by jrb:")

    (SETQ ALPHANUMCHARARRAY (ARRAY 256 'BYTE 0 0))
    (for
 I from
 (CHARCODE A) to
 (CHARCODE Z) do
 (SETA ALPHANUMCHARARRAY I 1))
    (for
 I from
 (CHARCODE a) to
 (CHARCODE z) do
 (SETA ALPHANUMCHARARRAY I 2))
    (for
 I from
 (CHARCODE 0) to
 (CHARCODE 9) do
 (SETA ALPHANUMCHARARRAY I 3))
    ALPHANUMCHARARRAY])
)

(RPAQ? PLVLFILEFLG
 NIL)

(RPAQ? \LINELENGTH
 82)

(RPAQ? \FLOATFORMAT
 T)

(RPAQ? PRXFLG
 NIL)

(RPAQ? *PRINT-BASE*
 10)

(RPAQ? *READ-BASE*
 10)

(RPAQ? *READ-EVAL*
 T)

(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? *CLTL2-PEDANTIC*
 NIL)

(RPAQ? \DEFPRINTFNS
 NIL)

(RPAQ? ALPHANUMCHARARRAY
 (ALPHANUMCHARARRAY))



(* ; "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)                                        (* ; "Edited  3-Apr-91 10:33 by jrb:")

         (DECLARE
 (CL:SPECIAL *PRINT-ARRAY*))
         (CL:TYPECASE OBJECT
             (CONS [COND
                      ((NOT (PRINT-CIRCLE-ENTER
 OBJECT))
                       (PRINT-CIRCLE-SCAN
 (CAR OBJECT))
                       (PRINT-CIRCLE-SCAN
 (CDR OBJECT])
             (CL:SYMBOL                                      (* ; 

                                                           "Uninterned symbols must be entered")

                (CL:UNLESS (ffetch
 (CL:SYMBOL PACKAGE) of
 OBJECT)
                       (PRINT-CIRCLE-ENTER
 OBJECT)))
             (CL::STRUCTURE-OBJECT [COND
                                      ((AND XCL:*PRINT-STRUCTURE* (NOT (PRINT-CIRCLE-ENTER
 OBJECT
                                                                              )))
                                       (CL:MAPCAR [FUNCTION (LAMBDA (DESCRIPTOR)
                                                              (PRINT-CIRCLE-SCAN
 (FETCHFIELD
                                                                                      DESCRIPTOR 
                                                                                      OBJECT]
                                              (CL::STRUCTURE-POINTER-SLOTS (CL:TYPE-OF OBJECT])
             ((CL:ARRAY T) [COND
                              ((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 (COND
                                                 ((> (CL:ARRAY-RANK OBJECT)
                                                     1)
                                                  (CL:MAKE-ARRAY ASIZE :DISPLACED-TO OBJECT))
                                                 (T 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))
                                                             (* ; "Edited 31-Mar-87 19:16 by jrb:")

         (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 (OBJECT STREAM CPL)                                (* ; "Edited 11-Feb-91 14:34 by jds")

    (DECLARE
 (USEDFREE *READTABLE* *PRINT-RADIX* *PRINT-BASE* *PRINT-ESCAPE*))
    (SELECTC (NTYPX OBJECT)
        ((LIST \LITATOM \NEW-ATOM) 
             (\LITPRIN
 OBJECT STREAM))
        (\LISTP 
                (* ;; "macro call that uses the arguments already bound, to save a fn call.")


                (\PRINDATUM-LISTP
))
        ((LIST \SMALLP \FIXP) 
             (WITH-RESOURCES (\NUMSTR \NUMSTR1)
                    (\CKPOSSOUT
 STREAM (\CONVERTNUMBER

                                            OBJECT
                                            (\CHECKRADIX *PRINT-BASE*)
                                            T
                                            (AND (if
 (fetch
 (READTABLEP COMMONLISP)
                                                            of
 *READTABLE*)
                                                     then
 
                                                             (* ; 

                                                        "Common Lisp controlled solely by this var")

                                                           *PRINT-RADIX*
                                                   else
  (* ; 

                                          "Interlisp prints radix if it is not 10 and we are prin2")

                                                         (AND *PRINT-ESCAPE* (NEQ *PRINT-BASE* 10)))
                                                 *READTABLE*)
                                            \NUMSTR \NUMSTR1))))
        (\FLOATP [WITH-RESOURCES (\NUMSTR \NUMSTR1)
                        (\CKPOSSOUT
 STREAM (\CONVERT.FLOATING.NUMBER OBJECT \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])
        (\STACKP (\PRINSTACKP
 OBJECT STREAM))
        (COND
           ((STRINGP OBJECT)
            (\PRINSTRING
 OBJECT STREAM))
           ((TYPENAMEP OBJECT 'CL::STRUCTURE-OBJECT)

            (* ;; "this is a structure, don't use defprint.")


            (CL::PRINT-STRUCTURE-INSTANCE OBJECT STREAM CPL))
           ((TYPENAMEP OBJECT 'T)

            (* ;; 

  "this is a common-loops object, since it is a sub-class of t, so call the print-instance method.")


            (PRINT-INSTANCE OBJECT STREAM 0))
           (T (\PRINT-USING-DEFPRINT
 OBJECT STREAM CPL])

(\PRINT-USING-DEFPRINT

  [LAMBDA (X STREAM CPL)                                     (* ; "Edited 18-Dec-86 12:22 by bvm:")

    (DECLARE
 (USEDFREE *PRINT-LEVEL*))
    (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")

                                      (CL:FUNCALL (CDR FN)
                                             X STREAM 0]

              (* ;; "No defined printer, or printer declined to do anything")


              (\PRINT-USING-ADDRESS
 X STREAM CPL))
             ((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])

(\PRINT-USING-ADDRESS

  (CL:LAMBDA (X STREAM CPL)                                  (* ; "Edited 17-Oct-91 15:27 by jrb:")

         (CL:BLOCK \PRINT-USING-ADDRESS
             [LET ((TYPE (TYPENAME X)))
                  (COND
                     ((fetch
 (READTABLEP COMMONLISP) of
 *READTABLE*)
                      (CL::CHECK-READABLY X)
                      (.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]
             T)))

(\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)                          (* ; "Edited 18-Dec-86 17:53 by bvm:")


(* ;;; "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")


    (LET* ((SIGN)
           [MAGNITUDE (if
 (>= N 0)
                          then
 N
                        else
 (SETQ SIGN (IMINUS N]
           (X MAGNITUDE)
           (POS (\NSTRINGCHARS NS))
           (END (SUB1 POS))
           COMMONLISPY DIDQ)
          (if
 RDTBL
              then
                                       (* ; 

                                                           "do bletcherous suffix cases first")

                    (if
 (SETQ COMMONLISPY (fetch
 (READTABLEP COMMONLISP) of
 RDTBL))
                        then
                             (* ; "decimal is suffix")

                              (if
 (EQ R 10)
                                  then
 (RPLCHARCODE NS (add
 END 1)
                                                  (CHARCODE "."))
                                        (SETQ DIDQ T))
                      elseif
 (AND (EQ R 8)
                                      (> MAGNITUDE 7))
                        then
                             (* ; "Octal numbers have Q suffix")

                              (RPLCHARCODE NS (add
 END 1)
                                     (CHARCODE Q))
                              (SETQ DIDQ T)))
          (repeatuntil
 (EQ X 0) do
                   (* ; 

                               "note this loop happens at least once, for benefit of MAGNITUDE = 0")

                                          [RPLCHARCODE NS (add
 POS -1)
                                                 (LET ((DIGIT (IREMAINDER X R)))
                                                      (if
 (< DIGIT 10)
                                                          then
 (+ DIGIT (CHARCODE 0))
                                                        else
 
                                                             (* ; 

                                 "For radices higher than 10, use letters of alphabet from A on up")

                                                              (+ (- DIGIT 10)
                                                                 (CHARCODE A]
                                          (SETQ X (IQUOTIENT X R)))
          (if
 SIGN
              then
 (RPLCHARCODE NS (add
 POS -1)
                              (CHARCODE -
)))
          (if
 [AND RDTBL (NOT DIDQ)
                       (OR COMMONLISPY (AND (NEQ R 10)
                                            (OR (> MAGNITUDE 9)
                                                (>= MAGNITUDE R]
              then
 

                    (* ;; "Prepend a radix qualifier if it wasn't already done as a suffix.  In Interlisp we don't do this if the radix is decimal or the number is smaller than the radix.")


                    [SELECTQ R
                        (16                                  (* ; "hex")

                            (RPLCHARCODE NS (add
 POS -1)
                                   (CHARCODE x)))
                        (8                                   (* ; "octal")

                           (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)
                                      (+ (CHARCODE 0)
                                         (IREMAINDER R 10)))
                               (if
 (>= R 10)
                                   then
                  (* ; "two-digit radix")

                                         (RPLCHARCODE NS (add
 POS -1)
                                                (+ (CHARCODE 0)
                                                   (IQUOTIENT R 10]
                    (RPLCHARCODE NS (add
 POS -1)
                           (fetch
 (READTABLEP HASHMACROCHAR) of
 RDTBL)))
          (SUBSTRING NS POS END NSB])

(\LITPRIN

  [LAMBDA (X STREAM)                                         (* ; "Edited 15-Aug-91 11:19 by jrb:")

    (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.")

                         [if
 *PRINT-CIRCLE-HASHTABLE*
                             then
 

                                   (* ;; 

                                 "*PRINT-CIRCLE-HASHTABLE* is only non-nil when *print-circle*.")


                                   (CL:MULTIPLE-VALUE-BIND
                                    (LABEL FIRSTTIME)
                                    (PRINT-CIRCLE-LOOKUP
 X)
                                    (if
 LABEL
                                        then
 (\CKPOSSOUT
 STREAM LABEL)
                                              (if
 (NOT FIRSTTIME)
                                                  then
 (RETFROM '\LITPRIN X]
                         (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 
          (* ;; "Used to be (.SPACECHECK. STREAM (\NATOMCHARS X)); expanded and check for EOL character in print-name of atom added- JRB")


          (AND \THISFILELINELENGTH (IGREATERP (IPLUS (\NATOMCHARS X)
                                                     (fetch
 CHARPOSITION of
 STREAM))
                                          \THISFILELINELENGTH)
               (\PNAME-CONTAINS-NO-EOL
 X (IDIFFERENCE \THISFILELINELENGTH (fetch
 CHARPOSITION
                                                                                 of
 STREAM)))
               (FRESHLINE
 STREAM))

          (* ;; "Following code munged to match \LITPRIN.INTERNAL's handling of :CAPITALIZE")


          (for
 C inatom
 X bind
 CAPLOWER CAPUPPER UPTODOWN DOWNTOUP WAS-ALPHA CHARTYPE 
                                        CHARTYPEBASE
             first
 

                   (* ;; 

 "This mess encodes the requirements of *PRINT-CASE* x CL:READTABLE-CASE into the following flags:")


                   (* ;; "CAPLOWER, CAPUPPER - :CAPITALIZE for upper and lower case, respectively (split because CL:READTABLE-CASE can make upper and lower case behave differently)")


                   (* ;; 

                 "UPTODOWN,  DOWNTOUP - Translate between upper and lower case, respectively")


                   (* ;; "WAS-ALPHA - Previous char was alphanumeric, capitalize apropriately")


                   (* ;; "CHARTYPE, CHARTYPEBASE - When CHARTYPEBASE is set, need to distinguish between upper, lower, numeric, and other characters; result is an integer in CHARTYPE")


                   (AND (EQ *PRINT-CASE* :CAPITALIZE)
                        (SETQ CAPLOWER T)
                        (SETQ CAPUPPER T))
                   (SELECTQ (CL:READTABLE-CASE *READTABLE*)
                       (:PRESERVE (SETQ CAPLOWER NIL)
                                  (SETQ CAPUPPER NIL))
                       (:UPCASE (SELECTQ *PRINT-CASE*
                                    (:DOWNCASE (SETQ UPTODOWN T))
                                    (:CAPITALIZE (SETQ CAPLOWER NIL))
                                    NIL))
                       (:DOWNCASE (SELECTQ *PRINT-CASE*
                                      (:UPCASE (SETQ DOWNTOUP T))
                                      (:CAPITALIZE (SETQ CAPUPPER NIL))
                                      NIL))
                       (:INVERT                              (* ; "Have to prescan; YECCH!")

                                (SETQ CAPLOWER NIL)
                                (SETQ CAPUPPER NIL)
                                (AND [NULL (CADR (CL:MULTIPLE-VALUE-LIST (\SYMBOL.ESCAPE.COUNT

                                                                          X *READTABLE*]
                                     (SETQ UPTODOWN T)
                                     (SETQ DOWNTOUP T)))
                       NIL)
                   (if
 (OR UPTODOWN DOWNTOUP CAPLOWER CAPUPPER)
                       then
 (SETQ CHARTYPEBASE (ffetch
 (ARRAYP BASE) of
 ALPHANUMCHARARRAY
                                                          )))
             do
 (if
 (AND CHARTYPEBASE (ILEQ C \MAXTHINCHAR)
                                 (NOT (EQ (SETQ CHARTYPE (\GETBASEBYTE CHARTYPEBASE C))
                                          0)))
                        then
                             (* ; "Vanilla character")

                              (SELECTQ (\GETBASEBYTE CHARTYPEBASE C)
                                  (1                         (* ; "Upper case")

                                     [COND
                                        ((OR UPTODOWN (AND CAPUPPER WAS-ALPHA))
                                         (SETQ C (+ C (- (CHARCODE a)
                                                         (CHARCODE A]
                                     (SETQ WAS-ALPHA T))
                                  (2                         (* ; "Lower case")

                                     [COND
                                        ((OR DOWNTOUP (AND CAPLOWER (NOT WAS-ALPHA)))
                                         (SETQ C (- C (- (CHARCODE a)
                                                         (CHARCODE A]
                                     (SETQ WAS-ALPHA T))
                                  (3                         (* ; "Numeric")

                                     (SETQ WAS-ALPHA T))
                                  (SETQ WAS-ALPHA NIL))
                      else
 (SETQ WAS-ALPHA NIL))
                   (\OUTCHAR
 STREAM C])

(\LITPRIN.INTERNAL

  [LAMBDA (SYMBOL RDTBL STREAM PKGNAME PKGSEPR CHECKLENGTH)  (* ; "Edited 15-Aug-91 11:18 by jrb:")


(* ;;; "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 PKGLEN SA NESCAPES MULTICASE CHECKESCAPE FIRSTESCAPE)
         (if
 (OR (NEQ MULTESCAPE 0)
                     CHECKLENGTH)
             then
                                        (* ; 

                       "have to check now if linelength matters or we plan to use multiple escapes")

                   (CL:MULTIPLE-VALUE-SETQ (NESCAPES MULTICASE)
                          (\SYMBOL.ESCAPE.COUNT
 SYMBOL RDTBL (NULL CHECKLENGTH)))
                   (if
 (EQ NESCAPES -1)
                       then
                              (* ; 

        "Pname is numeric and we don't have a multiple escape available--need to escape first char")

                             (SETQ NESCAPES 1)
                             (SETQ FIRSTESCAPE T)
                     elseif
 (< NESCAPES 0)
                       then
                              (* ; "Use multiple escapes")

                             (SETQ NESCAPES (IMINUS NESCAPES))
                             (SETQ USEMULTESCAPE T)
                     elseif
 (NEQ NESCAPES 0)
                       then
 (SETQ CHECKESCAPE T))
           else
                                          (* ; 

                                          "if we don't check now then have to check while printing")

                 (SETQ CHECKESCAPE T))
         (if
 CHECKLENGTH
             then
                                        (* ; "Verify space for everything")


                   (* ;; "Used to be (.SPACECHECK. STREAM (hairy-expression)); expanded and check for EOL character in print-name of atom added - JRB")


                   (AND \THISFILELINELENGTH
                        (IGREATERP (IPLUS PNAMELENGTH NESCAPES
                                          (SETQ PKGLEN (IPLUS (if
 PKGNAME
                                                                  then
 
                                                             (* ; 

                                                           "How much space to print package name")

                                                                        (IABS (\SYMBOL.ESCAPE.COUNT

                                                                               PKGNAME RDTBL))
                                                                else
 0)
                                                              (if
 PKGSEPR
                                                                  then
 
                                                             (* ; 

                                                "Extra characters between pkg name and symbol name")

                                                                        (\NSTRINGCHARS PKGSEPR)
                                                                else
 0)))
                                          (fetch
 CHARPOSITION of
 STREAM))
                               \THISFILELINELENGTH)
                        [\PNAME-CONTAINS-NO-EOL
 SYMBOL (IDIFFERENCE \THISFILELINELENGTH
                                                                  (IPLUS PKGLEN (fetch
 
                                                                                       CHARPOSITION
                                                                                   of
 STREAM]
                        (FRESHLINE
 STREAM)))

         (* ;; "First print any needed package qualifier")


         (if
 PKGNAME
             then
                                        (* ; 

                                                           "Print package name, don't check length")

                   (\LITPRIN.INTERNAL
 PKGNAME RDTBL STREAM))
         (if
 PKGSEPR
             then
 (\SOUT
 PKGSEPR STREAM))
         (if
 USEMULTESCAPE
             then
                                        (* ; 

                           "Surround pname with multiple escape char, only escape internal escapes")

                   (\OUTCHAR
 STREAM MULTESCAPE)
                   (for
 C inatom
 SYMBOL do
 (if
 (OR (EQ C MULTESCAPE)
                                                                   (EQ C ESCAPE))
                                                           then
 (\OUTCHAR
 STREAM ESCAPE))
                                                      (\OUTCHAR
 STREAM C))
                   (\OUTCHAR
 STREAM MULTESCAPE)
           else
 [if
 FIRSTESCAPE
                        then
                             (* ; 

                  "Need an escape character at start to keep atom from being interpreted as number")

                              (\OUTCHAR
 STREAM ESCAPE)
                      elseif
 CHECKESCAPE
                        then
 (if
 (AND (EQ PNAMELENGTH 1)
                                              (EQ (CHCON1 SYMBOL)
                                                  (CHARCODE ".")))
                                     then
                (* ; 

                     "have to handle period special because it is only special in a dotted context")

                                           (\OUTCHAR
 STREAM ESCAPE)
                                           (SETQ CHECKESCAPE NIL)
                                   else
                  (* ; 

                                      "prepare to check for escaping of chars in the printing loop")

                                         (SETQ SA (fetch
 READSA of
 RDTBL] 

                 (* ;; 

               "There are a zillion flags bound and set below; their meanings are as follows:")


                 (* ;; "FIRSTFLG - First time through the loop")


                 (* ;; "CAPITALIZING - *PRINT-CASE* is :CAPITALIZE")


                 (* ;; 

 "WAS-ALPHA - Last char output was alphanumeric (thus current character should not be capitalized)")


                 (* ;; "ESCUPPER and ESCLOWER - Upper/lower case characters should be escaped here")


                 (* ;; 

               "UPTODOWN and DOWNTOUP - Upper/lower case characters should be case-converted here")


                 (* ;; "CHARTYPE - a character type number; 1=uppercase, 2=lowercase, 3=numeric")


                 (for
 C inatom
 SYMBOL bind
 (FIRSTFLG _ T)
                                                    (CAPITALIZING _ (EQ *PRINT-CASE* :CAPITALIZE))
                                                    (CHARTYPEBASE _ (ffetch
 (ARRAYP BASE)
                                                                       of
 ALPHANUMCHARARRAY))
                                                    WAS-ALPHA ESCUPPER ESCLOWER UPTODOWN DOWNTOUP 
                                                    CHARTYPE SYN
                    first
 

                          (* ;; "This mess encodes the requirements of *PRINT-CASE* x CL:READTABLE-CASE into the flags ESCUPPER ESCLOWER UPTODOWN DOWNTOUP CAPITALIZING")


                          (SELECTQ (CL:READTABLE-CASE RDTBL)
                              (:PRESERVE (SETQ CAPITALIZING NIL))
                              (:UPCASE (AND CHECKESCAPE (SETQ ESCLOWER T))
                                       (AND (EQ *PRINT-CASE* :DOWNCASE)
                                            (SETQ UPTODOWN T)))
                              (:DOWNCASE (AND CHECKESCAPE (SETQ ESCUPPER T))
                                         (AND (EQ *PRINT-CASE* :UPCASE)
                                              (SETQ DOWNTOUP T)))
                              (:INVERT (SETQ CAPITALIZING NIL)
                                       (AND (NOT MULTICASE)
                                            (SETQ UPTODOWN T)
                                            (SETQ DOWNTOUP T)))
                              NIL)
                    do
 (if
 (AND (ILEQ C \MAXTHINCHAR)
                                        (NOT (EQ (SETQ CHARTYPE (\GETBASEBYTE CHARTYPEBASE C))
                                                 0)))
                               then
                      (* ; "Vanilla character")

                                     [COND
                                        [(EQ CHARTYPE 1)     (* ; "Upper case")

                                         (COND
                                            (ESCUPPER (\OUTCHAR
 STREAM ESCAPE))
                                            ((OR UPTODOWN (AND CAPITALIZING WAS-ALPHA))
                                             (SETQ C (+ C (- (CHARCODE a)
                                                             (CHARCODE A]
                                        ((EQ CHARTYPE 2)     (* ; "Lower case")

                                         (COND
                                            (ESCLOWER (\OUTCHAR
 STREAM ESCAPE))
                                            ((OR DOWNTOUP (AND CAPITALIZING (NOT WAS-ALPHA)))
                                             (SETQ C (- C (- (CHARCODE a)
                                                             (CHARCODE A]
                                     (SETQ WAS-ALPHA T)
                             else
 (if
 (AND CHECKESCAPE (fetch
 (READCODE ESCQUOTE)
                                                                  of
 (SETQ SYN (\SYNCODE SA C)))
                                                   (OR FIRSTFLG (fetch
 (READCODE INNERESCQUOTE)
                                                                   of
 SYN)))
                                          then
           (* ; 

                                                           "Needs escaped for another reason")

                                                (\OUTCHAR
 STREAM ESCAPE))
                                   (SETQ WAS-ALPHA NIL))
                          (\OUTCHAR
 STREAM C)
                          (SETQ FIRSTFLG NIL])

(\PNAME-CONTAINS-NO-EOL

  [LAMBDA (A WITHIN)                                         (* ; "Edited 15-Aug-91 11:16 by jrb:")

    (for
 C inatom
 A as
 I from
 0 to
 (OR WITHIN 65535) by
 1
       never
 (EQ C (CHARCODE EOL])

(\SYMBOL.ESCAPE.COUNT

  [LAMBDA (SYMBOL RDTBL INEXACTOK)                           (* ; "Edited  3-Apr-91 10:47 by jrb:")


(* ;;; "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.")


(* ;;; "JRB - Added a little junk for support of (CL:READTABLE-CASE RDTBL) = :INVERT.  We return a second value of T if the current readtable-case is :INVERT and the symbol has both upper and lower cases in it.")


    (LET
     ((CASEBASE (READTABLE-CASEARRAY RDTBL))
      CASECHECK UPPERSEEN LOWERSEEN MULTICASE)
     (if
 (EQ (COMMON-LISP:READTABLE-CASE RDTBL)
                 :INVERT)
         then
 (SETQ CASEBASE NIL)
               (SETQ CASECHECK T))
     (for
 C inatom
 SYMBOL bind
 (RESULT _ 0)
                                        (NESCAPES _ 0)
                                        (FIRSTFLG _ T)
                                        (MULTESCAPE _ (fetch
 (READTABLEP MULTESCAPECHAR)
                                                         of
 RDTBL))
                                        (ESCAPE _ (fetch
 (READTABLEP ESCAPECHAR) of
 RDTBL))
                                        (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 (> (- 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)
              [AND CASECHECK (OR MULTICASE (COND
                                              ((AND (ILEQ C (CHARCODE z))
                                                    (IGEQ C (CHARCODE a)))
                                               (if
 UPPERSEEN
                                                   then
 (SETQ MULTICASE T)
                                                 else
 (SETQ LOWERSEEN T)))
                                              ((AND (ILEQ C (CHARCODE Z))
                                                    (IGEQ C (CHARCODE A)))
                                               (if
 LOWERSEEN
                                                   then
 (SETQ MULTICASE T)
                                                 else
 (SETQ UPPERSEEN T]
        finally
 (PROGN (SETQ RESULT
                            (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, and prefer single escape to multiple")

                                                     -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 (> (- 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")


                                      (- -2 NESCAPES)
                              else
 RESULT))
                           (RETURN (if
 MULTICASE
                                       then
 (CL:VALUES RESULT T)
                                     else
 RESULT])

(\NUMERIC.PNAMEP

  [LAMBDA (SYMBOL RADIX)                                     (* ; "Edited 18-Dec-91 11:25 by jrb:")


(* ;;; "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 'FIRST)
           [EFFECTIVE-RADIX (OR RADIX (COND
                                         ((fetch
 (READTABLEP COMMONLISP) of
 *READTABLE*)
                                          *READ-BASE*)
                                         (T 10]
           (MAXALPHADIGIT (+ (CHARCODE A)
                             (- EFFECTIVE-RADIX 11)))
           SEENALPHADIGITS SEENDIGITS SEENDECPT SEENEXPONENT SEENTIGHTLETTERS SEEN-INVALID-SYNTAX)
                                                             (* ; 

                                        "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
                    (COND
                       [(< C (CHARCODE A))                   (* ; "Numeric or funny char")

                        (COND
                           ((< C (CHARCODE 0))
                            (SELCHARQ C
                                 ((- +)                      (* ; "Signs anywhere but end")

                                      'SIGN)
                                 ("." (COND
                                         (SEENALPHADIGITS 

                                  (* ;; "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")


                                                (COND
                                                   (SEENTIGHTLETTERS (RETURN NIL)))
                                                (SETQ SEENALPHADIGITS NIL))
                                         (SEENDECPT          (* ; "Can't have 2 decimal points")

                                                (SETQ SEEN-INVALID-SYNTAX T)))
                                      (SETQ MAXALPHADIGIT 0)
                                      (SETQ SEENDECPT T))
                                 (/ (COND
                                       ((EQ LASTCHARTYPE 'FIRST)
                                                             (* ; "Can't start with ratio marker")

                                        (RETURN NIL))))
                                 (RETURN NIL)))
                           ((<= C (CHARCODE 9))              (* ; "digit")

                            (SETQ SEENDIGITS T)
                            'DIGIT)
                           (T (RETURN NIL]
                       ((> C (CHARCODE z))                   (* ; "Out in the wilderness.")

                        (RETURN NIL))
                       ((PROGN [COND
                                  ((>= C (CHARCODE a))       (* ; "Raise it")

                                   (SETQ C (- C (- (CHARCODE a)
                                                   (CHARCODE A]
                               (<= C (CHARCODE Z)))          (* ; "Letter")

                        [COND
                           ((<= C MAXALPHADIGIT)             (* ; 

                        "Letter is a digit in this base.  Can't be digit in number with decimal pt")

                            (COND
                               (SEENDECPT 

                                      (* ;; "If there was a decimal point earlier, bail out.")


                                      (RETURN NIL)))
                            (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))
                           (T                                (* ; 

                                                      "Potential exponent marker, only in radix 10")

                              (OR (IEQP 10 EFFECTIVE-RADIX)
                                  (RETURN NIL))
                              (AND SEENEXPONENT (RETURN NIL))
                              (SELECTQ LASTCHARTYPE
                                  ((LETTER FIRST) 
                                       (RETURN NIL))
                                  (COND
                                     ((FMEMB C (CHARCODE (E S F D L)))
                                      (SETQ SEENEXPONENT T))
                                     (T (RETURN NIL]
                        'LETTER)
                       ((OR (EQ C (CHARCODE "_"))
                            (EQ C (CHARCODE "^")))           (* ; 

                "Extension chars, not used now but maybe some day.  We're supposed to escape these")

                        NIL)
                       (T (RETURN NIL]
             finally
                                     (* ; "Success if there was at least one digit and didn't end in a sign.  Also true if symbol consisted solely of periods.")

                   (RETURN (OR (AND (NOT SEEN-INVALID-SYNTAX)
                                    (OR SEENDIGITS SEENALPHADIGITS)
                                    (NEQ LASTCHARTYPE 'SIGN))
                               (AND SEENDECPT (EQ LASTCHARTYPE T)
                                    (for
 C inpname
 SYMBOL always
 (EQ C (CHARCODE "."])

(\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)                                         (* ; "Edited 14-Dec-88 22:17 by jds")


    (* ;; "Print the string X onto STREAM, which -must- be a stream.")


    (DECLARE
 (GLOBALVARS \DISPLAYSTREAMTYPES))
    (DECLARE
 (SPECVARS *DRIBBLE-OUTPUT* \PRIMTERMSA \TERM.OFD))
    (COND
       [(FMEMB (ffetch
 (IMAGEOPS IMAGETYPE) of
 (fetch
 (STREAM IMAGEOPS) of
 STREAM))
               \DISPLAYSTREAMTYPES)
        (LET ((*DRIBBLE-OUTPUT* *DRIBBLE-OUTPUT*)
              (\PRIMTERMSA \PRIMTERMSA)
              (\TERM.OFD \TERM.OFD))
             (for
 I instring
 X do
 (\OUTCHAR
 STREAM I]
       ((for
 I instring
 X do
 (\OUTCHAR
 STREAM I])

(\OUTCHAR

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

    (STREAMOP 'OUTCHARFN STREAM STREAM CHARCODE])
)
(DEFINEQ

(\FILEOUTCHARFN

  [LAMBDA (ST CHARCODE)                                      (* ; "Edited 25-Feb-91 17:15 by nm")

    (\XCCSFILEOUTCHARFN ST CHARCODE])

(\JISFILEOUTCHARFN

  [LAMBDA (OUTSTREAM CHARCODE)                               (* ; "Edited 11-Mar-91 11:49 by nm")


(* ;;; "Encoder for JIS format.")


    (COND
       ((EQ CHARCODE (CHARCODE EOL))
        (COND
           ((\KIMODEP OUTSTREAM NIL)
            (\OUTKO OUTSTREAM)
            (\CHNAGE.KI.MODE OUTSTREAM NIL NIL)))
        (\BOUT OUTSTREAM (SELECTC (ffetch
 EOLCONVENTION of
 OUTSTREAM)
                             (CR.EOLC (CHARCODE CR))
                             (LF.EOLC (CHARCODE LF))
                             (CRLF.EOLC (\BOUT OUTSTREAM (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
 OUTSTREAM with
 0))
       (T (SETQ CHARCODE (\CONV.XCCS.TO.JIS OUTSTREAM CHARCODE))
                                                             (* ; 

          "\CONV.XCCS.TO.JIS converts ZENKAKUKATAKANA to HANKAKUKATAKANA if the stream desires it.")

          (COND
             ((> CHARCODE 255)
              (COND
                 ((NOT (\KIMODEP OUTSTREAM NIL))
                  (\OUTKI OUTSTREAM)
                  (\CHNAGE.KI.MODE OUTSTREAM NIL T)))
              (\BOUT OUTSTREAM (\CHARSET CHARCODE))
              (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE)))
             (T                                              (* ; "ASCII or HANKAKUKATAKANA")

                (COND
                   ((\KIMODEP OUTSTREAM NIL)
                    (\OUTKO OUTSTREAM)
                    (\CHNAGE.KI.MODE OUTSTREAM NIL NIL)))
                (\BOUT OUTSTREAM CHARCODE)))
          (freplace
 CHARPOSITION of
 OUTSTREAM with
 (PROGN 
                                                             (* ; "Ugh.  Don't overflow")

                                                                      (IPLUS16 (ffetch
 
                                                                                      CHARPOSITION
                                                                                  of
 OUTSTREAM)
                                                                             1])

(\SHIFTJISFILEOUTCHARFN

  [LAMBDA (OUTSTREAM CHARCODE)                               (* ; "Edited  7-Mar-91 21:55 by nm")


(* ;;; "Encoder for Shift-JIS format.")


    (COND
       ((EQ CHARCODE (CHARCODE EOL))
        (\BOUT OUTSTREAM (SELECTC (ffetch
 EOLCONVENTION of
 OUTSTREAM)
                             (CR.EOLC (CHARCODE CR))
                             (LF.EOLC (CHARCODE LF))
                             (CRLF.EOLC (\BOUT OUTSTREAM (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
 OUTSTREAM with
 0))
       (T (SETQ CHARCODE (\CONV.XCCS.TO.JIS OUTSTREAM CHARCODE))
                                                             (* ; 

          "\CONV.XCCS.TO.JIS converts ZENKAKUKATAKANA to HANKAKUKATAKANA if the stream desires it.")

          (COND
             [(> CHARCODE 255)
              (LET ((CH1 (FOLDLO CHARCODE 256))
                    (CH2 (LOGAND CHARCODE 255)))
                   (\CONV.JIS.TO.SJIS CH1 CH2)
                   (COND
                      ((AND (< CH1 256)
                            (< CH2 256))
                       (\BOUT OUTSTREAM CH1)
                       (\BOUT OUTSTREAM CH2]
             (T (\BOUT OUTSTREAM CHARCODE)))
          (freplace
 CHARPOSITION of
 OUTSTREAM with
 (PROGN 
                                                             (* ; "Ugh.  Don't overflow")

                                                                      (IPLUS16 (ffetch
 
                                                                                      CHARPOSITION
                                                                                  of
 OUTSTREAM)
                                                                             1])

(\EUCFILEOUTCHARFN

  [LAMBDA (OUTSTREAM CHARCODE)                               (* ; "Edited 11-Mar-91 11:29 by nm")


(* ;;; "Encoder for EUC format.")


    (COND
       ((EQ CHARCODE (CHARCODE EOL))
        (\BOUT OUTSTREAM (SELECTC (ffetch
 EOLCONVENTION of
 OUTSTREAM)
                             (CR.EOLC (CHARCODE CR))
                             (LF.EOLC (CHARCODE LF))
                             (CRLF.EOLC (\BOUT OUTSTREAM (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
 OUTSTREAM with
 0))
       (T (SETQ CHARCODE (\CONV.XCCS.TO.JIS OUTSTREAM CHARCODE))
                                                             (* ; 

          "\CONV.XCCS.TO.JIS converts ZENKAKUKATAKANA to HANKAKUKATAKANA if the stream desires it.")

          (COND
             ((> CHARCODE 255)                               (* ; "KANJI or GAIJI")

              (AND (NOT (\NOTGAIJIP CHARCODE))
                   (\BOUT OUTSTREAM 143))
              (\BOUT OUTSTREAM (LOGOR (\CHARSET CHARCODE)
                                      128))
              (\BOUT OUTSTREAM (LOGOR (\CHAR8CODE CHARCODE)
                                      128)))
             ((\HANKAKUP CHARCODE)
              (\BOUT OUTSTREAM 142)
              (\BOUT OUTSTREAM (LOGOR CHARCODE 128)))
             (T                                              (* ; "C0, C1, SP, DEL or G0")

                (\BOUT OUTSTREAM CHARCODE)))
          (freplace
 CHARPOSITION of
 OUTSTREAM with
 (PROGN 
                                                             (* ; "Ugh.  Don't overflow")

                                                                      (IPLUS16 (ffetch
 
                                                                                      CHARPOSITION
                                                                                  of
 OUTSTREAM)
                                                                             1])

(\THROUGHFILEOUTCHARFN

  [LAMBDA (OUTSTREAM CHARCODE)                               (* ; "Edited 26-Feb-91 13:44 by nm")


(* ;;; "Encoder for THROUGH format.")


    (COND
       ((> CHARCODE 255)
        (\BOUT OUTSTREAM (\CHARSET CHARCODE))
        (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE)))
       (T (\BOUT OUTSTREAM CHARCODE])
)
(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))))
)


(DEFMACRO \PRINDATUM-LISTP
 ()

   (* ;; "This is a hokey macro call to save the function call.  Read it as though it were inline code in \prindatum")


   `[LET (LABEL FIRSTTIME)
         (OR CPL (SETQ CPL 0))
         (if
 *PRINT-CIRCLE-HASHTABLE*
             then
 

                   (* ;; "*PRINT-CIRCLE-HASHTABLE* is only non-nil when *print-circle*.")


                   (CL:MULTIPLE-VALUE-SETQ (LABEL FIRSTTIME)
                          (PRINT-CIRCLE-LOOKUP
 OBJECT)))
         [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 OBJECT)
                                  STREAM CPL)
                           (COND
                              ((LISTP (SETQ OBJECT (CDR OBJECT)))
                               (\CKPOSBOUT
 STREAM (CHARCODE SPACE))
                               (if
 (AND *PRINT-CIRCLE-HASHTABLE* (PRINT-CIRCLE-LABEL-P
 OBJECT
                                                                            ))
                                   then
                  (* ; "Must print as a dotted tail")

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

                                     (\CKPOSSOUT
 STREAM " . ")
                                     (\PRINDATUM
 OBJECT STREAM]
                     (\CKPOSBOUT
 STREAM (CHARCODE ")"])

(* "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])
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \XCCSFILEOUTCHARFN
 MACRO
 [(OUTSTREAM CHARCODE)
                                            (COND
                                               ((EQ CHARCODE (CHARCODE EOL))
                                                [COND
                                                   [(NOT (\RUNCODED OUTSTREAM))
                                                    (\BOUT OUTSTREAM (\CHARSET (CHARCODE EOL]
                                                   ((EQ (\CHARSET (CHARCODE EOL))
                                                        (ffetch
 (STREAM CHARSET) of
 OUTSTREAM
                                                               )))
                                                   (T (\BOUT OUTSTREAM NSCHARSETSHIFT)
                                                      (\BOUT OUTSTREAM (freplace
 (STREAM CHARSET)
                                                                          of
 OUTSTREAM
                                                                          with

                                                                          (\CHARSET (CHARCODE EOL]
                                                (\BOUT OUTSTREAM (SELECTC (ffetch
 EOLCONVENTION
                                                                             of
 OUTSTREAM)
                                                                     (CR.EOLC (CHARCODE CR))
                                                                     (LF.EOLC (CHARCODE LF))
                                                                     (CRLF.EOLC (\BOUT OUTSTREAM
                                                                                       (CHARCODE
                                                                                        CR))
                                                                                (CHARCODE LF))
                                                                     (SHOULDNT)))
                                                (freplace
 CHARPOSITION of
 OUTSTREAM
                                                   with
 0))
                                               (T [COND
                                                     ((NOT (\RUNCODED OUTSTREAM))
                                                      (\BOUT OUTSTREAM (\CHARSET CHARCODE))
                                                      (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE)))
                                                     ((EQ (\CHARSET CHARCODE)
                                                          (ffetch
 (STREAM CHARSET) of
 
                                                                                            OUTSTREAM
                                                                 ))
                                                      (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE)))
                                                     (T (\BOUT OUTSTREAM NSCHARSETSHIFT)
                                                        (\BOUT OUTSTREAM (freplace
 (STREAM 
                                                                                              CHARSET
                                                                                              )
                                                                            of
 OUTSTREAM
                                                                            with
 (\CHARSET 
                                                                                            CHARCODE)
                                                                                ))
                                                        (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE]
                                                  (freplace
 CHARPOSITION of
 OUTSTREAM
                                                     with
 (PROGN (IPLUS16 (ffetch
 
                                                                                     CHARPOSITION
                                                                                 of
 OUTSTREAM)
                                                                            1])
)

(* "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 *PRINT-LEVEL* *PRINT-LENGTH*)      (* ; "Edited 23-Mar-87 11:01 by bvm:")


(* ;;; "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 [(*READTABLE* (if
 FLG
                           then
 (\GTREADTABLE RDTBL)
                         else
 (\DTEST *READTABLE* 'READTABLEP]
         (LET ((*PACKAGE* (if
 (AND FLG (fetch
 (READTABLEP USESILPACKAGE) of
 *READTABLE*))
                              then
 *INTERLISP-PACKAGE*
                            else
 *PACKAGE*))
               (*PRINT-ESCAPE* FLG)
               (*PRINT-BASE* (if
 (OR FLG PRXFLG)
                                 then
 *PRINT-BASE*
                               else
 10))
               (*PRINT-RADIX* (AND FLG *PRINT-RADIX*)))
              (\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 NIL)

(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* *READ-EVAL* *PRINT-RADIX* *PRINT-ESCAPE* 
                                *PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH* 
                                *PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE* 
                                *CLTL2-PEDANTIC*)
)



(* ; "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)
                     'FLOAT)
                 (EVERY (CDR FORMAT)
                        (FUNCTION (LAMBDA (X)
                                    (OR (NULL X)
                                        (FIXP X]
        FORMAT)
       (T (LISPERROR "ILLEGAL ARG" FORMAT])

(PRINTNUM-TO-STRING

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

                                                           (WIDTH RADIX PAD0 LEFTFLUSH))

                                                           (RECORD FLOATFMT (WIDTH DECPART 

                                                           EXPPART PAD0 SIGDIGITS)))

                                                             (* ; "Edited 27-Nov-91 13:32 by jds")

    (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)))
                 (RETURN (CONCAT (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)))
                                         (ALLOCSTRING PAD "0"))
                                        (T (ALLOCSTRING PAD " "]
                                    (T ""))
                                STR])
)
(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 ALPHANUMCHARARRAY)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 )
)
(PRETTYCOMPRINT APRINTCOMS)

(RPAQQ APRINTCOMS

       [(COMS                                                (* ; "User-level print functions")

              (FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT PRINTCCODE PRINTLEVEL RADIX SPACES TERPRI FRESHLINE
                   DEFPRINT LINELENGTH))
        (FNS ALPHANUMCHARARRAY)
        (INITVARS (PLVLFILEFLG NIL)
               (\LINELENGTH 82)
               (\FLOATFORMAT T)
               (PRXFLG NIL)
               (*PRINT-BASE* 10)
               (*READ-BASE* 10)
               (*READ-EVAL* T)
               (*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)
               (*CLTL2-PEDANTIC* NIL)
               (\DEFPRINTFNS NIL)
               (ALPHANUMCHARARRAY (ALPHANUMCHARARRAY)))
        (COMS                                                (* ; "PRINT internals")

              (FNS PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-SCAN PRINT-CIRCLE-ENTER)
              (FNS \PRINDATUM \PRINT-USING-DEFPRINT \PRINT-USING-ADDRESS \ELIDE.PRINT.ELEMENT 
                   \ELIDE.ELEMENT.CHAR \ELIDE.PRINT.TAIL \ELIDE.TAIL.STRING \CKPOSBOUT \CKPOSSOUT 
                   \CONVERTNUMBER \LITPRIN \LITPRIN.INTERNAL \PNAME-CONTAINS-NO-EOL 
                   \SYMBOL.ESCAPE.COUNT \NUMERIC.PNAMEP \PRINSTACKP \PRINTADDR \PRINSTRING \SOUT 
                   \OUTCHAR)
              (FNS \FILEOUTCHARFN \JISFILEOUTCHARFN \SHIFTJISFILEOUTCHARFN \EUCFILEOUTCHARFN 
                   \THROUGHFILEOUTCHARFN)
              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS .FILELINELENGTH.)
                     (FUNCTIONS \PRINDATUM-LISTP)
                     (EXPORT (MACROS .SPACECHECK. \CHECKRADIX)
                            (MACROS \XCCSFILEOUTCHARFN)))
              (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* *READ-EVAL* *PRINT-RADIX* 
                               *PRINT-ESCAPE* *PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* 
                               *PRINT-LENGTH* *PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE* 
                               *CLTL2-PEDANTIC*)))
        (COMS                                                (* ; "PRINTNUM and friends")

              (FNS PRINTNUM FLTFMT \CHECKFLTFMT PRINTNUM-TO-STRING)
              (MACROS NUMFORMATCODE)
              (INITVARS (NILNUMPRINTFLG)))
        (LOCALVARS . T)
        (GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS ALPHANUMCHARARRAY)
        (PROP (FILETYPE APRINT))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML)
                      (LAMA \PRINT-USING-ADDRESS PRINT-CIRCLE-ENTER PRINT-CIRCLE-SCAN 
                            PRINT-CIRCLE-LABEL-P])
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 \PRINT-USING-ADDRESS PRINT-CIRCLE-ENTER PRINT-CIRCLE-SCAN PRINT-CIRCLE-LABEL-P)
)
(PUTPROPS APRINT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 
1992 1993))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4313 13379 (PRIN1 4323 . 5808) (PRIN2 5810 . 7003) (PRIN3 7005 . 8039) (PRIN4 8041 . 
9224) (PRINT 9226 . 9462) (PRINTCCODE 9464 . 9737) (PRINTLEVEL 9739 . 10445) (RADIX 10447 . 10629) (
SPACES 10631 . 10977) (TERPRI 10979 . 11164) (FRESHLINE 11166 . 11843) (DEFPRINT 11845 . 12417) (
LINELENGTH 12419 . 13377)) (13380 13875 (ALPHANUMCHARARRAY 13390 . 13873)) (14649 19280 (
PRINT-CIRCLE-LOOKUP 14659 . 15825) (PRINT-CIRCLE-LABEL-P 15827 . 16303) (PRINT-CIRCLE-SCAN 16305 . 
18570) (PRINT-CIRCLE-ENTER 18572 . 19278)) (19281 68340 (\PRINDATUM 19291 . 22233) (
\PRINT-USING-DEFPRINT 22235 . 23607) (\PRINT-USING-ADDRESS 23609 . 24706) (\ELIDE.PRINT.ELEMENT 24708
 . 24878) (\ELIDE.ELEMENT.CHAR 24880 . 25163) (\ELIDE.PRINT.TAIL 25165 . 25589) (\ELIDE.TAIL.STRING 
25591 . 25812) (\CKPOSBOUT 25814 . 25979) (\CKPOSSOUT 25981 . 26195) (\CONVERTNUMBER 26197 . 30686) (
\LITPRIN 30688 . 38989) (\LITPRIN.INTERNAL 38991 . 49606) (\PNAME-CONTAINS-NO-EOL 49608 . 49860) (
\SYMBOL.ESCAPE.COUNT 49862 . 57735) (\NUMERIC.PNAMEP 57737 . 63556) (\PRINSTACKP 63558 . 64863) (
\PRINTADDR 64865 . 65962) (\PRINSTRING 65964 . 67460) (\SOUT 67462 . 68180) (\OUTCHAR 68182 . 68338)) 
(68341 75545 (\FILEOUTCHARFN 68351 . 68510) (\JISFILEOUTCHARFN 68512 . 70873) (\SHIFTJISFILEOUTCHARFN 
70875 . 72926) (\EUCFILEOUTCHARFN 72928 . 75201) (\THROUGHFILEOUTCHARFN 75203 . 75543)) (85227 85395 (
\INVALID.RADIX 85237 . 85393)) (85499 87553 (\MAPPNAME 85509 . 86504) (\MAPPNAME.INTERNAL 86506 . 
87196) (PNAMESTREAMP 87198 . 87551)) (88236 88624 (\MAPCHARS 88246 . 88622)) (89017 96056 (PRINTNUM 
89027 . 92084) (FLTFMT 92086 . 92476) (\CHECKFLTFMT 92478 . 93046) (PRINTNUM-TO-STRING 93048 . 96054))
)))
STOP