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

(filecreated "16-Oct-86 21:28:06" {eris}<lispcore>sources>aprint.\;51
 72857  

      |changes| |to:|  (fns print-circle-enter print-circle-scan print-circle-lookup \\convertnumber)

      |previous| |date:| "14-Oct-86 20:11:09" {eris}<lispcore>sources>aprint.\;47)


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

(prettycomprint aprintcoms)

(rpaqq aprintcoms
 
       ((coms (* \; "User-level print functions")
              (fns prin1 prin2 prin3 prin4 print printccode printlevel radix spaces terpri freshline 
                   defprint linelength))
        (initvars (plvlfileflg nil)
               (\\linelength 82)
               (\\floatformat t)
               (prxflg nil)
               (*print-base* 10)
               (*read-base* 10)
               (*print-radix* nil)
               (*print-escape* t)
               (*print-case* ':upcase)
               (*print-gensym* t)
               (*print-level* nil)
               (*print-length* nil)
               (*print-pretty* nil)
               (*print-circle* nil)
               (*print-array* nil)
               (*print-circle-hashtable* nil)
               (*package* nil)
               (*keyword-package* nil)
               (*interlisp-prin1-case* ':upcase)
               (\\defprintfns nil))
        (coms (* \; "PRINT internals")
              (fns print-circle-lookup print-circle-label-p print-circle-scan print-circle-enter)
              (fns \\prindatum \\elide.print.element \\elide.element.char \\elide.print.tail 
                   \\elide.tail.string \\ckposbout \\ckpossout \\convertnumber \\litprin 
                   \\litprin.internal \\symbol.escape.count \\numeric.pnamep \\prinstackp \\printaddr 
                   \\prinstring \\sout \\outchar \\fileoutcharfn \\ttyoutcharfn)
              (declare\: eval@compile dontcopy (macros .filelinelength.)
                     (export (macros .spacecheck. \\checkradix)))
              (fns \\invalid.radix)
              (specvars \\thisfilelinelength))
        (coms (* \; "Internal printing")
              (fns \\mappname \\mappname.internal pnamestreamp)
              (declare\: dontcopy (resources \\mappnamestream)
                     (macros pnamestreamp))
              (initresources \\mappnamestream)
              (initvars (\\pnamedevice (ncreate 'fdev (\\getdevicefromhostname 'null t))))
              (globalvars \\pnamedevice))
        (coms (* \; "Obsolete")
              (fns \\mapchars))
        (declare\: eval@compile docopy
               (addvars (sysspecvars *print-base* *read-base* *print-radix* *print-escape* 
                               *print-case* *print-gensym* *print-level* *print-length* 
                               *print-pretty* *print-circle* *print-array* *package*)))
        (coms (* \; "PRINTNUM and friends")
              (fns printnum fltfmt \\checkfltfmt)
              (macros numformatcode)
              (initvars (nilnumprintflg)))
        (localvars . t)
        (globalvars \\linelength \\floatformat prxflg \\defprintfns)
        (declare\: donteval@load doeval@compile dontcopy compilervars (addvars (nlama)
                                                                             (nlaml)
                                                                             (lama print-circle-enter 
                                                                                   print-circle-scan 
                                                                                 print-circle-label-p
                                                                                   )))))



(* \; "User-level print functions")


(defineq

(prin1

  (lambda (x file)
                                           (* |bvm:| "29-Sep-86 23:59")


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

    (let* ((strm (\\getstream file 'output))
           (obey-print-level (or (|ffetch|
 (readtablep commonlisp) |of|
 (\\dtest *readtable*
                                                                               'readtablep))
                                 (or (\\outtermp strm)
                                     plvlfileflg))))
          (let ((*print-escape* nil)
                (*print-radix* nil)
                (*print-level* (and obey-print-level *print-level*))
                (*print-length* (and obey-print-level *print-length*))
                (*print-case* (or *interlisp-prin1-case* *print-case*))
                \\thisfilelinelength)
               (declare
 (specvars *print-radix* *print-escape* *print-level* *print-length* 
                               *print-case* \\thisfilelinelength))

                                                  (* \; 

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

               (setq \\thisfilelinelength (.filelinelength. strm))
               (\\prindatum
 x strm 0)
               x))))

(prin2

  (lambda (x file rdtbl)
                                     (* |bvm:| "30-Sep-86 00:02")

    (let* ((strm (\\getstream file 'output))
           (obey-print-level (or (|fetch|
 (readtablep commonlisp) |of|
 (setq rdtbl (\\gtreadtable
                                                                                    rdtbl)))
                                 (or (\\outtermp strm)
                                     plvlfileflg))))
          (let ((*readtable* rdtbl)
                (*print-escape* t)
                (*print-radix* (neq *print-base* 10))
                (*print-level* (and obey-print-level *print-level*))
                (*print-length* (and obey-print-level *print-length*))
                (*package* (|if|
 (|fetch|
 (readtablep usesilpackage) |of|
 rdtbl)
                               |then|
 *interlisp-package*
                             |else|
 *package*))
                \\thisfilelinelength)
               (declare
 (specvars *print-radix* *print-escape* *readtable* *print-level* 
                               *print-length* *package* \\thisfilelinelength))
               (setq \\thisfilelinelength (.filelinelength. strm))
               (\\prindatum
 x strm 0)
               x))))

(prin3

  (lambda (x file)
                                           (* |bvm:| "29-Sep-86 23:59")

          
          (* * |Like| prin1 |but| |no| |linelength| |checking|)


    (let* ((strm (\\getstream file 'output))
           (obey-print-level (or (|ffetch|
 (readtablep commonlisp) |of|
 (\\dtest *readtable*
                                                                               'readtablep))
                                 (or (\\outtermp strm)
                                     plvlfileflg))))
          (let ((*print-escape* nil)
                (*print-radix* nil)
                (*print-level* (and obey-print-level *print-level*))
                (*print-length* (and obey-print-level *print-length*))
                (*print-case* (or *interlisp-prin1-case* *print-case*))
                \\thisfilelinelength)
               (declare
 (specvars *print-radix* *print-escape* *print-level* *print-length* 
                               \\thisfilelinelength))
               (\\prindatum
 x strm 0)
               x))))

(prin4

  (lambda (x file rdtbl)
                                     (* |bvm:| "30-Sep-86 00:03")

          
          (* * |Like| prin2 |but| |doesn't| |check| |linelength|)


    (let* ((strm (\\getstream file 'output))
           (obey-print-level (or (|fetch|
 (readtablep commonlisp) |of|
 (setq rdtbl (\\gtreadtable
                                                                                    rdtbl)))
                                 (or (\\outtermp strm)
                                     plvlfileflg))))
          (let ((*readtable* rdtbl)
                (*print-escape* t)
                (*print-radix* (neq *print-base* 10))
                (*print-level* (and obey-print-level *print-level*))
                (*print-length* (and obey-print-level *print-length*))
                (*package* (|if|
 (|fetch|
 (readtablep usesilpackage) |of|
 rdtbl)
                               |then|
 *interlisp-package*
                             |else|
 *package*))
                \\thisfilelinelength)
               (declare
 (specvars *print-radix* *print-escape* *readtable* *print-level* 
                               *print-length* *package* \\thisfilelinelength))
               (\\prindatum
 x strm 0)
               x))))

(print

  (lambda (x file rdtbl)
                                     (* |bvm:| " 9-May-86 23:08")

    (let ((strm (\\getstream file 'output)))
         (prin2
 x strm rdtbl)
         (\\outchar
 strm (charcode eol))
         x)))

(printccode

  (lambda (charcode file)
                                    (* |bvm:| " 9-May-86 22:44")

    (\\outchar
 (\\getstream file 'output)
           (cond
              ((\\charcodep charcode)
               charcode)
              (t (\\illegal.arg charcode))))))

(printlevel

  (lambda (carval cdrval)
                                    (* |bvm:| " 9-May-86 22:47")

          
          (* * |Sets| |Interlisp| |print| |level| |to| |the| |given| |values| |in| car 

          |and| cdr |directions.| |These| |correspond| |to| *print-level* |and| 

          *print-length* |in| |Common| |Lisp|)


    (cond
       ((listp carval)
        (setq cdrval (cdr carval))
        (setq carval (car carval))))
    (prog1 (cons (or *print-level* -1)
                 (or *print-length* -1))
           (cond
              (carval (setq *print-level* (and (igeq carval 0)
                                               carval))))
           (cond
              (cdrval (setq *print-length* (and (igeq cdrval 0)
                                                cdrval)))))))

(radix

  (lambda (n)
                                                (* |bvm:| " 5-May-86 10:56")

    (prog1 *print-base* (and n (setq *print-base* (\\checkradix n))))))

(spaces

  (lambda (n file)
                                           (* |rmk:| "21-OCT-83 12:32")

    (prog ((stream (\\getstream file 'output))
           \\thisfilelinelength)
          (setq \\thisfilelinelength (.filelinelength. stream))
          (.spacecheck. stream n)
          (frptq n (\\outchar
 stream (charcode space))))
    nil))

(terpri

  (lambda (file)
                                             (* |rmk:| "21-OCT-83 12:31")

    (\\outchar
 (\\getstream file 'output)
           (charcode eol))
    nil))

(freshline

  (lambda (stream)
                                           (* |rmk:| "22-AUG-83 13:48")

          
          (* |Adjusts| |the| stream |to| |be| |at| \a |new| |line| --

          |does| |equivalent| |of| terpri |unless| |it| |is| |already| 

          "sitting at the beginning of a line")


    (cond
       ((neq 0 (|fetch|
 charposition |of|
 (cond
                                             ((and (|type?|
 stream stream)
                                                   (writeable stream))
                                              stream)
                                             (t (setq stream (getstream stream 'output))))))
        (\\outchar
 stream (charcode eol))
        t))))

(defprint

  (lambda (type fn)
                                          (* |rmk:| "28-APR-80 12:04")

    (and (fixp type)
         (setq type (\\typenamefromnumber type)))            (* |The| fixp |case| |should| |never| 

                                                             |occur|)

    (prog ((f (fassoc type \\defprintfns)))
          (cond
             (f (setq \\defprintfns (dremove f \\defprintfns))))
          (cond
             (fn (setq \\defprintfns (cons (cons type fn)
                                           \\defprintfns))))
          (return (cdr f)))))

(linelength

  (lambda (n file)
                                           (* |bvm:| "11-Mar-86 14:56")

          
          (* * |Sets| |to| n |the| |linelength| |of| file --

          |defaults| |to| |primary| |output| |file|)


    (let ((stream (\\getstream file 'output)))
         (prog1 (|fetch|
 (stream linelength) |of|
 stream)
                (and n (cond
                          ((and (numberp n)
                                (ilessp n 1))
                           (\\illegal.arg n))
                          (t (|replace|
 (stream linelength) |of|
 stream |with|
 (cond
                                                                                  ((eq n t)
                                                             (* |Infinite|)

                                                                                   max.smallp)
                                                                                  (t (fix n)))))))))))
)

(rpaq? plvlfileflg
 nil)

(rpaq? \\linelength
 82)

(rpaq? \\floatformat
 t)

(rpaq? prxflg
 nil)

(rpaq? *print-base*
 10)

(rpaq? *read-base*
 10)

(rpaq? *print-radix*
 nil)

(rpaq? *print-escape*
 t)

(rpaq? *print-case*
 ':upcase)

(rpaq? *print-gensym*
 t)

(rpaq? *print-level*
 nil)

(rpaq? *print-length*
 nil)

(rpaq? *print-pretty*
 nil)

(rpaq? *print-circle*
 nil)

(rpaq? *print-array*
 nil)

(rpaq? *print-circle-hashtable*
 nil)

(rpaq? *package*
 nil)

(rpaq? *keyword-package*
 nil)

(rpaq? *interlisp-prin1-case*
 ':upcase)

(rpaq? \\defprintfns
 nil)



(* \; "PRINT internals")


(defineq

(print-circle-lookup

  (lambda (object)
                                           (* |Pavel| "16-Oct-86 21:13")

    (let ((tableentry (gethash object *print-circle-hashtable*)))
         (case tableentry ((t1 nil)
                           (cl:values nil nil))
               (t2 (cl:values (prog1 (concat (character (|fetch|
 (readtablep hashmacrochar)
                                                           |of|
 *readtable*))
                                            *print-circle-number* "=")
                                     (cl:setf (cl:gethash object *print-circle-hashtable*)
                                            *print-circle-number*)
                                     (cl:incf *print-circle-number*))
                          t))
               (cl:otherwise (cl:if (numberp tableentry)
                                    (cl:values (concat (character (|fetch|
 (readtablep hashmacrochar)
                                                                     |of|
 *readtable*))
                                                      tableentry "#")
                                           nil)
                                    (cl:error "Print-circle-lookup hashtable error!")))))))

(print-circle-label-p

  (cl:lambda (object)
                                        (* |jrb:| "30-Jun-86 23:04")

         (declare
 (cl:special *print-circle-hashtable*))
         (cl:block print-circle-label-p (let ((tableentry (gethash object *print-circle-hashtable*)))
                                             (cond
                                                ((eq tableentry 't2))
                                                ((cl:integerp tableentry)
                                                 tableentry)
                                                (t nil))))))

(print-circle-scan

  (cl:lambda (object)
                                        (* |Pavel| "16-Oct-86 21:17")

         (declare
 (cl:special *print-array*))
         (cl:typecase object (cons (cl:when (not (print-circle-enter
 object))
                                          (print-circle-scan
 (car object))
                                          (print-circle-scan
 (cdr object))))
                ((cl:array t)
                 (cl:when (and *print-array* (not (print-circle-enter
 object)))

                                                  (* \; 

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

                        (let* ((asize (cl:array-total-size object))
                               (varray (cl:if (> (cl:array-rank object)
                                                 1)
                                              (cl:make-array asize :displaced-to object)
                                              object)))
                              (cl:dotimes (x asize)
                                     (print-circle-scan
 (cl:aref varray x)))))))))

(print-circle-enter

  (cl:lambda (object)
         (declare
 (cl:special *print-circle-hashtable* there-are-circles))

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

         (case (cl:gethash object *print-circle-hashtable*)
               (nil (cl:setf (cl:gethash object *print-circle-hashtable*)
                           't1)
                    nil)
               (t1 (cl:setf (cl:gethash object *print-circle-hashtable*)
                          't2)
                   (setq there-are-circles t)
                   t)
               (t2 t)
               (cl:otherwise (cl:error "Print-circle-enter hashtable error!")))))
)
(defineq

(\\prindatum

  (lambda (x stream cpl)
                                     (* |gbn| " 7-Aug-86 16:20")

    (selectc (ntypx x)
        (\\litatom (\\litprin
 x stream))
        (\\listp (or cpl (setq cpl 0))
                 (let (label firsttime)
                      (|if|
 *print-circle-hashtable*
                          |then|
 (cl:multiple-value-setq (label firsttime)
                                        (print-circle-lookup
 x)))
                      (|if|
 label
                          |then|
 (\\ckpossout
 stream label)
                                (cl:when firsttime (\\ckposbout
 stream (charcode space))))
                      (cond
                         ((and label (not firsttime))        (* |Second| |reference| -

                                                             |just| |print| |label|)

                          nil)
                         ((and *print-level* (ileq *print-level* cpl))
                          (\\elide.print.element
 stream))
                         (t (prog (cdrcnt)
                                  (cond
                                     (*print-length* (setq cdrcnt (cond
                                                                     ((|fetch|
 (readtablep commonlisp
                                                                                      ) |of|
 
                                                                                          *readtable*
                                                                             )
                                                                      0)
                                                                     (t 
                                                             (* |Interlisp| |print| |depth| |is| 

                                                             |triangular,| |Common| |Lisp| |isn't|)

                                                                        (cond
                                                                           ((igeq cpl *print-length*)
          
          (* w\e |would| |just| |print| "(--)" |so| |it's| |nicer| |to| |print| "&")


                                                                            (return (

                                                                                \\elide.print.element

                                                                                     stream))))
                                                                        cpl)))))
                                  (|add|
 cpl 1)              (* |Recursive| |calls| |will| |be| 

                                                             |at| 1 |greater| |depth|)

                                  (\\ckposbout
 stream (charcode \())
                              lp  (cond
                                     ((and cdrcnt (igreaterp (|add|
 cdrcnt 1)
                                                         *print-length*))
                                                             (* |have| |printed| |as| |many| 

                                                             |elements| |as| |allowed|)

                                      (\\elide.print.tail
 stream t))
                                     (t (\\prindatum
 (car x)
                                               stream cpl)
                                        (cond
                                           ((listp (setq x (cdr x)))
                                            (\\ckposbout
 stream (charcode space))
                                            (|if|
 (and *print-circle-hashtable* (print-circle-label-p

                                                                                 x))
                                                |then|
       (* "Must print as a dotted tail")

                                                      (\\ckpossout
 stream ". ")
                                                      (\\prindatum
 x stream cpl)
                                              |else|
 (go lp)))
                                           (x                (* |Dotted| |tail|)

                                              (\\ckpossout
 stream " . ")
                                              (\\prindatum
 x stream)))))
                                  (\\ckposbout
 stream (charcode ")")))))))
        ((list \\smallp \\fixp) 
             (with-resources (\\numstr \\numstr1)
                    (\\ckpossout
 stream (\\convertnumber
 x (\\checkradix *print-base*)
                                               t
                                               (and *print-radix* *readtable*)
                                               \\numstr \\numstr1))))
        (\\floatp (with-resources (\\numstr \\numstr1)
                         (\\ckpossout
 stream (\\convert.floating.number x \\numstr \\numstr1
                                                    (cond
                                                       ((and (pnamestreamp
 stream)
                                                             (not prxflg))
          
          (* |The| |pname| |of| \a |number| |is| |unaffected| |by| radix |unless| prxflg 

          |is| |true.| |This| |seems| |silly,| |but| |assorted| |code| |will| |break| 

          |otherwise|)


                                                        t)
                                                       (t \\floatformat))))))
        (\\stringp (\\prinstring
 x stream))
        (\\stackp (\\prinstackp
 x stream))
        (cond
           ((\\instance-p x 't)
          
          (* |this| |is| \a |common-loops| |object,| |since| |it| |is| \a |sub-class| 

          |of| \t)


            (print-instance x stream 0))
           (t (let* ((type (typename x))
                     (fn (fassoc type \\defprintfns)))
                    (cond
                       ((or (null fn)
                            (null (setq fn (let ((*print-level* (and *print-level*
                                                                     (idifference *print-level*
                                                                            (or cpl 0)))))
          
          (* |This| |way| |recursive| |calls| |to| print |etc| |will| |be| |at| |the| "right" 

          |level|)


                                                (apply* (cdr fn)
                                                       x stream 0)))))
                                                             (* n\o |defined| |printer,| |or| 

                                                             |printer| |declined| |to| |do| 

                                                             |anything|)

                        (cond
                           ((|fetch|
 (readtablep commonlisp) |of|
 *readtable*)
                            (.spacecheck. stream 2)
                            (\\outchar
 stream (|fetch|
 (readtablep hashmacrochar) |of|
 *readtable*))
                            (\\outchar
 stream (charcode "<"))
                            (and type (\\litprin
 type stream))
                            (\\ckpossout
 stream " @ ")
                            (\\printaddr
 x stream)
                            (\\ckposbout
 stream (charcode ">")))
                           (t (\\ckposbout
 stream (charcode {))
                              (and type (\\litprin
 type stream))
                              (\\ckposbout
 stream (charcode }))
                              (\\outchar
 stream (charcode "#"))
                              (\\printaddr
 x stream))))
                       ((listp fn)
          
          (* prin1 |the| car (|usually| \a |macro| |char|) |and| prin2 |the| cdr.

          |Nowadays| |there| |is| |little| |reason| |for| \a |defprint| |fn| |to| |not| 

          |do| |its| |own| |printing|)


                        (and (car fn)
                             (let (*print-escape*)
                                  (\\prindatum
 (car fn)
                                         stream)))
                        (and (cdr fn)
                             (\\prindatum
 (cdr fn)
                                    stream cpl))))))))))

(\\elide.print.element

  (lambda (stream)
                                           (* |jrb:| "29-Jun-86 21:05")

    (\\outchar
 stream (\\elide.element.char
))))

(\\elide.element.char

  (lambda nil
                                                (* |jrb:| "29-Jun-86 21:04")

    (cond
       ((|fetch|
 (readtablep commonlisp) |of|
 *readtable*)
        (|fetch|
 (readtablep hashmacrochar) |of|
 *readtable*))
       (t (charcode "&")))))

(\\elide.print.tail

  (lambda (stream nospacep)
                                  (* |jrb:| "29-Jun-86 21:06")

          
          (* * |Prints| |the| |appropriate| |elision| |indicator| |for| |elements| 

          |beyond| *print-depth* |according| |to| |the| |read| |table| |we're| |using.|

          |Prints| |first| \a |space| |unless| nospacep)


    (cond
       ((not nospacep)
        (\\outchar
 stream (charcode space))))
    (\\sout
 (\\elide.tail.string
)
           stream)))

(\\elide.tail.string

  (lambda nil
                                                (* |jrb:| "29-Jun-86 21:05")

    (cond
       ((|fetch|
 (readtablep commonlisp) |of|
 *readtable*)
        "...")
       (t "--"))))

(\\ckposbout

  (lambda (stream x)
                                         (* |rmk:| "21-OCT-83 12:32")

    (.spacecheck. stream 1)
    (\\outchar
 stream x)))

(\\ckpossout

  (lambda (stream x)
                                         (* |rmk:| "21-OCT-83 12:32")

    (.spacecheck. stream (\\nstringchars x))
    (|for|
 i |instring|
 x |do|
 (\\outchar
 stream i))))

(\\convertnumber

  (lambda (n r ignore rdtbl ns nsb)
                          (* |Pavel| "16-Oct-86 21:02")


                                                  (* |;;;| "Convert integer N to a string in radix R.  RDTBL governs whether radix qualifiers appear.  NS is a scratch promised to be of sufficient length;  NSB is a scratch string pointer.  IGNORE is obsolete flag for printing unsigned numbers")

    (cond
       ((eq n 0)
        "0")
       (t (let* ((sign)
                 (x (cond
                       ((geq n 0)
                        n)
                       (t (setq sign (iminus n)))))
                 (pos (\\nstringchars (\\dtest ns 'stringp)))
                 (end (sub1 pos))
                 didq)
                (cond
                   ((and (eq r 8)
                         rdtbl
                         (not (|fetch|
 (readtablep commonlisp) |of|
 rdtbl))
                         (igreaterp x 7))
                    (* \; "Octal numbers have Q suffix")

                    (rplcharcode ns (|add|
 end 1)
                           (charcode q))
                    (setq didq t)))
                (|repeatuntil|
 (eq x 0) |do|
 (rplcharcode ns (|add|
 pos -1)
                                                    (let ((digit (iremainder x r)))
                                                         (cond
                                                            ((ilessp digit 10)
                                                             (iplus digit (charcode 0)))
                                                            (t 

                                                  (* \; 

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

                                                               (iplus (idifference digit 10)
                                                                      (charcode a))))))
                                             (setq x (iquotient x r)))
                (cond
                   (sign (rplcharcode ns (|add|
 pos -1)
                                (charcode -
))))
                (cond
                   ((and (neq r 10)
                         rdtbl
                         (not didq)
                         (let ((n (iabs n)))
                              (or (greaterp n 9)
                                  (geq n r))))
               (* \; "Prepend a radix qualifier")

                    (selectq r
                        (16 (rplcharcode ns (|add|
 pos -1)
                                   (charcode \x)))
                        (8 (rplcharcode ns (|add|
 pos -1)
                                  (charcode \o)))
                        (2 (rplcharcode ns (|add|
 pos -1)
                                  (charcode \b)))
                        (progn (rplcharcode ns (|add|
 pos -1)
                                      (charcode \r))
                               (rplcharcode ns (|add|
 pos -1)
                                      (iplus (charcode 0)
                                             (imod r 10)))
                               (cond
                                  ((geq r 10)
                                   (rplcharcode ns (|add|
 pos -1)
                                          (iplus (charcode 0)
                                                 (iquotient r 10)))))))
                    (rplcharcode ns (|add|
 pos -1)
                           (|fetch|
 (readtablep hashmacrochar) |of|
 rdtbl))))
                (substring ns pos end nsb))))))

(\\litprin

  (lambda (x stream)
                                         (* |bvm:| "30-Sep-86 00:12")

    (declare
 (usedfree \\thisfilelinelength *print-escape* *readtable* *package* *print-gensym* 
                    *print-case*))
    (cond
       (*print-escape* (let ((rdtbl *readtable*)
                             pkg pkgsepr)
                            (cond
                               (*package* 
         (* \; "This is NIL until packages get turned on")

                                      (cond
                                         ((eq *package* (setq pkg (|fetch|
 (cl:symbol package)
                                                                     |of|
 x)))

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

                                          (setq pkg nil))
                                         ((null pkg)

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

                                          (cond
                                             (*print-gensym* 

                                                  (* \; 

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

                                                    (rplcharcode (setq pkgsepr (allocstring
                                                                                2
                                                                                (charcode ":")))
                                                           1
                                                           (|fetch|
 (readtablep hashmacrochar)
                                                              |of|
 rdtbl)))))
                                         ((eq pkg *keyword-package*)

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

                                          (setq pkgsepr (allocstring 1 (|fetch|
 (readtablep 
                                                                                       packagechar)
                                                                          |of|
 rdtbl)))
                                          (setq pkg nil))
                                         ((find-exact-symbol x *package*)

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

                                          (setq pkg nil))
                                         (t 
      (* |;;| "Package qualifier is needed; we need only know now whether symbol is  internal or external in its home package.")

                                            (setq pkgsepr (allocstring (cond
                                                                          ((eq x (
                                                                                 find-external-symbol
                                                                                  x pkg))

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

                                                                           1)
                                                                          (t 2))
                                                                 (|fetch|
 (readtablep packagechar)
                                                                    |of|
 rdtbl)))))))
                            (\\litprin.internal
 x rdtbl stream (and pkg (package-name-as-symbol
                                                                         pkg))
                                   pkgsepr \\thisfilelinelength)))
       (t (.spacecheck. stream (\\natomchars x))
          (|for|
 c |inatom|
 x |bind|
 (downcase _ (and (eq *print-case* ':downcase)
                                                      (|fetch|
 (readtablep caseinsensitive)
                                                         |of|
 *readtable*)))
             |do|
 (\\outchar
 stream (cond
                                       ((and downcase (leq c (charcode z))
                                             (geq c (charcode a)))
                                        (iplus c (idifference (charcode \a)
                                                        (charcode a))))
                                       (t c))))))))

(\\litprin.internal

  (lambda (cl:symbol rdtbl stream pkgname pkgsepr checklength)

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

          
          (* * |Print| cl:symbol |to| stream |according| |to| rdtbl\, |preceded| |by| 

          pkgname (|if| |non-NIL|) |and/or| pkgsepr.

          pkgname |is| \a |symbol,| pkgsepr |is| \a |string.|

          i\f checklength |is| |true,| |need| |to| |check| |that| |there| |is| |room| 

          |for| |printing| |all| |three| |parts| |on| |this| |line;|

          |else| |caller| |has| |verified| |that| |there| |is| |room|)


    (let ((pnamelength (\\natomchars cl:symbol))
          (escape (|fetch|
 (readtablep escapechar) |of|
 rdtbl))
          (multescape (|fetch|
 (readtablep multescapechar) |of|
 rdtbl))
          usemultescape casebase sa syn nescapes checkescape firstescape)
         (cond
            ((or checklength (neq multescape 0))
          
          (* |have| |to| |check| |now| |if| |linelength| |matters| |or| |we| |plan| |to| 

          |use| |multiple| |escapes|)


             (setq nescapes (\\symbol.escape.count
 cl:symbol rdtbl (null checklength)))
             (cond
                ((eq nescapes -1)
          
          (* |Pname| |is| |numeric| |and| |we| |don't| |have| \a |multiple| |escape| 

          |available--need| |to| |escape| |first| |char|)


                 (setq nescapes 1)
                 (setq firstescape t))
                ((ilessp nescapes 0)                         (* |Use| |multiple| |escapes|)

                 (setq nescapes (iminus nescapes))
                 (setq usemultescape t))
                ((neq nescapes 0)
                 (setq checkescape t))))
            (t 
          
          (* |if| |we| |don't| |check| |now| |then| |have| |to| |check| |while| 

          |printing|)


               (setq checkescape t)))
         (cond
            (checklength                                     (* |Verify| |space| |for| |everything|)

                   (.spacecheck. stream (iplus pnamelength nescapes (cond
                                                                       (pkgname 
                                                             (* |How| |much| |space| |to| |print| 

                                                             |package| |name|)

                                                                              (iabs (

                                                                                \\symbol.escape.count

                                                                                     pkgname rdtbl)))
                                                                       (t 0))
                                               (cond
                                                  (pkgsepr   (* |Extra| |characters| |between| 

                                                             |pkg| |name| |and| |symbol| |name|)

                                                         (\\nstringchars pkgsepr))
                                                  (t 0))))))
          
          (* * |First| |print| |any| |needed| |package| |qualifier|)


         (cond
            (pkgname                                         (* |Print| |package| |name,| |don't| 

                                                             |check| |length|)

                   (\\litprin.internal
 pkgname rdtbl stream)))
         (cond
            (pkgsepr (\\sout
 pkgsepr stream)))
         (cond
            (firstescape 
          
          (* |Need| |an| |escape| |character| |at| |start| |to| |keep| |atom| |from| 

          |being| |interpreted| |as| |number|)


                   (\\outchar
 stream escape)))
         (cond
            (usemultescape 
          
          (* |Surround| |pname| |with| |multiple| |escape| |char,| |only| |escape| 

          |internal| |escapes|)


                   (\\outchar
 stream multescape)
                   (|for|
 c |inatom|
 cl:symbol |do|
 (cond
                                                       ((or (eq c multescape)
                                                            (eq c escape))
                                                        (\\outchar
 stream escape)))
                                                    (\\outchar
 stream c))
                   (\\outchar
 stream multescape))
            ((and (eq pnamelength 1)
                  (eq (chcon1 cl:symbol)
                      (charcode ".")))
          
          (* |have| |to| |handle| |period| |special| |because| |it| |is| |only| |special| 

          |in| \a |dotted| |context|)


             (\\outchar
 stream escape)
             (\\outchar
 stream (charcode ".")))
            (t (cond
                  (checkescape (setq casebase (and (|fetch|
 (readtablep caseinsensitive) |of|
 rdtbl)
                                                   (|fetch|
 (arrayp base) |of|
 uppercasearray)))
                         (setq sa (|fetch|
 readsa |of|
 rdtbl))))
               (|for|
 c |inatom|
 cl:symbol |bind|
 (firstflg _ t)
                                                 (downcase _ (and (|fetch|
 (readtablep 
                                                                                  caseinsensitive)
                                                                     |of|
 rdtbl)
                                                                  (eq *print-case* ':downcase)))
                  |do|
 (cond
                          ((and checkescape (or (and casebase (ileq c \\maxthinchar)
                                                     (neq c (\\getbasebyte casebase c)))
                                                (and (|fetch|
 (readcode escquote)
                                                        |of|
 (setq syn (\\syncode sa c)))
                                                     (or firstflg (|fetch|
 (readcode innerescquote)
                                                                     |of|
 syn)))))
          
          (* |Need| |to| |escape| |if:| |character| |is| |lower| |case| |when| 

          |case-insensitive,| |or| |character| |intrinsically| |needs| |escape.|)


                           (\\outchar
 stream escape)
                           (\\outchar
 stream c))
                          (t (\\outchar
 stream (cond
                                                  ((and downcase (leq c (charcode z))
                                                        (geq c (charcode a)))
                                                   (iplus c (idifference (charcode \a)
                                                                   (charcode a))))
                                                  (t c)))))
                       (setq firstflg nil)))))))

(\\symbol.escape.count

  (lambda (cl:symbol rdtbl inexactok)
                        (* |bvm:| " 8-Aug-86 12:31")

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


    (|for|
 c |inatom|
 cl:symbol |bind|
 (result _ 0)
                                      (nescapes _ 0)
                                      (firstflg _ t)
                                      (multescape _ (|fetch|
 (readtablep multescapechar) |of|
 rdtbl))
                                      (escape _ (|fetch|
 (readtablep escapechar) |of|
 rdtbl))
                                      (casebase _ (and (|fetch|
 (readtablep caseinsensitive)
                                                          |of|
 rdtbl)
                                                       (|fetch|
 (arrayp base) |of|
 uppercasearray)))
                                      (sa _ (|fetch|
 readsa |of|
 rdtbl))
                                      syn |first|
 (|if|
 (eq multescape 0)
                                                      |then|
 (* "Can't use multiple-escape")

                                                            (setq multescape nil))
       |do|
 (|if|
 (or (and casebase (ileq c \\maxthinchar)
                           (neq c (\\getbasebyte casebase c)))
                      (and (|fetch|
 (readcode escquote) |of|
 (setq syn (\\syncode sa c)))
                           (or firstflg (|fetch|
 (readcode innerescquote) |of|
 syn))))
                |then|
                                       (* "Need protection if char is lowercase in a case-insensitive read table or the read table says it needs it")

                      (|add|
 result 1)
                      (|if|
 multescape
                          |then|
 (|if|
 (or (eq c multescape)
                                           (eq c escape))
                                     |then|
                  (* 

                                                            "These have to be escaped no matter what")

                                           (|add|
 nescapes 1)
                                   |elseif|
 (and inexactok (greaterp (difference result nescapes)
                                                                  1))
                                     |then|
                  (* 

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

                                           (return -2))))
            (setq firstflg nil)
       |finally|
 (return (|if|
 (eq result 0)
                             |then|
                          (* 

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

                                   (let ((len (\\natomchars cl:symbol)))
                                        (|if|
 (eq len 0)
                                            |then|
           (* 

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

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

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

                                                          0)
                                          |elseif|
 (and (eq len 1)
                                                        (eq c (charcode ".")))
                                            |then|
           (* 

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

                                                  1
                                          |elseif|
 (\\numeric.pnamep
 cl:symbol
                                                          (|if|
 (|fetch|
 (readtablep commonlisp)
                                                                   |of|
 rdtbl)
                                                              |then|
 *read-base*
                                                            |else|
 10))
                                            |then|
           (* "Is numeric, must escape it.  Note that if pname is numeric, there can't be any special chars inside it needing escaping.  We wait until now to test numeric on the grounds that it is more likely we will print a symbol with escapable chars than one that is a potential number.")

                                                  (|if|
 multescape
                                                      |then|
 (* 

                                                   "Nicer to use multiple escape around whole symbol")

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

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

                                   (idifference -2 nescapes)
                           |else|
 result)))))

(\\numeric.pnamep

  (lambda (cl:symbol radix)
                                  (* |bvm:| " 4-Aug-86 14:56")

          
          (* * |True| |if| |the| |chars| |in| cl:symbol |are| \a |potential| |number| 

          |in| radix\, |which| |defaults| |to| |the| |current| |read| |base|

          (|according| |to| |current| |read| |table|))


    (let
     ((lastchartype 'first)
      (maxalphadigit (iplus (charcode a)
                            (idifference (or radix (|if|
 (|fetch|
 (readtablep commonlisp)
                                                            |of|
 *readtable*)
                                                       |then|
 *read-base*
                                                     |else|
 10))
                                   11)))
      seenalphadigits seendigits seendecpt seentightletters)
          
          (* i\f radix |is| |bigger| |than| 10\, |this| |allows| |alphabetic| |digits|)


     (|for|
 c |inpname|
 cl:symbol
        |do|
 
          
          (* |The| |inpname| |is| \a |nicety| |so| |it| |works| |on| |strings| |too|

          (|useful| |for| |testing|) -

          |Note| |that| |we| |are| |assuming| \a |partitioning| |of| |character| |space| 

          |as| |follows:| (-

          + / |decpt|) (|digits|) (a-z) (_ ^) (|a-z|))


             (setq lastchartype
              (|if|
 (ilessp c (charcode a))
                  |then|
                                     (* |Numeric| |or| |funny| |char|)

                        (|if|
 (ilessp c (charcode 0))
                            |then|
 (selcharq c
                                        ((- +)               (* |Signs| |anywhere| |but| |end|)

                                             'sign)
                                        (\. (|if|
 seenalphadigits
                                                |then|
 
          
          (* |Can't| |have| |decimal| |point| |in| |other| |radices,| |so| |if| |we| 

          |saw| |combinations| |of| |chars| |that| |would| |have| |been| |invalid| |in| 

          |radix| 10\, |bomb| |out|)


                                                      (|if|
 seentightletters
                                                          |then|
 (return nil))
                                                      (setq seenalphadigits nil))
                                            (setq maxalphadigit 0)
                                            (setq seendecpt t))
                                        (/ (|if|
 (eq lastchartype 'first)
                                               |then|
        (* |Can't| |start| |with| |ratio| 

                                                             |marker|)

                                                     (return nil)))
                                        (return nil))
                          |elseif|
 (ileq c (charcode 9))
                            |then|
                           (* |digit|)

                                  (setq seendigits t)
                                  'digit
                          |else|
 (return nil))
                |elseif|
 (igreaterp c (charcode \z))
                  |then|
                                     (* |Out| |in| |the| |wilderness.|)

                        (return nil)
                |elseif|
 (progn (|if|
 (igeq c (charcode \a))
                                    |then|
                   (* |Raise| |it|)

                                          (setq c (idifference c (idifference (charcode \a)
                                                                        (charcode a)))))
                                (ileq c (charcode z)))
                  |then|
                                     (* |Letter|)

                        (|if|
 (ileq c maxalphadigit)
                            |then|
 
          
          (* |Letter| |is| \a |digit| |in| |this| |base.|

          |Can't| |be| |digit| |in| |number| |with| |decimal| |pt|)


                                  (setq seenalphadigits t)
                                  (selectq lastchartype
                                      ((letter first) 
          
          (* |Two| |letters| |in| \a |row| |or| |started| |with| |letter.|

          |Notice| |this| |in| |case| \a |dec| |pt| |comes| |along|)


                                           (setq seentightletters t))
                                      nil)
                          |else|
 
          
          (* |Potential| |number| |marker| -- |only| |if| |not| |next| |to| |another| 

          |letter|)


                                (selectq lastchartype
                                    ((letter first) 
                                         (return nil))
                                    nil))
                        'letter
                |elseif|
 (or (eq c (charcode _))
                             (eq c (charcode ^)))
                  |then|
 
          
          (* |Extension| |chars,| |not| |used| |now| |but| |maybe| |some| |day.|

          |We're| |supposed| |to| |escape| |these|)


                        nil
                |else|
 (return nil))) |finally|
 
          
          (* |Success| |if| |there| |was| |at| |least| |one| |digit| |and| |didn't| |end| 

          |in| \a |sign|)


                                            (return (and (or seendigits seenalphadigits)
                                                         (neq lastchartype 'sign)))))))

(\\prinstackp

  (lambda (x stream)
                                         (* |bvm:| "11-May-86 16:09")

          
          (* * |Print| |stackp| |as| |addr/framename.|

          i\f |stackp| |is| |released| |or| |framename| |is| |not| \a |symbol,| |print| 

          |mumble|)


    (.spacecheck. stream (iplus 1 (constant (nchars "<StackP "))
                                (progn                       (* |Longest| |stack| |address| |is| 

                                                             "177,177777")

                                       10)
                                1
                                (cond
                                   ((relstkp x)
                                    (constant (nchars "released")))
                                   ((litatom (stkname x))
                                    (\\natomchars (stkname x)))
                                   (t 6))
                                1))
    (\\outchar
 stream (|fetch|
 (readtablep hashmacrochar) |of|
 *readtable*))
    (\\sout
 "<StackP " stream)
    (\\printaddr
 x stream)
    (\\outchar
 stream (charcode /))
    (cond
       ((relstkp x)
        (\\sout
 "released" stream))
       ((litatom (setq x (stkname x)))
        (\\litprin
 x stream))
       (t (\\sout
 "*form*" stream)))
    (\\outchar
 stream (charcode >))))

(\\printaddr

  (lambda (x stream)
                                         (* |bvm:| "11-May-86 15:13")

    (with-resources (\\numstr \\numstr1)
           (selectq (systemtype)
               (d (\\ckpossout
 stream (\\convertnumber
 (\\hiloc x)
                                             8 nil nil \\numstr \\numstr1))
                  (\\ckposbout
 stream (charcode \,))
                  (\\ckpossout
 stream (\\convertnumber
 (\\loloc x)
                                             8 nil nil \\numstr \\numstr1)))
               (jericho (\\ckpossout
 stream (\\convertnumber
 (logand \\addrmask (loc x))
                                                   8 nil nil \\numstr \\numstr1)))
               (vax (\\ckpossout
 stream (\\convertnumber
 (loc x)
                                               16 t nil \\numstr \\numstr1)))
               ((tenex tops-20) 
                    (\\ckpossout
 stream (\\convertnumber
 (loc x)
                                               8 t nil \\numstr \\numstr1)))
               (systemtypepunt '(\\prindatum
 x))))))

(\\prinstring

  (lambda (x stream)
                                         (* |bvm:| "11-May-86 15:08")

    (cond
       (*print-escape*                                       (* |Print| |with| |double| |quotes| 

                                                             |and| |escaped| |as| |needed|)

              (let ((esc (|fetch|
 (readtablep escapechar) |of|
 *readtable*)))
                   (.spacecheck. stream (iplus 2 (\\nstringchars x)
                                               (|for|
 c |instring|
 x
                                                  |count|
 (or (eq c (charcode \"))
                                                              (eq c esc)))))
                   (\\outchar
 stream (charcode \"))
                   (|for|
 c |instring|
 x |do|
 (cond
                                                 ((or (eq c (charcode \"))
                                                      (eq c (charcode lf))
                                                      (eq c esc))
          
          (* vm |says| |only| \" |is| |escaped| |no| |matter| |what| |stringdelim's| 

          |are.|)


                                                  (\\outchar
 stream esc)))
                                              (\\outchar
 stream c))
                   (\\outchar
 stream (charcode \"))))
       (t (.spacecheck. stream (\\nstringchars x))
          (\\sout
 x stream)))))

(\\sout

  (lambda (x stream)
                                         (* |rmk:| "21-OCT-83 12:32")

    (|for|
 i |instring|
 x |do|
 (\\outchar
 stream i))))

(\\outchar

  (lambda (stream charcode)
                                  (* |rmk:| " 7-APR-82 00:25")

    (streamop 'outcharfn stream stream charcode)))

(\\fileoutcharfn

  (lambda (stream charcode)
                                  (* |bvm:| "26-Mar-86 10:40")

                                                             (* outcharfn |for| |standard| |files|)

    (cond
       ((eq charcode (charcode eol))
        (cond
           ((not (\\runcoded stream))                        (* |Charset| |is| \a |constant| 0)

            (\\bout stream (\\charset (charcode eol))))
           ((eq (\\charset (charcode eol))
                (|ffetch|
 charset |of|
 stream)))
           (t (\\bout stream nscharsetshift)
              (\\bout stream (|freplace|
 (stream charset) |of|
 stream |with|
 (\\charset (charcode
                                                                                         eol))))))
        (\\bout stream (selectc (|ffetch|
 eolconvention |of|
 stream)
                           (cr.eolc (charcode cr))
                           (lf.eolc (charcode lf))
                           (crlf.eolc (\\bout stream (charcode cr))
          
          (* |Don't| |put| |out| |high-order| |byte| |preceding| lf.

          |The| crlf |is| eol |only| |if| |the| |bytes| |are| |immediately| |adjacent| 

          |in| |the| |stream,| |with| |no| |additional| |encoding| |bytes|)


                                      (charcode lf))
                           (shouldnt)))
        (|freplace|
 charposition |of|
 stream |with|
 0))
       (t (cond
             ((not (\\runcoded stream))
              (\\bout stream (\\charset charcode))
              (\\bout stream (\\char8code charcode)))
             ((eq (\\charset charcode)
                  (|ffetch|
 charset |of|
 stream))
              (\\bout stream (\\char8code charcode)))
             (t (\\bout stream nscharsetshift)
                (\\bout stream (|freplace|
 (stream charset) |of|
 stream |with|
 (\\charset charcode)))
                (\\bout stream (\\char8code charcode))))
          (|freplace|
 charposition |of|
 stream |with|
 (progn (* |Ugh.| |Don't| |overflow|)

                                                             (iplus16 (|ffetch|
 charposition
                                                                         |of|
 stream)
                                                                    1)))))))

(\\ttyoutcharfn

  (lambda (stream ch)
                                        (* |hdj| "17-Sep-86 19:21")


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

    (let ((op (|fetch|
 otherprops |of|
 stream)))
         (let ((dribblestream (listget op 'dribblestream)))
              (|if|
 dribblestream
                  |then|
 (\\outchar
 dribblestream ch)))
         (cl:funcall (listget op 'old-outcharfn)
                stream ch))))
)
(declare\: eval@compile dontcopy 
(declare\: eval@compile 

(putprops .filelinelength. macro ((strm)
                                  (let ((l (|fetch| (stream linelength)
                                                  |of| strm)))
                                       (selectc l (0 (* |Some| |default|)
                                                     \\linelength)
                                              (max.smallp (* |Infinite|)
                                                     nil)
                                              l))))
)

(* FOLLOWING DEFINITIONS EXPORTED)


(declare\: eval@compile 

(putprops .spacecheck. macro ((strm n)
                              (and \\thisfilelinelength (igreaterp (iplus n (|fetch| charposition 
                                                                                   |of| strm))
                                                               \\thisfilelinelength)
                                   (freshline strm))))
(putprops \\checkradix macro (lambda (r)
                                    (cond ((or (not (smallp r))
                                               (ilessp r 1)
                                               (igreaterp r 36))
                                           (\\invalid.radix r))
                                          (t r))))
)


(* END EXPORTED DEFINITIONS)

)
(defineq

(\\invalid.radix

  (lambda (n)
                                                (* |bvm:| " 5-May-86 10:58")

    (error "Bad value for *print-base*" n)))
)
(declare\: doeval@compile dontcopy

(specvars \\thisfilelinelength)
)



(* \; "Internal printing")


(defineq

(\\mappname

  (lambda (fn x flg rdtbl)
                                   (* |bvm:| "13-May-86 15:05")

          
          (* * |Run| |thru| |the| |characters| |in| |the| |pname| |of| x\, |calling| fn 

          |on| |each| |character.| |For| |speed,| fn |is| |defined| |to| |be| |of| |the| 

          |same| |form| |as| |an| outcharfn\, |viz.,| |arglist| =

          (|stream| |char|)\; |stream| |in| |this| |case| |is| \a |dummy|)


    (let ((*print-escape* flg)
          (*readtable* (cond
                          (flg (\\gtreadtable rdtbl))
                          (t (\\dtest *readtable* 'readtablep))))
          (*print-base* (cond
                           (prxflg *print-base*)
                           (t 10)))
          (*print-radix*)
          (*print-level*)
          (*print-length*))
         (declare
 (specvars *readtable* *print-escape* *print-base* *print-radix* *print-level* 
                         *print-length*))                    (* |numbers| |print| |in| |decimal| 

                                                             |unless| prxflg)

         (cond
            ((and flg (neq *print-base* 10))
             (setq *print-radix* t)))
         (\\mappname.internal
 fn x))))

(\\mappname.internal

  (lambda (fn x)
                                             (* |bvm:| "13-May-86 15:01")

    (with-resource (\\mappnamestream)
           (|replace|
 outcharfn |of|
 \\mappnamestream |with|
 fn)
           (|replace|
 strmboutfn |of|
 \\mappnamestream |with|
 fn)
          
          (* |Should| |never| |use| |the| |bout| |fn,| |but| |include| |it| |just| |in| 

          |case| |somebody| |thinks| \\outchar = \\bout)


           (let (\\thisfilelinelength)                       (* |Stream| |has| |no| |linelength| 

                                                             |checks|)

                (declare
 (specvars \\thisfilelinelength))
                (\\prindatum
 x \\mappnamestream 0)))))

(pnamestreamp

  (lambda (strm)
                                             (* |bvm:| "24-Mar-86 17:37")

          
          (* * |True| |if| strm |is| |an| |internal-printing| |stream| |for| |pnames,| 

          |i.e.,| |one| |of| |the| |values| |of| |the| \\mappnamestream |resource|)


    (and (typenamep strm 'stream)
         (eq (|fetch|
 (stream device) |of|
 strm)
             \\pnamedevice))))
)
(declare\: dontcopy 
(declare\: eval@compile 
(putdef '\\mappnamestream 'resources
       '(new (|create| stream device _ \\pnamedevice accessbits _ |OutputBits| linelength _ 
                    max.smallp)))
)

(declare\: eval@compile 

(putprops pnamestreamp dmacro ((strm)
                               (eq (|fetch| (stream device)
                                          |of| strm)
                                   \\pnamedevice)))
)
)
(/settopval '\\\\mappnamestream.globalresource)

(rpaq? \\pnamedevice
 (ncreate 'fdev (\\getdevicefromhostname 'null t)))
(declare\: doeval@compile dontcopy

(globalvars \\pnamedevice)
)



(* \; "Obsolete")


(defineq

(\\mapchars

  (lambda (\\mapcharfn x flg rdtbl)
                          (* |bvm:| "13-Mar-86 18:53")

    (declare
 (specvars rdtbl))
          
          (* * |Run| |thru| |the| |characters| |in| |the| |pname| |of| x\, |calling| 

          \\mapcharfn |on| |each| |character.|)


    (\\mappname
 (function (lambda (dummy char)
                            (spreadapply* \\mapcharfn char)))
           x flg rdtbl)))
)
(declare\: eval@compile docopy 

(addtovar sysspecvars
 *print-base* *read-base* *print-radix* *print-escape* *print-case* 
                            *print-gensym* *print-level* *print-length* *print-pretty* *print-circle* 
                            *print-array* *package*)
)



(* \; "PRINTNUM and friends")


(defineq

(printnum

  (lambda (cl:format cl:number file)                         (* declarations\: (record fixfmt

                                                             (width radix pad0 leftflush))

                                                             (record floatfmt (width decpart 

                                                             exppart pad0 sigdigits)))

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

    (declare
 (globalvars nilnumprintflg))
    (globalresource (\\numstr \\numstr1)
           (prog (str width pad temp rad (floatflag (selectq (car (listp cl:format))
                                                        (float t)
                                                        (fix nil)
                                                        (lisperror "ILLEGAL ARG" cl:format)))
                      (fmt (cdr cl:format)))
                 (setq width (|fetch|
 width |of|
 fmt))
                 (setq str (cond
                              ((and (null cl:number)
                                    nilnumprintflg))
                              (floatflag (\\convert.floating.number (float cl:number)
                                                \\numstr \\numstr1 (\\checkfltfmt
 cl:format)))
                              (t (\\convertnumber
 (or (fixp cl:number)
                                                      (fixr cl:number))
                                        (cond
                                           ((setq rad (|fetch|
 radix |of|
 fmt))
                                            (setq temp (iabs rad))
                                            (cond
                                               ((or (igreaterp 2 temp)
                                                    (igreaterp temp 16))
                                                (\\illegal.arg rad)))
                                            temp)
                                           (t 10))
                                        (or (null rad)
                                            (igreaterp rad 0))
                                        nil \\numstr \\numstr1))))
                 (setq pad (cond
                              (width (idifference width (nchars str)))
                              (t 0)))
                 (cond
                    ((and (igreaterp pad 0)
                          (or floatflag (null (|fetch|
 leftflush |of|
 fmt))))
                     (cond
                        ((cond
                            (floatflag (|fetch|
 (floatfmt pad0) |of|
 fmt))
                            (t (|fetch|
 (fixfmt pad0) |of|
 fmt)))
                         (frptq pad (prin1
 "0" file)))
                        (t (spaces
 pad file)))))
                 (prin1
 str file)
                 (cond
                    ((and (igreaterp pad 0)
                          (not floatflag)
                          (|fetch|
 leftflush |of|
 fmt))
                     (spaces
 pad file)))
                 (return cl:number)))))

(fltfmt

  (lambda (cl:format)
                                        (* |bvm:| "30-JAN-81 23:20")

                                                             (* |numeric| |arg,| |as| |on| 10\, 

                                                             |not| |allowed|)

    (prog1 \\floatformat (and cl:format (\\checkfltfmt
 cl:format)
                              (setq \\floatformat cl:format)))))

(\\checkfltfmt

  (lambda (cl:format)
                                        (* |bvm:| "29-JAN-81 15:41")

          
          (* * |Generates| |error| |if| cl:format |is| |not| |legal| float |format:|

          (float width decpart exppart pad sigdigits))


    (cond
       ((or (eq cl:format t)
            (and (eq (car cl:format)
                     'float)
                 (every (cdr cl:format)
                        (function (lambda (x)
                                    (or (null x)
                                        (fixp x)))))))
        cl:format)
       (t (lisperror "ILLEGAL ARG" cl:format)))))
)
(declare\: eval@compile 

(progn (putprops numformatcode bytemacro (= . prog1))
       (putprops numformatcode dmacro (= . prog1)))
)

(rpaq? nilnumprintflg
 )
(declare\: doeval@compile dontcopy

(localvars . t)
)
(declare\: doeval@compile dontcopy

(globalvars \\linelength \\floatformat prxflg \\defprintfns)
)
(declare\: donteval@load doeval@compile dontcopy compilervars 

(addtovar nlama
 )

(addtovar nlaml
 )

(addtovar lama
 print-circle-enter print-circle-scan print-circle-label-p)
)
(putprops aprint copyright ("Xerox Corporation" 1982 1983 1984 1985 1986))
(declare\: dontcopy
  (filemap (nil (3751 13390 (prin1 3761 . 5309) (prin2 5311 . 6584) (prin3 6586 . 7658) (prin4 7660 . 
8948) (print 8950 . 9196) (printccode 9198 . 9484) (printlevel 9486 . 10305) (radix 10307 . 10487) (
spaces 10489 . 10847) (terpri 10849 . 11041) (freshline 11043 . 11792) (defprint 11794 . 12394) (
linelength 12396 . 13388)) (14056 17786 (print-circle-lookup 14066 . 15311) (print-circle-label-p 
15313 . 15916) (print-circle-scan 15918 . 17092) (print-circle-enter 17094 . 17784)) (17787 62447 (
\\prindatum 17797 . 26227) (\\elide.print.element 26229 . 26409) (\\elide.element.char 26411 . 26711) 
(\\elide.print.tail 26713 . 27233) (\\elide.tail.string 27235 . 27468) (\\ckposbout 27470 . 27643) (
\\ckpossout 27645 . 27875) (\\convertnumber 27877 . 31524) (\\litprin 31526 . 36264) (
\\litprin.internal 36266 . 43288) (\\symbol.escape.count 43290 . 49546) (\\numeric.pnamep 49548 . 
55212) (\\prinstackp 55214 . 56615) (\\printaddr 56617 . 57736) (\\prinstring 57738 . 59212) (\\sout 
59214 . 59394) (\\outchar 59396 . 59559) (\\fileoutcharfn 59561 . 61920) (\\ttyoutcharfn 61922 . 62445
)) (63828 64003 (\\invalid.radix 63838 . 64001)) (64109 66595 (\\mappname 64119 . 65381) (
\\mappname.internal 65383 . 66162) (pnamestreamp 66164 . 66593)) (67258 67711 (\\mapchars 67268 . 
67709)) (68035 72253 (printnum 68045 . 71180) (fltfmt 71182 . 71609) (\\checkfltfmt 71611 . 72251))))
)
stop