github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-25 20:06:44 +00:00
Code Issues Projects Releases Wiki Activity

add merge in Ron's 11/21/2020 lispcore

Browse Source
This commit is contained in:
Larry Masinter
2020-11-21 13:24:44 -08:00
parent e9a80b1144
commit ce4eae736e
794 changed files with 117194 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

363
CLTL2/CMLPRINT Normal file
View File

@@ -0,0 +1,363 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "18-Oct-93 14:35:18" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPRINT.;2" 16374
previous date%: " 8-Jul-92 17:21:55" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPRINT.;1")
(* ; "
Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLPRINTCOMS)
(RPAQQ CMLPRINTCOMS
[(FNS WRITE LISP:WRITE-CHAR LISP:PRIN1 LISP:PRINT LISP:TERPRI LISP:FRESH-LINE
LISP:FINISH-OUTPUT LISP:FORCE-OUTPUT LISP:CLEAR-OUTPUT LISP:PPRINT LISP:PRINC)
(FUNCTIONS \WRITE1)
(FNS LISP:WRITE-TO-STRING LISP:PRIN1-TO-STRING LISP:PRINC-TO-STRING)
(FNS WRITE-STRING*)
(FUNCTIONS LISP:WRITE-STRING LISP:WRITE-LINE)
(INITVARS (XCL:*PRINT-STRUCTURE*))
(VARIABLES LISP:*PRINT-READABLY*)
(PROP FILETYPE CMLPRINT)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA LISP:WRITE-TO-STRING LISP:PRINC LISP:PPRINT LISP:PRINT LISP:PRIN1
LISP:WRITE-CHAR WRITE])
(DEFINEQ
(WRITE
(LISP:LAMBDA (OBJECT &KEY (STREAM *STANDARD-OUTPUT*)
((:ESCAPE *PRINT-ESCAPE*)
*PRINT-ESCAPE*)
((:RADIX *PRINT-RADIX*)
*PRINT-RADIX*)
((:BASE *PRINT-BASE*)
*PRINT-BASE*)
((:LEVEL *PRINT-LEVEL*)
*PRINT-LEVEL*)
((:LENGTH *PRINT-LENGTH*)
*PRINT-LENGTH*)
((:CASE *PRINT-CASE*)
*PRINT-CASE*)
((:GENSYM *PRINT-GENSYM*)
*PRINT-GENSYM*)
((:ARRAY *PRINT-ARRAY*)
*PRINT-ARRAY*)
((:PRETTY *PRINT-PRETTY*)
*PRINT-PRETTY*)
((:CIRCLE *PRINT-CIRCLE*)
*PRINT-CIRCLE*)
((:PPRINT-DISPATCH XP:*PRINT-PPRINT-DISPATCH*)
XP:*PRINT-PPRINT-DISPATCH*)
((:RIGHT-MARGIN XP:*PRINT-RIGHT-MARGIN*)
XP:*PRINT-RIGHT-MARGIN*)
((:LINES XP:*PRINT-LINES*)
XP:*PRINT-LINES*)
((:MISER-WIDTH XP:*PRINT-MISER-WIDTH*)
XP:*PRINT-MISER-WIDTH*)
((:READABLY LISP:*PRINT-READABLY*)
LISP:*PRINT-READABLY*)) (* ; "Edited 11-Oct-91 23:23 by jrb:")
(DECLARE (LISP:SPECIAL *PRINT-ESCAPE* *PRINT-RADIX* *PRINT-BASE* *PRINT-LEVEL*
*PRINT-LENGTH* *PRINT-CASE* *PRINT-GENSYM* *PRINT-ARRAY* *PRINT-PRETTY*
*PRINT-CIRCLE* XP:*PRINT-PPRINT-DISPATCH* XP:*PRINT-RIGHT-MARGIN*
XP:*PRINT-LINES* XP:*PRINT-MISER-WIDTH* LISP:*PRINT-READABLY*
*PRINT-CIRCLE-HASHTABLE* *PRINT-CIRCLE-NUMBER* THERE-ARE-CIRCLES))
(* ;
 "Make sure STREAM ends up as an appropriate stream")
(SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
(LISP:WHEN LISP:*PRINT-READABLY* (HANDLE-PRINT-READABLY))
[COND
[*PRINT-PRETTY* (COND
((XP::XP-STRUCTURE-P STREAM)
(XP::WRITE+ OBJECT STREAM))
(T (XP::MAYBE-INITIATE-XP-PRINTING #'(LISP:LAMBDA (LISP::S LISP::O)
(XP::WRITE+ LISP::O
LISP::S))
STREAM OBJECT]
((OR (NOT *PRINT-CIRCLE*)
*PRINT-CIRCLE-HASHTABLE*)
(\WRITE1 OBJECT STREAM))
(T (LET ((*PRINT-CIRCLE-NUMBER* 1)
(*PRINT-CIRCLE-HASHTABLE* (LISP:MAKE-HASH-TABLE))
THERE-ARE-CIRCLES)
(DECLARE (LISP:SPECIAL *PRINT-CIRCLE-NUMBER* *PRINT-CIRCLE-HASHTABLE*
THERE-ARE-CIRCLES))
(PRINT-CIRCLE-SCAN OBJECT)
(COND
((NOT THERE-ARE-CIRCLES)
(LISP:SETQ *PRINT-CIRCLE-HASHTABLE* NIL)))
(\WRITE1 OBJECT STREAM]
OBJECT))
(LISP:WRITE-CHAR
(LISP:LAMBDA (CHARACTER &OPTIONAL STREAM) (* ; "Edited 11-Oct-91 23:44 by jrb:")
(SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
[COND
((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
(XP::WRITE-CHAR+ CHARACTER STREAM))
[LISP:*PRINT-READABLY* (LET ((*PRINT-ESCAPE* T))
(\OUTCHAR STREAM (LISP:CHAR-INT CHARACTER]
(T (\OUTCHAR STREAM (LISP:CHAR-INT CHARACTER]
CHARACTER))
(LISP:PRIN1
(LISP:LAMBDA (OBJECT &OPTIONAL OUTPUT-STREAM) (* ; "Edited 20-Feb-87 16:58 by bvm:")
(WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE T)))
(LISP:PRINT
(LISP:LAMBDA (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (* ; "Edited 20-Oct-91 21:16 by jrb:")
(SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
(* ;; "The *PRINT-READABLY* case is forced through PRIN1 which goes through WRITE which rebinds everything as necessary")
(COND
[(AND *PRINT-PRETTY* (NOT LISP:*PRINT-READABLY*))
(COND
((XP::XP-STRUCTURE-P STREAM)
(XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM)
(LET ((*PRINT-ESCAPE* T))
(XP::BASIC-WRITE OBJECT STREAM)
(XP::WRITE-CHAR++ #\Space STREAM)))
(T (XP::MAYBE-INITIATE-XP-PRINTING #'(LISP:LAMBDA (LISP::S LISP::O)
(XP::WRITE+ LISP::O LISP::S))
STREAM OBJECT]
(T (TERPRI STREAM)
(LISP:PRIN1 OBJECT STREAM)
(SPACES 1 STREAM)))
OBJECT))
(LISP:TERPRI
[LAMBDA (STREAM) (* ; "Edited 20-Sep-91 13:56 by jrb:")
(* ;; "The clause *PRINT-PRETTY* is not necessary here: if a TERPRI is the first printing operation in a pretty-print sequence, it will be ignored anyway.")
(COND
((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
(XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM))
(T (TERPRI (OR STREAM *STANDARD-OUTPUT*])
(LISP:FRESH-LINE
[LAMBDA (STREAM) (* ; "Edited 20-Sep-91 13:57 by jrb:")
(SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
(COND
((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
(XP::ATTEMPT-TO-OUTPUT STREAM T T) (* ; "ok because we want newline")
(LISP:WHEN (NOT (LISP:ZEROP (XP::LP<-BP STREAM)))
(XP::PPRINT-NEWLINE+ :FRESH STREAM)
T))
(T (FRESHLINE STREAM])
(LISP:FINISH-OUTPUT
[LAMBDA (STREAM) (* ; "Edited 20-Sep-91 14:01 by jrb:")
(SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
(LISP:IF (XP::XP-STRUCTURE-P STREAM)
(XP::ATTEMPT-TO-OUTPUT STREAM T T))
(FORCEOUTPUT STREAM T)
NIL])
(LISP:FORCE-OUTPUT
[LAMBDA (STREAM) (* ; "Edited 20-Sep-91 14:01 by jrb:")
(SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
(LISP:IF (XP::XP-STRUCTURE-P STREAM)
(XP::ATTEMPT-TO-OUTPUT STREAM T T))
(FORCEOUTPUT STREAM)
NIL])
(LISP:CLEAR-OUTPUT
[LAMBDA (STREAM) (* ; "Edited 20-Sep-91 13:14 by jrb:")
(LISP:IF [XP::XP-STRUCTURE-P (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT]
(LET ((XP::*LOCATING-CIRCULARITIES* 0)) (* ; "hack to prevent visible output")
(XP::ATTEMPT-TO-OUTPUT STREAM T T)))
NIL])
(LISP:PPRINT
(LISP:LAMBDA (OBJECT &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*))
(* lmm " 4-May-86 03:19")
(TERPRI OUTPUT-STREAM)
(WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE T :PRETTY T)
(LISP:VALUES)))
(LISP:PRINC
(LISP:LAMBDA (OBJECT &OPTIONAL OUTPUT-STREAM) (* ; "Edited 20-Feb-87 16:59 by bvm:")
(WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE NIL)))
)
(LISP:DEFUN \WRITE1 (OBJECT STREAM)
(* ;; "This used to be where we decided if we were pretty-printing or not; the conditionality was a little strange:")
(* ;; "(CL:IF (AND *PRINT-PRETTY* (OR (NOT *PRINT-CIRCLE*) (NOT *PRINT-CIRCLE-HASHTABLE*)) *PRINT-ESCAPE*) (pretty-print-using-IL:PRINTDEF) (just-print))")
(* ;; "I don't remember why *PRINT-ESCAPE* was tested; I suspect PRINTDEF forces it on. Anyway, we're not using PRINTDEF any more here, I hope.")
(* ;; "otherwise just print it all on one line")
(LET (\THISFILELINELENGTH)
(DECLARE (LISP:SPECIAL \THISFILELINELENGTH))
(* ;; "CommonLisp streams do not observe line length")
(\PRINDATUM OBJECT (\GETSTREAM STREAM 'OUTPUT)
0)))
(DEFINEQ
(LISP:WRITE-TO-STRING
(LISP:LAMBDA (OBJECT &KEY ((:ESCAPE *PRINT-ESCAPE*)
*PRINT-ESCAPE*)
((:RADIX *PRINT-RADIX*)
*PRINT-RADIX*)
((:BASE *PRINT-BASE*)
*PRINT-BASE*)
((:CIRCLE *PRINT-CIRCLE*)
*PRINT-CIRCLE*)
((:PRETTY *PRINT-PRETTY*)
*PRINT-PRETTY*)
((:LEVEL *PRINT-LEVEL*)
*PRINT-LEVEL*)
((:LENGTH *PRINT-LENGTH*)
*PRINT-LENGTH*)
((:CASE *PRINT-CASE*)
*PRINT-CASE*)
((:ARRAY *PRINT-ARRAY*)
*PRINT-ARRAY*)
((:GENSYM *PRINT-GENSYM*)
*PRINT-GENSYM*)
((:PPRINT-DISPATCH XP:*PRINT-PPRINT-DISPATCH*)
XP:*PRINT-PPRINT-DISPATCH*)
((:RIGHT-MARGIN XP:*PRINT-RIGHT-MARGIN*)
XP:*PRINT-RIGHT-MARGIN*)
((:LINES XP:*PRINT-LINES*)
XP:*PRINT-LINES*)
((:MISER-WIDTH XP:*PRINT-MISER-WIDTH*)
XP:*PRINT-MISER-WIDTH*)
((:READABLY LISP:*PRINT-READABLY*)
LISP:*PRINT-READABLY*)) (* ; "Edited 11-Oct-91 23:58 by jrb:")
"Returns the printed representation of OBJECT as a string."
(LISP:WHEN LISP:*PRINT-READABLY* (HANDLE-PRINT-READABLY))
(LISP:IF *PRINT-PRETTY*
(LISP:WITH-OUTPUT-TO-STRING (LISP::S)
(WRITE OBJECT :STREAM LISP::S))
(\PRINDATUM.TO.STRING OBJECT))))
(LISP:PRIN1-TO-STRING
[LAMBDA (OBJECT) (* ; "Edited 20-Oct-91 21:25 by jrb:")
(* ;;; "Produces a string consisting of the output of (PRIN1 OBJECT)")
(LET ((*PRINT-ESCAPE* T))
(* ;;
"We force the *PRINT-READABLY* case through WRITE-TO-STRING to let it rebind the control variables ")
(COND
(LISP:*PRINT-READABLY* (LISP:WRITE-TO-STRING OBJECT))
(*PRINT-PRETTY* (LISP:WITH-OUTPUT-TO-STRING (LISP::S)
(WRITE OBJECT :STREAM LISP::S)))
(T (\PRINDATUM.TO.STRING OBJECT])
(LISP:PRINC-TO-STRING
[LAMBDA (OBJECT) (* ; "Edited 20-Oct-91 21:24 by jrb:")
(* ;;;
"A lot like MKSTRING, but not quite. Produces a string consisting of the output of (PRINC OBJECT)")
(LET ((*PRINT-ESCAPE* NIL))
(* ;;
"We force the *PRINT-READABLY* case through WRITE-TO-STRING to let it rebind the control variables ")
(COND
(LISP:*PRINT-READABLY* (LISP:WRITE-TO-STRING OBJECT))
(*PRINT-PRETTY* (LISP:WITH-OUTPUT-TO-STRING (LISP::S)
(WRITE OBJECT :STREAM LISP::S)))
(T (\PRINDATUM.TO.STRING OBJECT])
)
(DEFINEQ
(WRITE-STRING*
[LAMBDA (STRING STREAM START END) (* ; "Edited 21-Oct-91 13:20 by jrb:")
(OR STREAM (SETQ STREAM *STANDARD-OUTPUT*))
(LISP:UNLESS (EQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY)
(LISP::CHECK-READABLY STRING 'WRITE-STRING*))
(LISP:IF (AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
(XP::WRITE-STRING+ STRING STREAM START END)
[LET ((STRING-LENGTH (LISP:LENGTH STRING)))
(OR START (SETQ START 0))
(LISP:CHECK-TYPE STRING STRING)
(LISP:WHEN (NULL END)
(SETQ END STRING-LENGTH))
(LISP:ASSERT (AND (<= 0 START STRING-LENGTH)
(<= START END STRING-LENGTH))
'(START END)
"Start (~D) or end (~D) argument out of bounds." START END)
(* ;; "The following comes mainly from \PRINSTRING...")
(LET ((CHARS-TO-PRINT (- END START))
\THISFILELINELENGTH)
(DECLARE (SPECVARS \THISFILELINELENGTH))
(LISP:WHEN (LISP:PLUSP CHARS-TO-PRINT)
(.SPACECHECK. STREAM CHARS-TO-PRINT)
(* ;; "Essentially (for x instring string do (\outchar strm x)).")
(LISP:DO [(FATP (ffetch (STRINGP FATSTRINGP) of STRING))
(BASE (ffetch (STRINGP BASE) of STRING))
(OFFSET (IPLUS START (ffetch (STRINGP OFFST) of STRING))
(ADD1 OFFSET))
(END (IPLUS END (ffetch (STRINGP OFFST) of STRING]
((>= OFFSET END))
(\OUTCHAR STREAM (LISP:IF FATP
(\GETBASEFAT BASE OFFSET)
(\GETBASETHIN BASE OFFSET)))))])
STRING])
)
(LISP:DEFUN LISP:WRITE-STRING (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*)
&KEY
(START 0)
(END (LISP:LENGTH STRING)))
(* ; "Edited 6-May-92 13:23 by jrb:")
(WRITE-STRING* STRING (\GETSTREAM STREAM 'OUTPUT)
START END)
STRING)
(LISP:DEFUN LISP:WRITE-LINE (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*)
&KEY
(LISP::START 0)
LISP::END)
(SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
(LISP:UNLESS (EQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY)
(LISP::CHECK-READABLY STRING 'LISP:WRITE-LINE))
(COND
((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
(PROGN (XP::WRITE-STRING+ STRING STREAM LISP::START LISP::END)
(XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM)))
(T (WRITE-STRING* STRING STREAM LISP::START LISP::END)
(LISP:TERPRI STREAM)))
STRING)
(RPAQ? XCL:*PRINT-STRUCTURE* )
(LISP:DEFVAR LISP:*PRINT-READABLY* NIL)
(PUTPROPS CMLPRINT FILETYPE :FAKE-COMPILE-FILE)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA LISP:WRITE-TO-STRING LISP:PRINC LISP:PPRINT LISP:PRINT LISP:PRIN1 LISP:WRITE-CHAR
WRITE)
)
(PUTPROPS CMLPRINT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1992 1993))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1214 8835 (WRITE 1224 . 4704) (LISP:WRITE-CHAR 4706 . 5230) (LISP:PRIN1 5232 . 5413)
(LISP:PRINT 5415 . 6424) (LISP:TERPRI 6426 . 6882) (LISP:FRESH-LINE 6884 . 7373) (LISP:FINISH-OUTPUT
7375 . 7675) (LISP:FORCE-OUTPUT 7677 . 7974) (LISP:CLEAR-OUTPUT 7976 . 8342) (LISP:PPRINT 8344 . 8646)
(LISP:PRINC 8648 . 8833)) (9611 12737 (LISP:WRITE-TO-STRING 9621 . 11419) (LISP:PRIN1-TO-STRING 11421
. 12054) (LISP:PRINC-TO-STRING 12056 . 12735)) (12738 14726 (WRITE-STRING* 12748 . 14724)))))
STOP