(FILECREATED "21-Mar-86 11:22:38" {GENIE}LISP:<LISPLIBRARY.KOTO>CMLREADER.;44 56009
changes to: (VARS CMLREADERCOMS)
(ALISTS (PRETTYPRINTMACROS QUOTE)
(PRETTYPRINTMACROS BQUOTE)
(PRETTYPRINTMACROS \,@)
(PRETTYPRINTMACROS \,))
previous date: " 3-Mar-86 17:00:05" {GENIE}LISP:<LISPLIBRARY.KOTO>CMLREADER.;43)
(* Copyright (c) 1986 by public domain. All rights reserved.)
(PRETTYCOMPRINT CMLREADERCOMS)
(RPAQQ CMLREADERCOMS ((E (* * Extension to the Interlisp Reader for CommonLisp.))
(FILEDESCRIPTION CMLREADER)
(LOCALVARS . T)
(FILEPKGCOMS CONSTANTS DEFSETF FNS TYPES VARS INITVARS)
(PROP PROPTYPE SETFN)
(PROP (PRINT-TO-FILE COMPILE.FILE.EXPRESSION)
DEFSETF)
(ALISTS (PRETTYPRINTMACROS QUOTE BQUOTE \,@ \, * FUNCTION))
(INITVARS (*INTERLISP-READTABLE* (GETREADTABLE T))
(*READTABLE* (AND (BOUNDP 'CMLRDTBL)
(READTABLEP CMLRDTBL)))
(*PRINT-PRETTY* T)
(*TERMINAL-IO* T)
(*STANDARD-INPUT* T)
(*COMMON-LISP-FILE-FLAG* NIL)
(*COMMON-LISP-COMMENT-FLAG* NIL)
(*COMMON-LISP-DEFUN-FLAG* NIL)
(\READ.SEMICOLON-TO-INTERLISP-COMMENT-SCRATCH-STRING " "))
(GLOBALVARS *INTERLISP-READTABLE* *READTABLE* *TERMINAL-IO* *STANDARD-INPUT*
*COMMON-LISP-FILE-FLAG* *COMMON-LISP-COMMENT-FLAG* *COMMON-LISP-DEFUN-FLAG*
*PRINT-PRETTY* \READ.SEMICOLON-TO-INTERLISP-COMMENT-SCRATCH-STRING)
(ADDVARS (CMLTRANSLATIONS (prin1 . CL:PRIN1)
(read . CL:READ)))
(CONSTANTS (BRACKET-READ-MACRO-PROP '%[-DISPATCH-PROPERTY)
(DISPATCH-MACRO-PROPERTY 'DISPATCH-MACRO-HASHARRAY))
(MACROS CL:PRIN1 CL:READ CLEAR-INPUT LISTEN PEEK-CHAR PRINC READ-BYTE READ-CHAR
READ-CHAR-NO-HANG READ-FROM-STRING READ-LINE)
(FNS .CHECK.BEFORE.READBQUOTE CL:READ CMLTTYINREAD COMPILE.FILE.DEFSETF
COMS.COMS-FNSCOMMENT COMS.COMS-VARS COMS.PRINT-CONSTANTS COMS.PRINT-DEFSETF
COMS.PRINT-FNS COMS.PRINT-INITVARS COMS.PRINT-TYPES DEFSETF.GETDEF DEFSETF.HASDEF
FNS.FILEGETDEF GET-DISPATCH-MACRO-CHARACTER PEEK-CHAR PRETTYPRINTMACROS.#QUOTE
PRETTYPRINTMACROS.* PRETTYPRINTMACROS.QUOTE PRINT.SEMICOLON-COMMENT
PRINT.SEMICOLON-COMMENT1A PRINT.SEMICOLON-COMMENT1B QUOTESETUP READ#QUOTE READ#<
READ#PLUS-OR-MINUS READ#VBAR READ-CHAR READ-DELIMITED-LIST READ-FROM-STRING
READ-LINE READ.SEMICOLON-TO-INTERLISP-COMMENT READ.SEMICOLON-ZAP-LINE
SET-DISPATCH-MACRO-CHARACTER UNREAD-CHAR USER-READ-HASH-MACRO)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (QUOTESETUP (BOUNDP 'TEXTINDEXMARKER))
(COND ((MOVD? 'READHASHMACRO 'OLD.READHASHMACRO)
(MOVD 'USER-READ-HASH-MACRO 'READHASHMACRO)))
(COND ((GETD 'SET-DISPATCH-MACRO-CHARACTER)
(SET-DISPATCH-MACRO-CHARACTER
(CHARCODE "#")
(CHARCODE "'")
(FUNCTION READ#QUOTE)
(GETREADTABLE T))
(SET-DISPATCH-MACRO-CHARACTER
(CHARCODE "#")
(CHARCODE "'")
(FUNCTION READ#QUOTE)
EDITRDTBL)
(SET-DISPATCH-MACRO-CHARACTER
(CHARCODE "#")
(CHARCODE "'")
(FUNCTION READ#QUOTE)
FILERDTBL)
(SET-DISPATCH-MACRO-CHARACTER
(CHARCODE "#")
(CHARCODE "'")
(FUNCTION READ#QUOTE)
*READTABLE*)
(SET-DISPATCH-MACRO-CHARACTER
(CHARCODE "#")
(CHARCODE "+")
(FUNCTION READ#PLUS-OR-MINUS)
FILERDTBL)
(SET-DISPATCH-MACRO-CHARACTER
(CHARCODE "#")
(CHARCODE "+")
(FUNCTION READ#PLUS-OR-MINUS)
*READTABLE*)
(SET-DISPATCH-MACRO-CHARACTER
(CHARCODE "#")
(CHARCODE "-")
(FUNCTION READ#PLUS-OR-MINUS)
FILERDTBL)
(SET-DISPATCH-MACRO-CHARACTER
(CHARCODE "#")
(CHARCODE "-")
(FUNCTION READ#PLUS-OR-MINUS)
*READTABLE*)
(SET-DISPATCH-MACRO-CHARACTER
(CHARCODE "#")
(CHARCODE "|")
(FUNCTION READ#VBAR)
FILERDTBL)
(SET-DISPATCH-MACRO-CHARACTER
(CHARCODE "#")
(CHARCODE "|")
(FUNCTION READ#VBAR)
*READTABLE*)))
(MOVD? 'TTYINREAD 'OLDTTYINREAD)
(MOVD? 'READ#< 'READ<)
(AND (GETD 'OLDTTYINREAD)
(MOVD 'CMLTTYINREAD 'TTYINREAD))))
(XREF CMLREADER)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA UNREAD-CHAR READ-LINE READ-FROM-STRING READ-CHAR PEEK-CHAR
CL:READ)))))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTDEF (QUOTE CONSTANTS) (QUOTE FILEPKGCOMS) '((COM MACRO
(X (DECLARE: EVAL@COMPILE
(E (COMS.PRINT-CONSTANTS
'X)))))))
(PUTDEF (QUOTE DEFSETF) (QUOTE FILEPKGCOMS) '((COM MACRO (X (E (COMS.PRINT-DEFSETF 'X))))
(TYPE DESCRIPTION "DEFSETF definitions" GETDEF
DEFSETF.GETDEF HASDEF DEFSETF.HASDEF EDITDEF
NILL)))
(PUTDEF (QUOTE FNS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (E (COMS.PRINT-FNS 'X))
(COMS * (COMS.COMS-FNSCOMMENT
'X)))
CONTENTS NILL)
(TYPE DESCRIPTION "functions" PUTDEF FNS.PUTDEF
CANFILEDEF T)))
(PUTDEF (QUOTE TYPES) (QUOTE FILEPKGCOMS) '((COM MACRO (X (E (COMS.PRINT-TYPES 'X))))
(TYPE DESCRIPTION "type specifiers" GETDEF
TYPES.GETDEF)))
(PUTDEF (QUOTE VARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (COMS * (COMS.COMS-VARS 'X)))
CONTENTS NILL)
(TYPE DESCRIPTION "variables" NULLDEF NOBIND PUTDEF
VARS.PUTDEF)))
(PUTDEF (QUOTE INITVARS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (E (COMS.PRINT-INITVARS
'X)))
CONTENTS NILL)))
(PUTPROPS SETFN PROPTYPE DEFSETF)
(PUTPROPS DEFSETF PRINT-TO-FILE PRINT.DEFUN)
(PUTPROPS DEFSETF COMPILE.FILE.EXPRESSION COMPILE.FILE.DEFSETF)
(ADDTOVAR PRETTYPRINTMACROS (QUOTE . PRINTQUOTE)
(BQUOTE . PRINTQUOTE)
(\,@ . PRINTQUOTE)
(\, . PRINTQUOTE)
(* . PRETTYPRINTMACROS.*)
(FUNCTION . PRETTYPRINTMACROS.#QUOTE))
(RPAQ? *INTERLISP-READTABLE* (GETREADTABLE T))
(RPAQ? *READTABLE* (AND (BOUNDP 'CMLRDTBL)
(READTABLEP CMLRDTBL)))
(RPAQ? *PRINT-PRETTY* T)
(RPAQ? *TERMINAL-IO* T)
(RPAQ? *STANDARD-INPUT* T)
(RPAQ? *COMMON-LISP-FILE-FLAG* NIL)
(RPAQ? *COMMON-LISP-COMMENT-FLAG* NIL)
(RPAQ? *COMMON-LISP-DEFUN-FLAG* NIL)
(RPAQ? \READ.SEMICOLON-TO-INTERLISP-COMMENT-SCRATCH-STRING " ")
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *INTERLISP-READTABLE* *READTABLE* *TERMINAL-IO* *STANDARD-INPUT*
*COMMON-LISP-FILE-FLAG* *COMMON-LISP-COMMENT-FLAG* *COMMON-LISP-DEFUN-FLAG*
*PRINT-PRETTY* \READ.SEMICOLON-TO-INTERLISP-COMMENT-SCRATCH-STRING)
)
(ADDTOVAR CMLTRANSLATIONS (prin1 . CL:PRIN1)
(read . CL:READ))
(DECLARE: EVAL@COMPILE
(CONSTANTS BRACKET-READ-MACRO-PROP DISPATCH-MACRO-PROPERTY)
(RPAQQ BRACKET-READ-MACRO-PROP %[-DISPATCH-PROPERTY)
(RPAQQ DISPATCH-MACRO-PROPERTY DISPATCH-MACRO-HASHARRAY)
)
(DECLARE: EVAL@COMPILE
(DEFMACRO CL:PRIN1 (OBJECT &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*))
"CommonLisp function PRIN1."
`(PRIN2 ,OBJECT ,OUTPUT-STREAM))
(DEFMACRO CL:READ (&OPTIONAL (INPUT-STREAM '*TERMINAL-IO*)
&KEY
(READ-TABLE '*READTABLE*))
"CommonLisp READ function."
`(READ ,INPUT-STREAM ,READ-TABLE T))
(DEFMACRO CLEAR-INPUT (&OPTIONAL (INPUT-STREAM '*TERMINAL-IO*))
"CommonLisp CLEAR-INPUT function."
`(CLEARBUF ,INPUT-STREAM))
(DEFMACRO LISTEN (&OPTIONAL (INPUT-STREAM '*TERMINAL-IO*))
"CommonLisp function LISTEN."
`(READP ,INPUT-STREAM T))
(DEFMACRO PEEK-CHAR (&OPTIONAL PEEK-TYPE (INPUT-STREAM '*TERMINAL-IO*)
&KEY
(READ-TABLE '*READTABLE*))
"CommonLisp function PEEK-CHAR."
(COND (PEEK-TYPE `(COND (,PEEK-TYPE (CLEARBUF ,INPUT-STREAM T)
(LET ((LIN-BUFFER (LINBUF T))
(SYS-BUFFER (SYSBUF T))
CH)
(LINBUF)
(SYSBUF)
(COND (LIN-BUFFER (SETQ CH
(SKIPSEPRS
(SUBSTRING
LIN-BUFFER 1)
,READ-TABLE)))
(SYS-BUFFER (SETQ CH
(SKIPSEPRS
(SUBSTRING
SYS-BUFFER 1)
,READ-TABLE))))
(BKLINBUF LIN-BUFFER)
(BKSYSBUF SYS-BUFFER)
(NAME-CHAR CH)))
(T (CODE-CHAR (PEEKCCODE ,INPUT-STREAM)))))
(T `(CODE-CHAR (PEEKCCODE ,INPUT-STREAM)))))
(DEFMACRO PRINC (OBJECT &OPTIONAL (OUTPUT-STREAM '*STANDARD-OUTPUT*))
"CommonLisp function PRINC."
`(PRIN1 ,OBJECT ,OUTPUT-STREAM))
(DEFMACRO READ-BYTE (&OPTIONAL (BINARY-INPUT-STREAM '*TERMINAL-IO*))
"CommonLisp function READ-BYTE for reading a Byte."
`(BIN ,BINARY-INPUT-STREAM))
(DEFMACRO READ-CHAR (&OPTIONAL (INPUT-STREAM '*TERMINAL-IO*)
&KEY
(READ-TABLE '*READTABLE*))
"CommonLisp function READ-CHAR."
`(CODE-CHAR (READCCODE ,INPUT-STREAM ,READ-TABLE)))
(DEFMACRO READ-CHAR-NO-HANG (&OPTIONAL (INPUT-STREAM '*TERMINAL-IO*)
&KEY
(READ-TABLE '*READTABLE*))
`(AND (LISTEN ,INPUT-STREAM)
(READ-CHAR ,INPUT-STREAM ,READ-TABLE)))
(DEFMACRO READ-FROM-STRING (STRING &KEY (START 1)
END
(READ-TABLE '*READTABLE*))
"CommonLisp READ-FROM-STRING function."
`(READ (SUBSTRING (THE STRING ,STRING)
(ADD1 ,START)
,END)
,READ-TABLE T))
(DEFMACRO READ-LINE (&OPTIONAL (INPUT-STREAM '*TERMINAL-IO*)
EOF-ERROR-P EOF-VALUE &KEY (READ-TABLE '*READTABLE*))
"CommonLisp function READ-LINE."
`(CL:DO ((CH (READCCODE ,INPUT-STREAM ,READ-TABLE)
(READCCODE ,INPUT-STREAM ,READ-TABLE))
(EOLCHARS (GETSYNTAX 'EOL))
(LINE "" (CONCAT LINE (CHARACTER CH))))
((FMEMB CH EOLCHARS)
LINE)
(AND (NOT ,EOF-ERROR-P)
(EOFP ,INPUT-STREAM)
(RETURN EOF-VALUE))))
)
(DEFINEQ
(.CHECK.BEFORE.READBQUOTE
(LAMBDA (FILE RDTBL) (* tlm: "16-Jan-86 14:30")
(* * Reader check function for in case there is a file with the back-quote character used as a
normal character)
(COND
((EQ (CHCON1 (PEEKC FILE))
(CHARCODE "`"))
(RESETLST (RESETSAVE (READMACROS NIL RDTBL)
(BQUOTE (READMACROS T (\, RDTBL))))
(PROG (ATM CHAR)
(SETQ ATM (PACK* "`" (READ FILE RDTBL)))
(SETQ CHAR (CHCON1 (PEEKC FILE)))
(OR (EOFP FILE)
(SYNTAXP CHAR (QUOTE BREAK)
RDTBL)
(SYNTAXP CHAR (QUOTE SEPR)
RDTBL)
(SETQ ATM (PACK* ATM (READ FILE RDTBL))))
(RETURN ATM)))))))
(CL:READ
(CL:LAMBDA (&OPTIONAL (INPUT-STREAM *TERMINAL-IO*)
&KEY
(READ-TABLE *READTABLE*)) (* tlm: "31-Jan-86 08:17")
(* * CommonLisp READ function.)
(* * INPUT-STREAM -
Input stream to read. By default use the *TERMINAL-IO* stream.)
(* * READ-TABLE -
Read table to use for the read. By default the CMLRDTBL read table is used.)
(* * operation -
Use the standard Interlisp read function with by default the cmlrdtbl read table and the flg
set to T.)
(* * value -
A lisp object.)
(READ INPUT-STREAM READ-TABLE T)))
(CMLTTYINREAD
(LAMBDA (FILE RDTBL) (* tlm: "17-Feb-86 17:24")
(* * Redefinition of the TTYINREAD function.)
(COND
((EQ LISPXID CMLPROMPT) (* use the CommonLisp default readtable
*READTABLE* if we are under CML.)
(CMLTRANSLATE (OLDTTYINREAD FILE *READTABLE*)))
(T (* Otherwise use the old version of TTYREAD.)
(OLDTTYINREAD FILE RDTBL)))))
(COMPILE.FILE.DEFSETF
(LAMBDA (FORM LCFIL RDTBL) (* tlm: "10-Feb-86 12:21")
(PRINT (BQUOTE (PUTPROPS (\, (CADR FORM))
SETFN
(\,@ (CDDR FORM))))
LCFIL RDTBL)))
(COMS.COMS-FNSCOMMENT
(LAMBDA (FNLST) (* tlm: " 6-Feb-86 14:59")
(* * Create a list of file package commands to print the comments for the function in FNSLST
and for saving lambda lists. The top-level comments for functions are ordinarily used to
explain what has changed in a function from its previous versions.)
(* * FNLST -
a list of function names. The functions to be saved in a file.)
(* * operation -
Print the functions comments and if there is a lambdalist then return it as a coms command to
be executed.)
(* * value -
a list of file package commands for saving any comments or lambda list associated with the
function.)
(PROG (HEADFLG VAL ARGS LLFLG)
(AND
(FUNCTIONP (QUOTE HASTLCMNTS))
(PROGN (SETQ VAL
(MAPCONC
FNLST
(FUNCTION (LAMBDA (FN)
(AND (LISTP (HASTLCMNTS FN (QUOTE FNS)))
(COND
((NULL HEADFLG)
(SETQ HEADFLG T)
(BQUOTE ((P ((\, COMMENTFLG))
((\, COMMENTFLG)
"Descriptions of recent changes to the above functions.")
((\, COMMENTFLG)))
(E (SHOWTLCMNTS (QUOTE (\, FN))
(QUOTE FNS)
NIL)))))
(T (BQUOTE ((E (SHOWTLCMNTS (QUOTE (\, FN))
(QUOTE FNS)
NIL)))))))))))
(AND VAL (NCONC1 VAL (BQUOTE (P ((\, COMMENTFLG))
((\, COMMENTFLG)
"----- end of function comments -----")
((\, COMMENTFLG))))))))
(PROGN (AND (FUNCTIONP (QUOTE LLARGLIST))
(MAPC FNLST (FUNCTION (LAMBDA (FN)
(AND (EXPRP FN)
(SETQ ARGS (LLARGLIST FN))
(PUTPROP FN (QUOTE LAMBDALIST)
ARGS)
(SETQ LLFLG T))))))
(AND LLFLG (SETQ VAL (NCONC1 VAL (BQUOTE
(DECLARE: DONTEVAL@LOAD
(IFPROP LAMBDALIST
(\, FNLST))))))))
(RETURN VAL))))
(COMS.COMS-VARS
(LAMBDA (VARSLST)
(DECLARE (SPECVARS VARSLST)) (* tlm: " 5-Feb-86 10:30")
(* * Function for the Interlisp file package to print variable definitions
using SETQ)
(* * VARSLST -
name of the variable to printed on the file.)
(* * environment -
this function is being used in the filepkgcoms environment.)
(* * operation -
printout the form definition for the variable VARNAME using RPAQQ/RPAQ if
the flag *COMMON-LISP-FILE-FLAG* is NIL other it will use SETQ.)
(* * effects -
Construct the coms list.)
(* * value -
COMS list to be executed by the filepkg.)
(PROG (VARDEF VARCOMMENT COMS)
(COND
(*COMMON-LISP-FILE-FLAG*
(RETURN (MAPCONC VARSLST
(FUNCTION (LAMBDA (VARNAME)
(COND
((LISTP VARNAME)
(SETQ COMS (BQUOTE ((P (SETQ (\,@ VARNAME)))))))
((AND (HASDEF VARNAME (QUOTE VARS))
(type? BITMAP (SETQ VARDEF
(GETDEF VARNAME (QUOTE VARS)
(QUOTE CURRENT)
(QUOTE (NOCOPY NOERROR))))))
(* for BitMap use standard Interlisp.)
(SETQ COMS (BQUOTE ((ORIGINAL (VARS (\, VARNAME)))))))
((HASDEF VARNAME (QUOTE VARS))
(SETQ COMS (BQUOTE ((P (SETQ (\, VARNAME)
(QUOTE (\, VARDEF))))))))
((LITATOM VARNAME)
(SETQ COMS (BQUOTE ((P (SETQ (\, VARNAME))))))))
(AND (GETD (QUOTE HASTLCMNTS))
(LISTP (HASTLCMNTS VARNAME (QUOTE VARS)))
(SETQ COMS
(NCONC1 COMS
(BQUOTE (E (SHOWTLCMNTS (QUOTE (\, VARNAME))
(QUOTE VARS))
(TERPRI))))))
COMS)))))
(T (RETURN (MAPCONC VARSLST
(FUNCTION (LAMBDA (VARNAME)
(SETQ COMS (BQUOTE ((ORIGINAL (VARS (\, VARNAME))))))
(AND (GETD (QUOTE HASTLCMNTS))
(LISTP (HASTLCMNTS VARNAME (QUOTE VARS)))
(SETQ COMS
(NCONC1 COMS
(BQUOTE (E (SHOWTLCMNTS (QUOTE (\, VARNAME))
(QUOTE VARS))
(TERPRI))))))
COMS)))))))))
(COMS.PRINT-CONSTANTS
(LAMBDA (CONSTANTNAMELST) (* tlm: "19-Feb-86 10:59")
(* * Function for the Interlisp file package to print constants definitions using DEFCONSTANT)
(COND
(*COMMON-LISP-FILE-FLAG* (MAPC CONSTANTNAMELST
(FUNCTION (LAMBDA (CONSTANTNAME)
(COND
((LISTP CONSTANTNAME)
(PRETTYVAR1 (QUOTE DEFCONSTANT)
(CAR CONSTANTNAME)
(CDR CONSTANTNAME)
T T))
((HASDEF CONSTANTNAME (QUOTE VARS))
(PRETTYVAR1 (QUOTE DEFCONSTANT)
CONSTANTNAME
(KWOTE
(GETDEF CONSTANTNAME
(QUOTE VARS)
(QUOTE CURRENT)
(QUOTE (NOCOPY
NOERROR))))
T)
(AND (FUNCTIONP (QUOTE SHOWTLCMNTS))
(SHOWTLCMNTS CONSTANTNAME (QUOTE
VARS))))
((LITATOM CONSTANTNAME)
(PRETTYVAR1 (QUOTE DEFCONSTANT)
CONSTANTNAME
(LIST NIL)
T T)))))))
(T (printout NIL T .PPV (CONS (QUOTE CONSTANTS)
(MAPCAR CONSTANTNAMELST (FUNCTION (LAMBDA (
CONSTANTNAME)
(COND
((LISTP CONSTANTNAME)
(CAR CONSTANTNAME))
(T CONSTANTNAME)))))))
(MAPC CONSTANTNAMELST (FUNCTION (LAMBDA (CONSTANTNAME)
(PRETTYVAR CONSTANTNAME)
(AND (FUNCTIONP (QUOTE SHOWTLCMNTS))
(SHOWTLCMNTS (COND
((LISTP CONSTANTNAME)
(CAR CONSTANTNAME))
(T CONSTANTNAME))
(QUOTE VARS))))))))))
(COMS.PRINT-DEFSETF
(LAMBDA (SETFNAMELST) (* tlm: "10-Feb-86 11:52")
(MAPC SETFNAMELST (FUNCTION (LAMBDA (SETF-FUNCTION)
(COND
((LISTP SETF-FUNCTION)
(PRETTYVAR1 (QUOTE DEFSETF)
(CAR SETF-FUNCTION)
(CDR SETF-FUNCTION)
T T))
((HASDEF SETF-FUNCTION (QUOTE DEFSETF))
(LET ((SETF-DEFINITION (GETDEF SETF-FUNCTION (QUOTE DEFSETF))))
(PRETTYVAR1 (QUOTE DEFSETF)
(CADR SETF-DEFINITION)
(CDDR SETF-DEFINITION)
T T)))
(T (printout T "No DEFSETF definition for " SETF-FUNCTION))))))))
(COMS.PRINT-FNS
(LAMBDA (FNLST)
(DECLARE (SPECVARS FNLST)) (* tlm: "21-Jan-86 11:35")
(* * This function print a function definition for the Interlisp filepkg.)
(* * FNLST -
Function name to be printed.)
(* * environment -
This function must be used in the environment of the filepkg coms.)
(* * operation -
If *COMMON-LISP-DEFUN-FLAG* is T then use DEFUN for printing functions which have a definition
beginning with CL:LAMBDA, for the other functions just use the standard Interlisp PRINTFNS for
printing. If *COMMON-LISP-DEFUN-FLAG* is nil and *COMMON-LISP-FILE-FLAG* is T then use PRINTFNS
Separately on each function in FNLST so that it make 1 DEFINEQ per function, else use PRINTFNS
for all functions.)
(* * effects -
Print the function definition form for each functions in FNLST -
Note: if DEFUN is used then the function LOADFNS will not be able to reload CL:LAMBDA
functions.)
(* * value -
NIL)
(COND
(*COMMON-LISP-DEFUN-FLAG* (MAPC
FNLST
(FUNCTION (LAMBDA (FNNAME)
(DECLARE (SPECVARS FNNAME))
(COND
((HASDEF FNNAME (QUOTE FNS))
(LET (FNS.START FNS.END
(FNSDEF (GETDEF
FNNAME
(QUOTE FNS)
(QUOTE CURRENT)
(QUOTE (NOCOPY NOERROR))))
)
(COND
((EQ (CAR FNSDEF)
(QUOTE CL:LAMBDA))
(SETQ FNS.START (GETFILEPTR PRTTYFILE))
(PRETTYVAR1 (QUOTE DEFUN)
FNNAME
(CDR FNSDEF)
T T)
(SETQ FNS.END (GETFILEPTR PRTTYFILE))
(NCONC1 NEWFILEMAP
(NCONC1 (LIST FNS.START
FNS.END)
(CONS FNNAME
(CONS
FNS.START
FNS.END)))))
(T (PRINTFNS (LIST FNNAME)
T)))))
(T (printout T FNNAME " - has no function defintion." T
T)))))))
(*COMMON-LISP-FILE-FLAG* (MAPC FNLST (FUNCTION (LAMBDA (FNNAME)
(PRINTFNS (LIST FNNAME)
T)))))
(T (PRINTFNS FNLST T)))))
(COMS.PRINT-INITVARS
(LAMBDA (INITVARSLST)
(DECLARE (SPECVARS INITVARSLST)) (* tlm: "21-Jan-86 10:54")
(* * Function for the Interlisp file package to print variable definitions using DEFVAR)
(* * INITVARSLST -
Name of the variable to be printed.)
(* * environment -
This function is being used in a COMS environment.)
(* * operation -
Depending on the variable *COMMON-LISP-FILE-FLAG* it will use either DEFVAR for CommonLisp or
RPAQ? for InterLisp. The printing function being used is PRETTYVAR1. And if the comment
function SHOWTLCMNTS is defined it will try to printout the comment related to this variable.)
(* * effects -
It has for side effect to print to the current output stream.)
(* * value -
The value returned is not significant.)
(COND
(*COMMON-LISP-FILE-FLAG* (MAPC INITVARSLST (FUNCTION (LAMBDA (INITVARNAME)
(COND
((LISTP INITVARNAME)
(PRETTYVAR1 (QUOTE DEFVAR)
(CAR INITVARNAME)
(CDR INITVARNAME)
T T))
(T (PRETTYVAR1 (QUOTE DEFVAR)
INITVARNAME)))
(AND (FUNCTIONP (QUOTE SHOWTLCMNTS))
(SHOWTLCMNTS (COND
((LISTP INITVARNAME)
(CAR INITVARNAME))
(T INITVARNAME))
(QUOTE VARS)))))))
(T (MAPC INITVARSLST (FUNCTION (LAMBDA (INITVARNAME)
(COND
((LISTP INITVARNAME)
(PRETTYVAR1 (QUOTE RPAQ?)
(CAR INITVARNAME)
(CDR INITVARNAME)
T T))
(T (PRETTYVAR1 (QUOTE RPAQ?)
INITVARNAME)))
(AND (FUNCTIONP (QUOTE SHOWTLCMNTS))
(SHOWTLCMNTS (COND
((LISTP INITVARNAME)
(CAR INITVARNAME))
(T INITVARNAME))
(QUOTE VARS))))))))))
(COMS.PRINT-TYPES
(LAMBDA (TYPELST)
(DECLARE (SPECVARS TYPELST)) (* tlm: "18-Feb-86 15:18")
(* * Function for the Interlisp file package to print variable definitions using DEFTYPE)
(MAPC TYPELST (FUNCTION (LAMBDA (TYPENAME)
(COND
((LISTP TYPENAME)
(PRETTYVAR1 (QUOTE DEFTYPE)
(CAR TYPENAME)
(CDR TYPENAME)
T T))
((HASDEF TYPENAME (QUOTE TYPES))
(LET ((DEFTYPE-BODY (GETDEF TYPENAME (QUOTE TYPES))))
(PRETTYVAR1 (CAR DEFTYPE-BODY)
(CADR DEFTYPE-BODY)
(CDDR DEFTYPE-BODY)
T T)))
(T (PRINT (CONS TYPENAME (QUOTE (-- No TYPE Definition.)))
T))))))))
(DEFSETF.GETDEF
(LAMBDA (NAME TYPE OPTIONS) (* tlm: "10-Feb-86 11:35")
(BQUOTE (DEFSETF (\, NAME)
(\, (GETPROP NAME (QUOTE SETFN)))))))
(DEFSETF.HASDEF
(LAMBDA (NAME TYPE OPTIONS) (* tlm: "10-Feb-86 12:00")
(GETPROP NAME (QUOTE SETFN))))
(FNS.FILEGETDEF
(LAMBDA (FN TYPE FILE OPTIONS) (* tlm: "21-Jan-86 11:30")
(* * Locate the symbolic definition of a function in a file.)
(* * FN -
a function name.)
(* * TYPE -
Ignored argument)
(* * FILE -
the fully recognized file name of a file containing a symbolic definition of FN.)
(* * effects -
repositions the file pointer for the file to begin reading the symbolic definition of the
function.)
(* * value -
the file pointer for the end of the function; or NIL if the function could not be located.)
(PROG (NAME MAP LOC START STREAM)
(OR FILE (RETURN))
(OR (SETQ STREAM (OPENSTREAM FILE (QUOTE INPUT)))
(RETURN))
(PRINT (SETQ NAME (FILENAMEFIELD FILE (QUOTE NAME))))
A (OR (AND (SETQ MAP (GETPROP NAME (QUOTE FILEMAP)))
(EQ FILE (GETPROP NAME (QUOTE MAPFILE))))
(AND (SETQ MAP (PUTPROP NAME (QUOTE FILEMAP)
(GETFILEMAP FILE)))
(PUTPROP NAME (QUOTE MAPFILE)
FILE))
(COND
((NOT (EXPRP FN))
(REMPROP NAME (QUOTE FILEMAP))
(AND (RESETVAR USEMAPFLG NIL
(GETDEF (OR (CAR (LAST (FILEVARLST FILE (QUOTE
FNS))))
FN)
(QUOTE FNS)
FILE))
(GETPROP NAME (QUOTE FILEMAP))
(PUTPROP NAME (QUOTE MAPFILE)
FILE)
(GO A))))
(HELP "No file map for " FILE)
(RETURN))
A0 (SOME MAP (FUNCTION (LAMBDA (LST)
(SETQ LOC (ASSOC FN LST)))))
(AND (NULL LOC)
(SETQ MAP (LISTP (CADR MAP)))
(GO A0))
(OR LOC (HELP FN "NOT IN MAP")
(RETURN))
(SETQ LOC (CDR LOC))
(SETQ START (pop LOC))
(SETFILEPTR STREAM START)
(SETQ FNS.DEF (READ STREAM FILERDTBL))
(CLOSEF STREAM)
(RETURN (COND
((AND (EQ (CAR FNS.DEF)
(QUOTE DEFUN))
(EQ (CADR FNS.DEF)
FN))
(CONS (QUOTE CL:LAMBDA)
(CDDR FNS.DEF)))
((EQ (CAR FNS.DEF)
FN)
(CADR FNS.DEF))
(T FNS.DEF))))))
(GET-DISPATCH-MACRO-CHARACTER
(LAMBDA (DISP-CHAR SUB-CHAR READTABLE) (* tlm: "27-Feb-86 10:31")
(* * Pulls the dispatch function out of a two-dimensional array.)
(OR READTABLE (SETQ READTABLE *READTABLE*))
(* * Coerce DISP-CHAR to Interlisp character.)
(COND
((SMALLP DISP-CHAR)
(SETQ DISP-CHAR (CHARACTER DISP-CHAR)))
((OR (LITATOM DISP-CHAR)
(STRINGP DISP-CHAR))
(SETQ DISP-CHAR (CHARACTER (CHCON1 DISP-CHAR))))
((EQ (TYPE-OF DISP-CHAR)
(QUOTE CHARACTER))
(SETQ DISP-CHAR (CHARACTER (CHAR-CODE DISP-CHAR))))
(T (ERROR DISP-CHAR
"is not either a Common Lisp standard character, a character-code, a Interlisp character or a String."
)))
(* * Coerce SUB-CHAR to a Character-Code.)
(COND
((SMALLP SUB-CHAR))
((OR (LITATOM SUB-CHAR)
(STRINGP SUB-CHAR))
(SETQ SUB-CHAR (CHCON1 SUB-CHAR)))
((EQ (TYPE-OF SUB-CHAR)
(QUOTE CHARACTER))
(SETQ SUB-CHAR (CHAR-CODE SUB-CHAR)))
(T (ERROR SUB-CHAR
"is not either a Common Lisp standard character, a character-code, a Interlisp character or a String."
)))
(LET* ((DISPATCH-HARRAY (GET DISP-CHAR DISPATCH-MACRO-PROPERTY))
(MACRO-HASHARRAY (AND (HASHARRAYP DISPATCH-HARRAY)
(GETHASH READTABLE DISPATCH-HARRAY))))
(AND (HASHARRAYP MACRO-HASHARRAY)
(GETHASH SUB-CHAR MACRO-HASHARRAY)))))
(PEEK-CHAR
(CL:LAMBDA (&OPTIONAL PEEK-TYPE (INPUT-STREAM *TERMINAL-IO*)
&KEY
(READ-TABLE *READTABLE*))
(DECLARE (SPECVARS READ-TABLE)) (* tlm: "31-Jan-86 08:18")
(* * CommonLisp function for PEEK-CHAR.)
(* * PEEK-TYPE -
If NIL then just PEEK the first character. If T then PEEK then first non separator character
defined in the current Read Table.)
(* * INPUT-STREAM -
The Input Stream to PEEK. By default it is the *TERMINAL-IO* stream.)
(* * operation -
If no PEEK-TYPE is given or NIL then just use the PEEKCCODE Interlisp Function for peeking
otherwise save the line buffer and system buffer scan first the line buffer then the system
buffer for the first non separator character, restore the line and system buffer and return the
character found.)
(* * effects -
If an interrupt is caugth during a peek with PEEK-TYPE T then the line and system buffer may be
lost.)
(* * value -
a CommonLisp character.)
(COND
(PEEK-TYPE (CLEARBUF INPUT-STREAM T)
(LET ((LIN-BUFFER (LINBUF T))
(SYS-BUFFER (SYSBUF T))
CH)
(LINBUF)
(SYSBUF)
(COND
(LIN-BUFFER (SETQ CH (SKIPSEPRS (SUBSTRING LIN-BUFFER 1)
READ-TABLE)))
(SYS-BUFFER (SETQ CH (SKIPSEPRS (SUBSTRING SYS-BUFFER 1)
READ-TABLE))))
(BKLINBUF LIN-BUFFER)
(BKSYSBUF SYS-BUFFER)
(NAME-CHAR CH)))
(T (CODE-CHAR (PEEKCCODE INPUT-STREAM))))))
(PRETTYPRINTMACROS.#QUOTE
(LAMBDA (FORM) (* tlm: " 5-Feb-86 18:34")
(COND
(*COMMON-LISP-FILE-FLAG* (PRIN1 "#'")
(CADR FORM))
(T FORM))))
(PRETTYPRINTMACROS.*
(LAMBDA (FORM) (* tlm: "22-Jan-86 08:24")
(COND
(*COMMON-LISP-COMMENT-FLAG* (PRINT.SEMICOLON-COMMENT FORM))
(T (PRINTCOMMENT FORM)))))
(PRETTYPRINTMACROS.QUOTE
(LAMBDA (FORM) (* tlm: "22-Jan-86 08:19")
(COND
(*COMMON-LISP-FILE-FLAG* (PRINTQUOTE FORM))
(T FORM))))
(PRINT.SEMICOLON-COMMENT
(LAMBDA (COM LMAR) (* tlm: "21-Jan-86 08:51")
(* * Print an expression as a series of comment lines.)
(* * COM -
an optional list. This is the expression to be printed. Normally, this will be an Interlisp
comment, but it may be any list whose contents is to be printed as the text of a comment.
If this is a comment pointer, the text of the comment will be retrieved.)
(* * LMAR -
an optional column at which to start printing the comment. If the current print position is
already beyond this column, then printing will begin on the next line. The default value is 0)
(* * effects -
prints the contents of the expression as the text of a comment on the primary output file.
If the expression is empty, then an empty comment is printed.)
(PROG ((COMMENTCHAR (CHARACTER 59)))
(AND COM (EQ COMMENTFLG (CAR COM))
(GETCOMMENT COM))
(AND (EQ COMMENTFLG (CAR COM))
(SETQ COM (CDR COM))
(EQ COMMENTFLG (CAR COM))
(SETQ COMMENTCHAR (PACK* (CHARACTER 59)
(CHARACTER 59)))
(SETQ COM (CDR COM)))
(OR (SMALLP LMAR)
(SETQ LMAR 0))
(AND (ILESSP LMAR (POSITION))
(printout NIL T .TAB0 LMAR))
(printout NIL T COMMENTCHAR " " %# (PRINT.SEMICOLON-COMMENT1A COM LMAR
(SUB1 (
LINELENGTH))
COMMENTCHAR)
T)
(RETURN))))
(PRINT.SEMICOLON-COMMENT1A
(LAMBDA (LST LMAR RMAR CMNTCHAR) (* tlm: "21-Jan-86 08:50")
(* * Print the contents of a list in a series of comment lines.)
(* * LST -
a list containing text to be printed. It may be any list whose contents is to be printed as the
text of a comment.)
(* * LMAR -
an optional column at which to start printing any new lines. If none is given, the current line
position is used, and CMNTCHAR is printed at the start of the current line.)
(* * RMAR -
an optional column at which printing is to end. The default value is the current linelength.
This must be >= 30 or no printing will occur.)
(* * CMNTCHAR -
an optional character to be printed at the start of each new line. If LMAR is not given, this
is also printed at the start of the current line. The default value is ;)
(* * effects -
prints the contents of the list as the text of a series of comment lines on the primary output
file. If the list is NIL, no printing takes place. CMNTCHAR is printed at the start of each new
line required. If LMAR is not specified, CMNTCHAR is also printed at the start of the current
line.)
(PROG NIL
(OR (LISTP LST)
(RETURN))
(OR CMNTCHAR (SETQ CMNTCHAR (CHARACTER 59)))
(OR (SMALLP RMAR)
(SETQ RMAR (SUB1 (LINELENGTH))))
(OR (IGEQ RMAR 30)
(RETURN))
(COND
((NOT (SMALLP LMAR))
(SETQ LMAR (POSITION))
(printout NIL CMNTCHAR %,)))
(OR (ILESSP LMAR (ITIMES 2 (IQUOTIENT RMAR 3)))
(SETQ LMAR 0))
(PRINT.SEMICOLON-COMMENT1B (CAR LST)
LMAR RMAR CMNTCHAR)
(MAPC (CDR LST)
(FUNCTION (LAMBDA (X)
(printout NIL %, %# (PRINT.SEMICOLON-COMMENT1B X LMAR RMAR CMNTCHAR)))
))
(RETURN))))
(PRINT.SEMICOLON-COMMENT1B
(LAMBDA (VAL LMAR RMAR CMNTCHAR) (* tlm: " 6-Feb-86 13:06")
(* * Print an expression as part of a comment line.)
(* * VAL -
an expression to be printed as part of a comment.)
(* * LMAR -
the column at which to start printing any new lines.)
(* * RMAR -
the column at which printing is to end.)
(* * CMNTCHAR -
the character to be printed at the start of any new line.)
(* * effects -
prints the expression in the current line, if it will fit. Otherwise, a new line is started and
CMNTCHAR is printed before printing the expression.)
(PROG (NC)
(COND
((LISTP VAL)
(AND (ILEQ 10 (IDIFFERENCE RMAR (POSITION)))
(printout NIL T .TAB0 LMAR CMNTCHAR %,))
(printout NIL "(" %# (PRINT.SEMICOLON-COMMENT1A VAL LMAR RMAR CMNTCHAR)
")")
(RETURN)))
(SETQ NC (NCHARS VAL))
(COND
((IGEQ NC (IDIFFERENCE RMAR LMAR))
(SETQ VAL "{ ... }")
(SETQ NC 7)))
(COND
((ILEQ RMAR (IPLUS NC (POSITION)))
(printout NIL T .TAB0 LMAR CMNTCHAR %,)))
(printout NIL VAL)
(RETURN))))
(QUOTESETUP
(LAMBDA (BQINDXFLG) (* tlm: " 6-Feb-86 11:10")
(* * Setup read macros for QUOTE and BQUOTE characters.)
(* * BQINDXFLG -
a flag which indicates that the character sequence "``" is to be used to indicate indexed terms
and should not be treated as a BQUOTE macro. If the value is NIL, then this special treatment
will be disabled.)
(* * effects -
moves the read macro definition of QUOTE from the terminal read table to the file read table,
and installs the BQUOTE read macro in the terminal, edit, and file read tables.
When called for, the function READBUOTE is advised to disable the interpretation of the
character sequence "``" as a BQUOTE macro. This provides compatibility with the text processing
utility, TXTIO.)
(AND (EQ (GETSYNTAX (CHARCODE "'")
FILERDTBL)
(QUOTE OTHER))
(SETSYNTAX (CHARCODE "'")
(GETSYNTAX (CHARCODE "'")
T)
FILERDTBL))
(COND
((AND (FGETD (QUOTE READBQUOTE))
(FGETD (QUOTE READBQUOTECOMMA)))
(SETSYNTAX (CHARCODE "`")
(QUOTE (MACRO FIRST NONIMMEDIATE ESCQUOTE READBQUOTE))
FILERDTBL)
(SETSYNTAX (CHARCODE ",")
(QUOTE (MACRO FIRST NONIMMEDIATE ESCQUOTE READBQUOTECOMMA))
FILERDTBL)
(COND
(BQINDXFLG (OR (GETPROP (QUOTE READBQUOTE)
(QUOTE ADVICE))
(PUTPROP (QUOTE READBQUOTE)
(QUOTE ADVICE)
(QUOTE ((BEFORE NIL (SETQ FILE
(PROG1 FILE
(AND (SETQ FILE
(
.CHECK.BEFORE.READBQUOTE
FILE RDTBL))
(RETURN FILE))))))))
)
(READVISE READBQUOTE))
((MEMB (QUOTE READBQUOTE)
ADVISEDFNS)
(UNADVISE READBQUOTE)))))))
(READ#QUOTE
(LAMBDA (STREAM RDTBL INDEX) (* tlm: "26-Feb-86 19:08")
(* * This function implement the read macro "#'")
(* * STREAM -
Input stream to read.)
(* * RDTBL -
Read Table to use.)
(* * INDEX -
something passed by the function new.readhashmacro.)
(* * environment -
This function should be called from inside the function new.readhashmacro.
The dispatching is done from the function new.readhashmacro by looking in the hasharray
HASHMACROS.HARRAY for the character 39 (charcode "'"))
(* * operation -
consume the "'" character and read the rest of the input)
(* * effects -
Leave the stream pointer and the end of the s-expression.)
(* * value -
a form (function ...))
(READCCODE STREAM RDTBL)
(COND
((EQ (QUOTE SEPRCHAR)
(GETSYNTAX (PEEKCCODE STREAM)
RDTBL)) (* Found an isolated "#'" then just return it.)
(PACKC (LIST (CHARCODE "#")
(CHARCODE "'"))))
(T (* Return a function form.)
(BQUOTE (FUNCTION (\, (READ STREAM RDTBL INDEX))))))))
(READ#<
(LAMBDA (STREAM RDTBL INDEX)
(DECLARE (SPECVARS STREAM RDTBL)) (* tlm: " 6-Feb-86 12:26")
(* * Function for reading Unreadable object after form like "#<vector name>")
(* * STREAM -
File to read.)
(* * RDTBL -
Current readtable to use.)
(* * INDEX -
Ignored variable.)
(* * environment -
This function is called inside the readhashmacro function.)
(* * operation -
Read until an > is encountered and procude an error.)
(* * effects -
call error.)
(* * value -
NIL)
(LET ((OBJSTR "#<")
CH)
(until (OR (EOFP STREAM)
(EQ (QUOTE >)
(SETQ CH (READC STREAM RDTBL))))
do (SETQ OBJSTR (CONCAT OBJSTR CH)))
(ERROR "Trying to read an UNREADABLE lisp Object" (CONCAT OBJSTR CH)))))
(READ#PLUS-OR-MINUS
(LAMBDA (STREAM RDTBL INDEX) (* tlm: " 3-Mar-86 13:14")
(* * Implementation of the Common Lisp "#+" or "#-" readmacros.)
(LET ((CH (READCCODE STREAM RDTBL))
(FEATURE (READ STREAM RDTBL))
OP SELECTFN SWITCH)
(AND (LISTP FEATURE)
(PROGN (SETQ OP (CAR FEATURE))
(SETQ FEATURE (CDR FEATURE))))
(SETQ SELECTFN (SELECTQ (U-CASE OP)
(OR (FUNCTION SOME))
(AND (FUNCTION EVERY))
NIL))
(SETQ SWITCH (COND
(SELECTFN (APPLY* SELECTFN (MKLIST FEATURE)
(FUNCTION (LAMBDA (X)
(OR (MEMBER (L-CASE X)
*FEATURES*)
(MEMBER (U-CASE X)
*FEATURES*))))))
(T (OR (MEMBER (L-CASE FEATURE)
*FEATURES*)
(MEMBER (U-CASE FEATURE)
*FEATURES*)))))
(COND
((OR (AND (EQ CH (CHARCODE "+"))
(NOT SWITCH))
(AND (EQ CH (CHARCODE "-"))
SWITCH)) (* We should not read it so skip read
the next sexpr.)
(COND
((EQ STREAM T)
(READ STREAM NIL RDTBL)
NIL)
(T (SKREAD STREAM NIL RDTBL))))
(T (* According to the flag we should
read.)
(READ STREAM RDTBL))))))
(READ#VBAR
(LAMBDA (STREAM RDTBL INDEX) (* tlm: "26-Feb-86 20:03")
(* * Implementation of the Common Lisp readmacro for COMMENTS. "#|...|#")
(LET ((CH (READCCODE STREAM RDTBL))
LASTCH)
(until (AND (EQ CH (CHARCODE "#"))
(EQ LASTCH (CHARCODE "|")))
do (SETQ LASTCH CH)
(SETQ CH (READCCODE STREAM RDTBL))))))
(READ-CHAR
(CL:LAMBDA (&OPTIONAL (INPUT-STREAM *TERMINAL-IO*)
&KEY
(READ-TABLE *READTABLE*)) (* tlm: "31-Jan-86 08:20")
(* * CommonLisp function for reading a character.)
(* * INPUT-STREAM -
Input stream to be read. By default it is the *terminal-io* stream.)
(* * READ-TABLE -
read table used for reading. By default it is the cmlrdtbl.)
(* * effects -
Read a character from the stream. The stream pointer is moved to the next character.
But depending on the value of (control t) the line might be bufferized.)
(* * value -
a common lisp character object.)
(CODE-CHAR (READCCODE INPUT-STREAM READ-TABLE))))
(READ-DELIMITED-LIST
(LAMBDA (FILE END-CHAR RDTBL) (* JPG: "13-Feb-86 18:03")
(* * Common Lisp function. Reads a delimited list. end-char is not modified to be a break
character.)
(* * Eats the end-char.)
(bind (END-CHAR-CODE ← (NTHCHARCODE END-CHAR 1))
eachtime (* Skip over white space.)
(while (SYNTAXP (PEEKCCODE FILE)
(QUOTE SEPR)
RDTBL)
do (READCCODE FILE RDTBL))
until (EQ (PEEKCCODE FILE)
END-CHAR-CODE)
collect (READ FILE RDTBL)
finally (* Eat the end-char.)
(READCCODE FILE RDTBL))))
(READ-FROM-STRING
(CL:LAMBDA (STRING &KEY (START 0)
END
(READ-TABLE *READTABLE*)) (* tlm: "31-Jan-86 08:25")
(* * CommonLisp function READ-FROM-STRING.)
(* * STRING -
Input string.)
(* * START -
Start position in the string. By default it is 0 the beginning of the string.)
(* * END -
End position. By default is the length of the string.)
(* * operation -
Take the string as input stream and read it.)
(* * effects -
The input string STRING is not modified.)
(* * value -
Return the value of the read.)
(READ (SUBSTRING (THE STRING STRING)
(ADD1 START)
END)
READ-TABLE T)))
(READ-LINE
(CL:LAMBDA (&OPTIONAL (INPUT-STREAM *TERMINAL-IO*)
EOF-ERROR-P EOF-VALUE &KEY (READ-TABLE *READTABLE*))
(* tlm: "31-Jan-86 08:26")
(* * CommonLisp function READ-LINE.)
(* * INPUT-STREAM -
Input stream to read. By default it is the *terminal-io*.)
(* * EOF-ERROR-P -
If true then signal an error if the read pointer is at end-of-file.)
(* * EOF-VALUE -
Value to return if eof is reached.)
(* * READ-TABLE -
read-table to use for the read. By default it is the cmlrdtbl.)
(* * operation -
read character by character and concat to line.)
(* * value -
return a string or nil or eof-value.)
(CL:DO ((CH (READCCODE INPUT-STREAM READ-TABLE)
(READCCODE INPUT-STREAM READ-TABLE))
(EOLCHARS (GETSYNTAX (QUOTE EOL)))
(LINE "" (CONCAT LINE (CHARACTER CH))))
((FMEMB CH EOLCHARS)
LINE)
(AND (NOT EOF-ERROR-P)
(EOFP INPUT-STREAM)
(RETURN EOF-VALUE)))))
(READ.SEMICOLON-TO-INTERLISP-COMMENT
(LAMBDA (STREAM RDTBL)
(DECLARE (SPECVARS STREAM RDTBL)) (* tlm: "17-Feb-86 15:09")
(* * Function for reading semicolon ala CommonLisp and transform them to Interlisp comments.)
(* * STREAM -
Stream passed by the read function.)
(* * RDTBL -
Read table used for the read.)
(* * environment -
This function is used as a character SPLICE macro for the semi-colon character.)
(* * operation -
Execute the READCCODE until we find a blank line or a line not beginning with a semi-colon.
There is one limitation to this function: the comments must not be longer than 2048 characters.
Otherwise the comment will be cut in chunks of 1968 characters.)
(* * value -
Return an Interlisp Comment form.)
(LET ((SC 0)
(SCL 0)
(STRINGPTR 2)
(RESULT-STRING (ALLOCSTRING 2048 (CHARCODE SPACE)
\READ.SEMICOLON-TO-INTERLISP-COMMENT-SCRATCH-STRING NIL)
)
(STREAM (GETSTREAM STREAM (QUOTE INPUT)))
CHCODE)
(DECLARE (SPECVARS STREAM))
(RPLCHARCODE RESULT-STRING 1 (CHARCODE "("))
(until (AND (EQ (PEEKCCODE STREAM)
(CHARCODE NEWLINE))
(COND
((IGREATERP STRINGPTR (CONSTANT (- 2048 80)))
(* return before we have no more place in the
string buffer)
(RETURN))
(T T))
(PROGN (SETQ SC 0) (* throw away the separator characters)
(SKIPSEPRS STREAM RDTBL)
T)
(NEQ (PEEKCCODE STREAM)
(CHARCODE ";")))
do (until (AND (NEQ (SETQ CHCODE (PEEKCCODE STREAM))
(CHARCODE NEWLINE))
(NEQ CHCODE (CHARCODE ";")))
do (* throw away newline and semicolon characters)
(READCCODE STREAM RDTBL)
(COND
((EQ CHCODE (CHARCODE ";"))
(SETQ SC (ADD1 SC)))
((EQ CHCODE (CHARCODE NEWLINE))
(SETQ SC 0))))
(AND (IGREATERP SC SCL)
(SETQ SCL SC))
(AND (NEQ CHCODE (CHARCODE NEWLINE))
(RPLCHARCODE RESULT-STRING STRINGPTR (READCCODE STREAM RDTBL))
(SETQ STRINGPTR (ADD1 STRINGPTR))))
(COND
((IGEQ SCL 2) (* If scl > 2 then it is a wide comment with 2
*)
(LIST (CONS COMMENTFLG (CONS (QUOTE *)
(READ (CONCAT RESULT-STRING "))))))))")
RDTBL)))))
(T (* scl <= 1 this a simple comment with 1 *)
(LIST (CONS COMMENTFLG (READ (CONCAT RESULT-STRING ")")
RDTBL))))))))
(READ.SEMICOLON-ZAP-LINE
(LAMBDA (STREAM RDTBL) (* tlm: "21-Jan-86 11:47")
(* * Splice macro for reading CommonLisp comments beginning with a semicolon.)
(* * STREAM -
Stream to be read.)
(* * RDTBL -
Read table argument ignored.)
(* * environment -
This function should be used as a SPLICE macro for the character semicolon.
To install the macro do: (SETSYNTAX 59 (QUOTE (SPLICE FORST NONIMMEDIATE ESCQUOTE
READ.SEMICOLON-ZAP-LINE)) ReadTableName))
(* * operation -
Do a READCCODE until the end of line character.)
(* * effects -
Doesn't do anything.)
(* * value -
Return NIL for the reader.)
(until (EQ (READCCODE STREAM)
(CHARCODE NEWLINE))
do NIL)))
(SET-DISPATCH-MACRO-CHARACTER
(LAMBDA (DISP-CHAR SUB-CHAR FUNCTION READTABLE) (* tlm: "27-Feb-86 10:31")
(* * Installs the appropriate dispatch facility for sub-chars of a given dispatch character.
The disp-char must have been previously set up as a dispatch character by the function
make-dispatch-macro-character.)
(* * DISP-CHAR -
The dispatch character. This parameter can be given as a char-code, a standard common lisp
character, a litatom or a string.)
(* * SUB-CHAR -
The sub char. The same format as the dispatch character is allowed.)
(* * FUNCTION -
The dispatch function can be a function name or a lambda expression. The sub-char will not be
read when passed to the dispatch function of the sub-char.)
(* * READTABLE -
The readtable in which the dispatching will be made.)
(* * operation -
An hasharray is stored is on the property DISPATCH-MACRO-HARRAY of the dispatch character.
This hasharray contains as key the readtables in which the dispatching will be done and as
value an hasharray. This second hasharray contains as key the character code of the sub-char
and as value the dispatching function. When setting a new dispatch macro the 2 hasharrays will
be constructed is necessary.)
(* * effects -
Construct the hasharrays and set the values inside.)
(* * value -
return the function.)
(OR READTABLE (SETQ READTABLE *READTABLE*))
(* * Coerce DISP-CHAR to an Interlisp character.)
(COND
((SMALLP DISP-CHAR)
(SETQ DISP-CHAR (CHARACTER DISP-CHAR)))
((OR (LITATOM DISP-CHAR)
(STRINGP DISP-CHAR))
(SETQ DISP-CHAR (CHARACTER (CHCON1 DISP-CHAR))))
((EQ (TYPE-OF DISP-CHAR)
(QUOTE CHARACTER))
(SETQ DISP-CHAR (CHARACTER (CHAR-CODE DISP-CHAR))))
(T (ERROR DISP-CHAR
"is not either a character-code, a common-lisp character or a string")))
(* * Get the char-code of sub-char)
(COND
((SMALLP SUB-CHAR))
((OR (LITATOM SUB-CHAR)
(STRINGP SUB-CHAR))
(SETQ SUB-CHAR (CHCON1 SUB-CHAR)))
((EQ (TYPE-OF SUB-CHAR)
(QUOTE CHARACTER))
(SETQ SUB-CHAR (CHAR-CODE SUB-CHAR)))
(T (ERROR SUB-CHAR
"is not either a character-code, a common-lisp character or a string")))
(LET* ((DISPACTH-HARRAY (OR (GET DISP-CHAR DISPATCH-MACRO-PROPERTY)
(PUTPROP DISP-CHAR DISPATCH-MACRO-PROPERTY (HASHARRAY
5))))
(MACRO-HARRAY (OR (GETHASH READTABLE DISPACTH-HARRAY)
(PUTHASH READTABLE (HASHARRAY 128)
DISPACTH-HARRAY))))
(PUTHASH SUB-CHAR FUNCTION MACRO-HARRAY))))
(UNREAD-CHAR
(CL:LAMBDA (CHAR &OPTIONAL (INPUT-STREAM *TERMINAL-IO*))
(DECLARE (SPECVARS CHAR)) (* tlm: "31-Jan-86 08:35")
(CLEARBUF INPUT-STREAM T)
(LET ((LIN-BUFFER (LINBUF T))
(SYS-BUFFER (SYSBUF T)))
(LINBUF)
(SYSBUF)
(COND
(LIN-BUFFER (BKLINBUF (CONCAT LIN-BUFFER (CHARACTER (CHAR-CODE CHAR))))
(BKSYSBUF SYS-BUFFER))
(SYS-BUFFER (BKSYSBUF (CONCAT SYS-BUFFER (CHARACTER (CHAR-CODE CHAR)))))
(T (BKSYSBUF (CHARACTER (CHAR-CODE CHAR))))))
CHAR))
(USER-READ-HASH-MACRO
(LAMBDA (FILE RDTBL) (* tlm: " 3-Mar-86 16:58")
(* * This function implement the Common Lisp dispatching readmacros.)
(* * FILE -
The file to read from.)
(* * RDTBL -
The read table to use.)
(* * environment -
This function should be installed as (MACRO FIRST NONIMMEDIATE ESCQUOTE
READHASHMACRO) in the readtable RDTBL for the dispatching character.)
(* * operation -
Enable users to add on to the "#" read macro, in the special case where "["
follows the pound sign. i.e. "#[Unit METHOD KEEDATATYPES]" is treated
specially. -
Any other case is passed on to the usual reader. The general scheme is that
the first character after the "#[" is an indicator. If it has a
PoundSignReadFn property, its value is a function to do the reading.
If it has no such property, the system vbar read function is used.)
(* * value -
The updated form of input.)
(LET ((DISPATCH.FN (GET-DISPATCH-MACRO-CHARACTER (CHARCODE "#")
(CHCON1 (U-CASE (PEEKC FILE)))
RDTBL)))
(COND
(DISPATCH.FN (APPLY* DISPATCH.FN FILE RDTBL))
(T
(* * We're in the CML package. Anything we don't handle should be passed off
to the standard CML read macro fn.)
(OLD.READHASHMACRO FILE RDTBL NIL))))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(QUOTESETUP (BOUNDP 'TEXTINDEXMARKER))
(COND ((MOVD? 'READHASHMACRO 'OLD.READHASHMACRO)
(MOVD 'USER-READ-HASH-MACRO 'READHASHMACRO)))
(COND ((GETD 'SET-DISPATCH-MACRO-CHARACTER)
(SET-DISPATCH-MACRO-CHARACTER (CHARCODE "#")
(CHARCODE "'")
(FUNCTION READ#QUOTE)
(GETREADTABLE T))
(SET-DISPATCH-MACRO-CHARACTER (CHARCODE "#")
(CHARCODE "'")
(FUNCTION READ#QUOTE)
EDITRDTBL)
(SET-DISPATCH-MACRO-CHARACTER (CHARCODE "#")
(CHARCODE "'")
(FUNCTION READ#QUOTE)
FILERDTBL)
(SET-DISPATCH-MACRO-CHARACTER (CHARCODE "#")
(CHARCODE "'")
(FUNCTION READ#QUOTE)
*READTABLE*)
(SET-DISPATCH-MACRO-CHARACTER (CHARCODE "#")
(CHARCODE "+")
(FUNCTION READ#PLUS-OR-MINUS)
FILERDTBL)
(SET-DISPATCH-MACRO-CHARACTER (CHARCODE "#")
(CHARCODE "+")
(FUNCTION READ#PLUS-OR-MINUS)
*READTABLE*)
(SET-DISPATCH-MACRO-CHARACTER (CHARCODE "#")
(CHARCODE "-")
(FUNCTION READ#PLUS-OR-MINUS)
FILERDTBL)
(SET-DISPATCH-MACRO-CHARACTER (CHARCODE "#")
(CHARCODE "-")
(FUNCTION READ#PLUS-OR-MINUS)
*READTABLE*)
(SET-DISPATCH-MACRO-CHARACTER (CHARCODE "#")
(CHARCODE "|")
(FUNCTION READ#VBAR)
FILERDTBL)
(SET-DISPATCH-MACRO-CHARACTER (CHARCODE "#")
(CHARCODE "|")
(FUNCTION READ#VBAR)
*READTABLE*)))
(MOVD? 'TTYINREAD 'OLDTTYINREAD)
(MOVD? 'READ#< 'READ<)
(AND (GETD 'OLDTTYINREAD)
(MOVD 'CMLTTYINREAD 'TTYINREAD))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA UNREAD-CHAR READ-LINE READ-FROM-STRING READ-CHAR PEEK-CHAR CL:READ)
)
(PUTPROPS CMLREADER COPYRIGHT ("public domain" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (9739 54079 (.CHECK.BEFORE.READBQUOTE 9749 . 10573) (CL:READ 10575 . 11240) (
CMLTTYINREAD 11242 . 11774) (COMPILE.FILE.DEFSETF 11776 . 12016) (COMS.COMS-FNSCOMMENT 12018 .
14213) (COMS.COMS-VARS 14215 . 16351) (COMS.PRINT-CONSTANTS 16353 . 18113) (COMS.PRINT-DEFSETF
18115 . 18788) (COMS.PRINT-FNS 18790 . 21147) (COMS.PRINT-INITVARS 21149 . 23198) (
COMS.PRINT-TYPES 23200 . 23986) (DEFSETF.GETDEF 23988 . 24185) (DEFSETF.HASDEF 24187 . 24337) (
FNS.FILEGETDEF 24339 . 26745) (GET-DISPATCH-MACRO-CHARACTER 26747 . 28326) (PEEK-CHAR 28328 .
30014) (PRETTYPRINTMACROS.#QUOTE 30016 . 30240) (PRETTYPRINTMACROS.* 30242 . 30475) (
PRETTYPRINTMACROS.QUOTE 30477 . 30679) (PRINT.SEMICOLON-COMMENT 30681 . 32305) (
PRINT.SEMICOLON-COMMENT1A 32307 . 34345) (PRINT.SEMICOLON-COMMENT1B 34347 . 35664) (QUOTESETUP
35666 . 37642) (READ#QUOTE 37644 . 38995) (READ#< 38997 . 39987) (READ#PLUS-OR-MINUS 39989 .
41269) (READ#VBAR 41271 . 41702) (READ-CHAR 41704 . 42466) (READ-DELIMITED-LIST 42468 . 43262) (
READ-FROM-STRING 43264 . 44062) (READ-LINE 44064 . 45226) (READ.SEMICOLON-TO-INTERLISP-COMMENT
45228 . 48171) (READ.SEMICOLON-ZAP-LINE 48173 . 49080) (SET-DISPATCH-MACRO-CHARACTER 49082 .
52040) (UNREAD-CHAR 52042 . 52674) (USER-READ-HASH-MACRO 52676 . 54077)))))
STOP