(FILECREATED "14-Sep-85 08:14:23" {ERIS}<LISPCORE>SOURCES>COMMON.;28 32143Q
changes to: (FNS PRINT-LISP-INFORMATION MACHINE-INSTANCE)
previous date: "14-Sep-85 02:26:03" {ERIS}<LISPCORE>SOURCES>COMMON.;25)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT COMMONCOMS)
(RPAQQ COMMONCOMS [(COMS (* BQUOTE AND FRIENDS)
(FNS READVBAR DIGITBASEP READNUMBERINBASE READHASHMACRO
ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT READBQUOTE READBQUOTECOMMA)
(FNS BQUOTE \BQUOTE.EXPAND BQ.CONS BQ.PROGN \BQUOTE.SPLICE \BQUOTE.STANDARD
\UNCOMMA \BQUOTE.BREAKRESET)
[VARS \CML.READPREFIX (SIMPLERDTBL (COPYREADTABLE (QUOTE ORIG]
[DECLARE: DONTEVAL@LOAD DOCOPY (VARS (\INBQUOTE))
(ADDVARS (BREAKRESETFORMS (\BQUOTE.BREAKRESET)))
(P (MAPC (QUOTE (FILERDTBL T EDITRDTBL DEDITRDTBL))
(FUNCTION (LAMBDA
(RDTBL)
(COND
((BOUNDP RDTBL)
(SETSYNTAX (QUOTE %|)
(QUOTE (INFIX READVBAR))
(EVALV RDTBL))
(SELECTQ
RDTBL
((CODERDTBL FILERDTBL)
(* Don't set it loose on these yet))
(PROGN (SETSYNTAX (QUOTE `)
(QUOTE (MACRO FIRST
READBQUOTE))
(EVALV RDTBL))
(SETSYNTAX (QUOTE ,)
(QUOTE (MACRO FIRST
READBQUOTECOMMA))
(EVALV RDTBL]
(MACROS BQUOTE)
(VARS \CML.READPREFIX))
(COMS * CMLENVIRONMENTCOMS)
(COMS (* *FEATURES* used only by #+ #- reader, which is really disabled)
(ADDVARS (*FEATURES* INTERLISP)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML BQUOTE)
(LAMA PRINT-LISP-INFORMATION PRINT-LOADED-FILE-INFORMATION])
(* BQUOTE AND FRIENDS)
(DEFINEQ
(READVBAR
(LAMBDA (STREAM RDTBL TC) (* lmm " 1-Aug-85 09:43") (SELCHARQ (PEEKCCODE STREAM) (' (* commonlisp
defines "#'X" to mean (FUNCTION X) , but here its BQUOTE) (READCCODE STREAM) (TCONC TC (READBQUOTE
STREAM RDTBL))) ((%( { ↑) (TCONC TC (HREAD STREAM))) (# (READCCODE STREAM) (TCONC TC (READHASHMACRO
STREAM RDTBL))) ((EOL TAB SPACE) (* CR or tab, treat as separator) TC) (TCONC TC (READHASHMACRO STREAM
RDTBL)))))
(DIGITBASEP
(LAMBDA (CODE RADIX) (* lmm "11-Jun-85 00:54") (if (AND (GEQ CODE (CHARCODE 0)) (LESSP CODE (PLUS (
CHARCODE 0) RADIX))) then (DIFFERENCE CODE (CHARCODE 0)) elseif (GREATERP RADIX 10) then (if (AND (GEQ
CODE (CHARCODE a)) (LEQ CODE (CHARCODE z))) then (add CODE (DIFFERENCE (CHARCODE A) (CHARCODE a)))) (
if (AND (GEQ CODE (CHARCODE A)) (LEQ CODE (CHARCODE Z))) then (SETQ CODE (PLUS 10 (DIFFERENCE CODE (
CHARCODE A)))) (if (LESSP CODE RADIX) then CODE)))))
(READNUMBERINBASE
(LAMBDA (STREAM RADIX) (* lmm " 8-Jul-85 13:56") (bind (VAL ← 0) BASE while (SETQ BASE (DIGITBASEP (
PEEKCCODE STREAM) RADIX)) do (READCCODE STREAM) (SETQ VAL (PLUS (TIMES VAL RADIX) BASE)) finally (
RETURN VAL))))
(READHASHMACRO
(LAMBDA (STREAM RDTBL INDEX) (* raf "14-Sep-85 00:14") (LET ((NEXTCHAR (PEEKCCODE STREAM)) READVAL) (
while (DIGITCHARP NEXTCHAR) do (SETQ INDEX (PLUS (TIMES (OR INDEX 0) 10) (DIFFERENCE NEXTCHAR (
CHARCODE 0)))) (READCCODE STREAM RDTBL) (SETQ NEXTCHAR (PEEKCCODE STREAM RDTBL))) (SELCHARQ NEXTCHAR (
' (READCCODE STREAM RDTBL) (LIST (QUOTE FUNCTION) (READ STREAM RDTBL))) (%. (READCCODE STREAM RDTBL) (
EVAL (READ STREAM RDTBL))) (, (READCCODE STREAM RDTBL) (LIST (QUOTE LOADTIMECONSTANT) (READ STREAM
RDTBL))) (\ (INT-CHAR (CHARCODE.DECODE (READ STREAM CMLRDTBL)))) ("*" (READCCODE STREAM RDTBL) (LET ((
CONTENTS (for (C ← (READCCODE STREAM RDTBL)) by (READCCODE STREAM RDTBL) until (NOT (MEMQ C (CONSTANT
(LIST (CHARCODE 0) (CHARCODE 1))))) collect (IDIFFERENCE C (CONSTANT (CHARCODE 0)))))) (if INDEX then
(FILL.VECTOR (MAKE-ARRAY INDEX :ELEMENT-TYPE (QUOTE BIT)) CONTENTS) else (MAKE-ARRAY (LENGTH CONTENTS)
:INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE (QUOTE BIT))))) ("(" (LET ((CONTENTS (READ STREAM RDTBL))) (
if INDEX then (FILL.VECTOR (MAKE-ARRAY INDEX) CONTENTS) else (MAKE-ARRAY (LENGTH CONTENTS)
:INITIAL-CONTENTS CONTENTS)))) (":" (READCCODE STREAM RDTBL) (RSTRING STREAM RDTBL)) ((O o) (READCCODE
STREAM RDTBL) (READNUMBERINBASE STREAM 8)) ((B b) (READCCODE STREAM RDTBL) (READNUMBERINBASE STREAM 2
)) ((X x) (READCCODE STREAM RDTBL) (READNUMBERINBASE STREAM 16)) ((R r) (READCCODE STREAM RDTBL) (
READNUMBERINBASE STREAM INDEX)) ((A a) (READCCODE STREAM RDTBL) (LET ((CONTENTS (READ STREAM RDTBL)))
(MAKE-ARRAY (ESTIMATE-DIMENSIONALITY INDEX CONTENTS) :INITIAL-CONTENTS CONTENTS))) ((S s) (READCCODE
STREAM RDTBL) (CREATE-STRUCTURE (READ STREAM RDTBL))) (+ (READCCODE STREAM RDTBL) (if (MEMBER (READ
STREAM SIMPLERDTBL) *FEATURES*) then (READ STREAM RDTBL) else (SKREAD STREAM RDTBL) (READ STREAM
SIMPLERDTBL))) (- (READCCODE STREAM RDTBL) (if (NOT (MEMBER (READ STREAM SIMPLERDTBL) *FEATURES*))
then (READ STREAM RDTBL) else (SKREAD STREAM RDTBL) (READ STREAM SIMPLERDTBL))) ("|" (READCCODE STREAM
RDTBL) (* special comment) (SKIP.HASH.COMMENT STREAM RDTBL) (READ STREAM RDTBL)) (< (READ<)) ((SPACE
TAB NEWLINE PAGE RETURN RIGHTPAREN) (READCCODE STREAM RDTBL) (ERROR "Illegal read syntax " (
CHARCODE.UNDECODE NEXTCHAR))) (PROGN (READCCODE STREAM RDTBL) (APPLY* (OR (GETPROP (CHARACTER NEXTCHAR
) (QUOTE HASHREADMACRO)) (ERROR "UNDEFINED HASHMACRO CHAR" NEXTCHAR)) STREAM RDTBL))))))
(ESTIMATE-DIMENSIONALITY
(LAMBDA (RANK CONTENTS) (* raf "14-Sep-85 02:18") (if (NULL RANK) then (ERROR
"No rank found while reading array" NIL) elseif (EQ RANK 0) then NIL else (for I to RANK as D in
CONTENTS by (CAR D) collect (LENGTH D)))))
(SKIP.HASH.COMMENT
(LAMBDA (STREAM RDTBL) (* lmm " 5-Jul-85 12:44") (do (SELCHARQ (READCCODE STREAM RDTBL) (# (if (EQ (
PEEKCCODE STREAM RDTBL) (CHARCODE "|")) then (READCCODE STREAM RDTBL) (SKIP.HASH.COMMENT STREAM RDTBL)
)) ("|" (if (EQ (PEEKCCODE STREAM RDTBL) (CHARCODE "#")) then (READCCODE STREAM RDTBL) (RETURN))) NIL)
)))
(READBQUOTE
(LAMBDA (FILE RDTBL) (* bvm: " 6-Jul-85 23:19") (SELECTQ (PROGN (SKIPSEPRS FILE RDTBL) (GETSYNTAX (
PEEKCCODE FILE) RDTBL)) ((RIGHTPAREN RIGHTBRACKET) (* Shouldn't have to test this, since such a quote
is required to be escaped. This test is merely a nicety for type-in) (QUOTE `)) (LET ((\INBQUOTE T)) (
DECLARE (SPECVARS \INBQUOTE)) (LIST (QUOTE BQUOTE) (READ FILE RDTBL))))))
(READBQUOTECOMMA
(LAMBDA (FILE RDTBL) (DECLARE (USEDFREE \INBQUOTE)) (* bvm: " 6-Jul-85 23:19") (COND (\INBQUOTE (*
Valid context for comma) (SELECTQ (SKIPSEPRS FILE RDTBL) ((@ %.) (READC FILE) (LIST (QUOTE \,@) (READ
FILE RDTBL))) (LIST (QUOTE \,) (READ FILE RDTBL)))) (T (* Comma outside of backquote context is
"an error" ; however, it would be nice if we treat it as though it had been escaped) (LET ((CH (
PEEKCCODE FILE))) (COND ((OR (SYNTAXP CH (QUOTE BREAK) RDTBL) (SYNTAXP CH (QUOTE SEPR) RDTBL)) (QUOTE
,)) (T (PACK* (QUOTE ,) (READ FILE RDTBL)))))))))
)
(DEFINEQ
(BQUOTE
(NLAMBDA (FORM.WITH.COMMAS) (DECLARE (LOCALVARS . T)) (* lmm " 1-Jul-85 12:29") (EVAL (\BQUOTE.EXPAND
(\UNCOMMA FORM.WITH.COMMAS) 1))))
(\BQUOTE.EXPAND
(LAMBDA (EXPR LEVEL) (* lmm " 9-Jul-85 12:29") (* Backquote expanding function *) (COND ((ILESSP LEVEL
0) (* Perhaps the user hand constructed a malformed backquoted form. *) (ERROR "Too many commas" EXPR
)) ((ZEROP LEVEL) (COND ((LISTP EXPR) (SELECTQ (CAR EXPR) (BQUOTE (\BQUOTE.EXPAND (CADR EXPR) 1)) (
CONS (\BQUOTE.EXPAND (CAR EXPR) 0) (\BQUOTE.EXPAND (CDR EXPR) 0)))) (T EXPR))) ((EQ LEVEL 1) (COND ((
LISTP EXPR) (SELECTQ (CAR EXPR) (\, (CADR EXPR)) (\,@ (ERROR ",@ in illegal context" EXPR)) (\., (
ERROR ". , in illegal context" EXPR)) (BQUOTE (\BQUOTE.STANDARD EXPR 2)) (COND ((AND (LISTP (CAR EXPR)
) (MEMB (CAAR EXPR) (QUOTE (\,@ \.,)))) (\BQUOTE.SPLICE EXPR)) (T (\BQUOTE.STANDARD EXPR 1))))) (T (
KWOTE EXPR)))) (T (* LEVEL > 1.0 *) (COND ((LISTP EXPR) (SELECTQ (CAR EXPR) ((\, \,@ \.,) (
\BQUOTE.STANDARD EXPR (SUB1 LEVEL))) (BQUOTE (\BQUOTE.STANDARD EXPR (ADD1 LEVEL))) (\BQUOTE.STANDARD
EXPR LEVEL))) (T (KWOTE EXPR)))))))
(BQ.CONS
(LAMBDA (XA XD) (* lmm "31-AUG-83 21:58") (SELECTQ (CAR (LISTP XD)) ((CONS LIST*) (LIST* (QUOTE LIST*)
XA (CDR XD))) (LIST (LIST* (QUOTE LIST) XA (CDR XD))) (COND (XD (LIST (QUOTE CONS) XA XD)) (T (LIST (
QUOTE LIST) XA))))))
(BQ.PROGN
(LAMBDA (L) (* lmm "31-AUG-83 22:21") (COND ((CDR L) (CONS (QUOTE PROGN) L)) (T (CAR L)))))
(\BQUOTE.SPLICE
(LAMBDA (SEX) (* lmm "14-Jun-85 14:26") (* Splice-in cases. ",@" uses NCONC & ",." uses APPEND. *) (
PROG (A A1 A2 D FN ANSWER) (SETQ A (CAR SEX)) (SETQ A1 (CAR A)) (SETQ A2 (CADR A)) (SETQ D (CDR SEX))
(SETQ D (\BQUOTE.EXPAND D 1)) (COND ((EQUAL D (QUOTE (QUOTE NIL))) (* (NCONC X (QUOTE NIL)) => X *) (
SETQ ANSWER A2)) (T (COND ((EQ A1 (QUOTE \,@)) (SETQ FN (QUOTE APPEND))) (T (* \DOTCOMMA => Safe for
us to NCONC. *) (SETQ FN (QUOTE NCONC)))) (COND ((AND (LISTP D) (EQ (CAR D) FN)) (* (NCONC X (NCONC .
Y)) => (NCONC X . Y) *) (SETQ ANSWER (CONS FN (CONS A2 (CDR D))))) (T (SETQ ANSWER (LIST FN A2 D))))))
(RETURN ANSWER))))
(\BQUOTE.STANDARD
(LAMBDA (EXPR LEVEL) (* lmm "14-Jun-85 14:17") (* Standard case. *) (LET ((BCAR (\BQUOTE.EXPAND (CAR
EXPR) LEVEL)) (BCDR (\BQUOTE.EXPAND (CDR EXPR) LEVEL)) AV DV) (COND ((AND (SETQ AV (
CONSTANTEXPRESSIONP BCAR)) (SETQ DV (CONSTANTEXPRESSIONP BCDR))) (LIST (QUOTE QUOTE) (CONS (CAR AV) (
CAR DV)))) (T (BQ.CONS BCAR BCDR))))))
(\UNCOMMA
(LAMBDA (X) (* lmm "14-Jun-85 14:21") (* This function does the expansion of a BQUOTEd form.) (COND ((
NLISTP X) X) (T (SELECTQ (CAR X) (, (LET ((TAIL (\UNCOMMA (CDR X)))) (CONS (LIST (QUOTE \,) (CAR TAIL)
) (CDR TAIL)))) ((,. ., ,@ ,!) (LET ((TAIL (\UNCOMMA (CDR X)))) (CONS (LIST (QUOTE \,@) (CAR TAIL)) (
CDR TAIL)))) (LET ((BCAR (\UNCOMMA (CAR X))) (BCDR (\UNCOMMA (CDR X)))) (COND ((AND (EQ BCAR (CAR X))
(EQ BCDR (CDR X))) X) (T (CONS BCAR BCDR)))))))))
(\BQUOTE.BREAKRESET
(LAMBDA (FLG) (* bvm: " 6-Jul-85 23:19") (PROG1 \INBQUOTE (SETQ \INBQUOTE FLG))))
)
(RPAQQ \CML.READPREFIX "|")
(RPAQ SIMPLERDTBL (COPYREADTABLE (QUOTE ORIG)))
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ \INBQUOTE NIL)
(ADDTOVAR BREAKRESETFORMS (\BQUOTE.BREAKRESET))
[MAPC (QUOTE (FILERDTBL T EDITRDTBL DEDITRDTBL))
(FUNCTION (LAMBDA (RDTBL)
(COND ((BOUNDP RDTBL)
(SETSYNTAX (QUOTE %|)
(QUOTE (INFIX READVBAR))
(EVALV RDTBL))
(SELECTQ RDTBL ((CODERDTBL FILERDTBL)
(* Don't set it loose on these yet))
(PROGN (SETSYNTAX (QUOTE `)
(QUOTE (MACRO FIRST READBQUOTE))
(EVALV RDTBL))
(SETSYNTAX (QUOTE ,)
(QUOTE (MACRO FIRST READBQUOTECOMMA))
(EVALV RDTBL]
)
(DECLARE: EVAL@COMPILE
(PUTPROPS BQUOTE MACRO (FORM (\BQUOTE.EXPAND (\UNCOMMA (CAR FORM))
1)))
)
(RPAQQ \CML.READPREFIX "|")
(RPAQQ CMLENVIRONMENTCOMS ((FNS LISP-IMPLEMENTATION-TYPE LISP-IMPLEMENTATION-VERSION MACHINE-INSTANCE
MACHINE-VERSION PRINT-LOADED-FILE-INFORMATION SOFTWARE-TYPE
SOFTWARE-VERSION PRINT-LISP-INFORMATION MACHINE-TYPE)
(FNS SHORT-SITE-NAME LONG-SITE-NAME)))
(DEFINEQ
(LISP-IMPLEMENTATION-TYPE
(LAMBDA NIL "Interlisp-D"))
(LISP-IMPLEMENTATION-VERSION
(LAMBDA NIL (CONCAT MAKESYSNAME " of " MAKESYSDATE)))
(MACHINE-INSTANCE
[LAMBDA NIL (* DECLARATIONS: (TYPERECORD NSHOSTNUMBER
(A B C)))
(* lmm "14-Sep-85 07:39")
(MKSTRING (with NSHOSTNUMBER \MY.NSHOSTNUMBER (PLUS (LSH A 40Q)
(LSH B 20Q)
C])
(MACHINE-VERSION
(LAMBDA NIL (* lmm " 6-Sep-85 16:37") (CONCAT "microcode " (MICROCODEVERSION) ", " (REALMEMORYSIZE)
" pages")))
(PRINT-LOADED-FILE-INFORMATION
(CL:LAMBDA (FILE &OPTIONAL (STRING "PATCH")) (* lmm " 6-Sep-85 16:01") (for X in LOADEDFILELST when (
STRPOS STRING X) do (PRINTOUT FILE (NAMEFIELD X) " dated " (CAAR (GETPROP (NAMEFIELD X) (QUOTE
FILEDATES))) T))))
(SOFTWARE-TYPE
(LAMBDA NIL "Interlisp-D"))
(SOFTWARE-VERSION
(LAMBDA NIL (* lmm " 6-Sep-85 16:39") (CAR MAKEINITDATES)))
(PRINT-LISP-INFORMATION
(CL:LAMBDA (&OPTIONAL (FILE T)
(STRING "PATCH")) (* lmm "14-Sep-85 07:40")
(PRINTOUT FILE (LISP-IMPLEMENTATION-TYPE)
" version "
(LISP-IMPLEMENTATION-VERSION)
" on "
(MACHINE-TYPE)
", "
(MACHINE-VERSION)
", " "machine " (MACHINE-INSTANCE)
" based on "
(SOFTWARE-TYPE)
" version "
(SOFTWARE-VERSION)
T "Patch files: " # (PRINT-LOADED-FILE-INFORMATION FILE STRING))))
(MACHINE-TYPE
(LAMBDA NIL (LET ((MT (MACHINETYPE))) (SELECTQ MT (DANDELION "1108") (DORADO "1132") (DOVE "1186") MT)
)))
)
(DEFINEQ
(SHORT-SITE-NAME
(LAMBDA NIL (* lmm " 6-Sep-85 16:41") (OR (ETHERHOSTNAME) "unknown")))
(LONG-SITE-NAME
(LAMBDA NIL (SHORT-SITE-NAME)))
)
(* *FEATURES* used only by #+ #- reader, which is really disabled)
(ADDTOVAR *FEATURES* INTERLISP)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML BQUOTE)
(ADDTOVAR LAMA PRINT-LISP-INFORMATION PRINT-LOADED-FILE-INFORMATION)
)
(PUTPROPS COMMON COPYRIGHT ("Xerox Corporation" 3701Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3502Q 15526Q (READVBAR 3514Q . 4370Q) (DIGITBASEP 4372Q . 5325Q) (READNUMBERINBASE
5327Q . 5703Q) (READHASHMACRO 5705Q . 12502Q) (ESTIMATE-DIMENSIONALITY 12504Q . 13074Q) (
SKIP.HASH.COMMENT 13076Q . 13613Q) (READBQUOTE 13615Q . 14430Q) (READBQUOTECOMMA 14432Q . 15524Q)) (
15527Q 23512Q (BQUOTE 15541Q . 15765Q) (\BQUOTE.EXPAND 15767Q . 17667Q) (BQ.CONS 17671Q . 20250Q) (
BQ.PROGN 20252Q . 20423Q) (\BQUOTE.SPLICE 20425Q . 21642Q) (\BQUOTE.STANDARD 21644Q . 22401Q) (
\UNCOMMA 22403Q . 23335Q) (\BQUOTE.BREAKRESET 23337Q . 23510Q)) (25633Q 31112Q (
LISP-IMPLEMENTATION-TYPE 25645Q . 25736Q) (LISP-IMPLEMENTATION-VERSION 25740Q . 26066Q) (
MACHINE-INSTANCE 26070Q . 26644Q) (MACHINE-VERSION 26646Q . 27053Q) (PRINT-LOADED-FILE-INFORMATION
27055Q . 27450Q) (SOFTWARE-TYPE 27452Q . 27530Q) (SOFTWARE-VERSION 27532Q . 27653Q) (
PRINT-LISP-INFORMATION 27655Q . 30712Q) (MACHINE-TYPE 30714Q . 31110Q)) (31113Q 31347Q (
SHORT-SITE-NAME 31125Q . 31260Q) (LONG-SITE-NAME 31262Q . 31345Q)))))
STOP