(FILECREATED "22-JUL-83 12:28:40" {PHYLUM}<LISPCORE>DIG>MACHINEINDEPENDENT.;1 79100
changes to: (FNS COMPAREPRINT)
previous date: "19-MAR-83 18:14:09" {PHYLUM}<LISPCORE>SYSTEM>MACHINEINDEPENDENT.;33)
(* Copyright (c) 1983 by Xerox Corporation)
(PRETTYCOMPRINT MACHINEINDEPENDENTCOMS)
(RPAQQ MACHINEINDEPENDENTCOMS ([COMS (* * random machine-independent utilities)
(FNS LOAD? FILESLOAD DOFILESLOAD)
(FNS DMPHASH HASHOVERFLOW)
(FNS BKBUFS CONCATLIST CHANGENAME CHNGNM CLBUFS CLOSEF? DEFINE
EQMEMB EQUALN FILEDATE FILEMAP FNCHECK FNTYP1 FREEVARS
GETFILEMAP LCSKIP LDIFFERENCE MAPRINT MKLIST NAMEFIELD
NLIST PRINTBELLS PROMPTCHAR PUTFILEMAP RAISEP READFILE
READLINE REMPROPLIST RESETBUFS TAB UNSAVED1 UNSAVEDEF
UPDATEFILEMAP USEDFREE WRITEFILE XNLSETQ PROG2)
(FNS RESETFORM RESETLST RESETTOPVALS RESETTOPVALS1)
(PROP INFO RESETTOPVALS)
(BLOCKS (EQUALN EQUALN)
(SUBPAIR SUBPAIR)
(NIL PROMPTCHAR NAMEFIELD CLOSEF? CLBUFS BKBUFS
(NOLINKFNS PRINTBELLS)
(LINKFNS . T)
(LOCALVARS . T]
[COMS (* * LVLPRINT)
(FNS LVLPRINT LVLPRIN1 LVLPRIN2 LVLPRIN LVLPRIN0)
(BLOCKS (LVLPRINTBLOCK LVLPRINT LVLPRIN1 LVLPRIN2 LVLPRIN LVLPRIN0
(ENTRIES LVLPRINT LVLPRIN1 LVLPRIN2)
(LOCALFREEVARS FILE PRIN2FLG]
[COMS (* * SUBLIS and friends)
(FNS SUBLIS SUBPAIR SUBLIS0 DSUBLIS SUBLIS1 DSUBLIS0)
(BLOCKS (SUBBLOCK DSUBLIS SUBLIS1 SUBLIS SUBLIS0 (LOCALFREEVARS ALST FLG)
(ENTRIES SUBLIS DSUBLIS)
DSUBLIS0))
(DECLARE: DONTEVAL@LOAD DOCOPY (* initialization of variables used in many places)
(ADDVARS (CLISPARRAY)
(CLISPFLG)
(CTRLUFLG)
(EDITCALLS)
(EDITHISTORY)
(EDITUNDOSAVES)
(EDITUNDOSTATS)
(GLOBALVARS)
(LCASEFLG)
(LISPXBUFS)
(LISPXCOMS)
(LISPXFNS)
(LISPXHIST)
(LISPXHISTORY)
(LISPXPRINTFLG)
(NOCLEARSTKLST)
(NOFIXFNSLST)
(NOFIXVARSLST)
(P.A.STATS)
(PROMPTCHARFORMS)
(READBUF)
(READBUFSOURCE)
(REREADFLG)
(RESETSTATE)
(SPELLINGS1)
(SPELLINGS2)
(SPELLINGS3)
(SPELLSTATS1)
(USERWORDS))
(VARS (CHCONLST (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL NIL NIL NIL NIL NIL NIL)))
(CHCONLST1 (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL NIL NIL NIL NIL NIL NIL)))
(CHCONLST2 (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL
NIL NIL NIL NIL NIL NIL NIL)))
(CLEARSTKLST T)
(CLISPTRANFLG (QUOTE CLISP% ))
(HISTSTR0 "<c.r.>")
(HISTSTR2 "repeat")
(HISTSTR3 "from event:")
(HISTSTR4 "ignore")
(LISPXREADFN (QUOTE READ))
(USEMAPFLG T]
(COMS (* * CHARCODE)
(FNS CHARCODE SELCHARQ)
(PROP MACRO CHARCODE SELCHARQ ALPHACHARP DIGITCHARP UCASECODE)
(ALISTS (DWIMEQUIVLST SELCHARQ)
(PRETTYEQUIVLST SELCHARQ)))
[COMS (* * CONSTANTS)
(FNS CONSTANTOK)
(P (MOVD? (QUOTE EVQ)
(QUOTE CONSTANT))
(MOVD? (QUOTE EVQ)
(QUOTE DEFERREDCONSTANT]
(COMS (* * SCRATCHLIST)
(FNS ADDTOSCRATCHLIST SCRATCHLIST)
(PROP MACRO SCRATCHLIST ADDTOSCRATCHLIST)
(PROP INFO SCRATCHLIST))
(COMS (* * COMPARE)
(FNS COMPARELST COMPARE1 COMPAREPRINT COMPAREPRINT1 COMPARELISTS COMPAREPRINTN
COMPAREFAIL COMPAREMAX COUNTDOWN)
(ADDVARS (COMPARETRANSFORMS))
(DECLARE: EVAL@COMPILE DONTCOPY (PROP BLKLIBRARYDEF COUNTDOWN)
(ADDVARS (BLKLIBARY COUNTDOWN)))
(BLOCKS (COMPARELISTSBLOCK COMPARELISTS COMPARELST COMPARE1 COMPAREPRINT COMPAREPRINT1
COMPAREMAX (ENTRIES COMPARELISTS COMPARELST)
(GLOBALVARS COMPARETRANSFORMS)
(LOCALFREEVARS DIFFERENCES LOOSEMATCH)
(NOLINKFNS . T)
COMPAREPRINTN COMPAREFAIL (GLOBALVARS COMMENTFLG
**COMMENT**FLG))
(COUNTDOWN COUNTDOWN)))
(COMS (* * MIN and MAX)
(FNS FLESSP FMAX FMIN GEQ IGEQ ILEQ IMAX IMIN LEQ MAX MIN)
(GLOBALVARS MAX.INTEGER MIN.INTEGER MAX.FLOAT MIN.FLOAT))
(COMS (FNS POWEROFTWOP IMOD EVENP ODDP)
(DECLARE: DONTCOPY (MACROS .2↑NP.)))
[COMS (* * WHENCLOSE)
(FNS AFTERCLOSE EOFCLOSEF WHENCLOSE CLOSEALL NEWCLOSEF RESTOREFILES)
(PROP ARGNAMES WHENCLOSE)
(ADDVARS (BEFORESYSOUTFORMS (RESTOREFILES T))
(AFTERSYSOUTFORMS (RESTOREFILES)))
[DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE CLOSEF)
(QUOTE OLDCLOSEF))
(MOVD (QUOTE NEWCLOSEF)
(QUOTE CLOSEF]
(BLOCKS (NIL AFTERCLOSE EOFCLOSEF WHENCLOSE CLOSEALL NEWCLOSEF RESTOREFILES
(LOCALVARS . T)
(GLOBALVARS RESTOREFILELST]
(GLOBALVARS SYSFILES LOADOPTIONS UPDATEMAPFLG LISPXCOMS CLISPTRANFLG COMMENTFLG
**COMMENT**FLG HISTSTR4 LISPXREADFN REREADFLG HISTSTR0 FILEPKGFLG CTRLUFLG
NOLINKMESS PROMPTCHARFORMS PROMPT#FLG USEMAPFLG FILERDTBL BUILDMAPFLG DFNFLG
ERRORTYPELST SPELLINGS2 DWIMFLG USERWORDS ADDSPELLFLG BELLS LISPXPRINTFLG
CLISPARRAY)
(P [COND (SHALLOWFLG (MOVD (QUOTE EVALV)
(QUOTE GETATOMVAL))
(MOVD (QUOTE SET)
(QUOTE SETATOMVAL))
(MOVD (QUOTE PROG)
(QUOTE RESETVARS)))
(T (MOVD (QUOTE GETTOPVAL)
(QUOTE GETATOMVAL))
(MOVD (QUOTE SETTOPVAL)
(QUOTE SETATOMVAL]
[MAPC (QUOTE ((APPLY BLKAPPLY)
(APPLY* BLKAPPLY*)
(RPLACA FRPLACA)
(RPLACD FRPLACD)
(STKNTH FSTKNTH)
(STKNAME FSTKNAME)
(CHARACTER FCHARACTER)
(STKARG FSTKARG)
(CHCON DCHCON)
(UNPACK DUNPACK)
(ADDPROP /ADDPROP)
(ATTACH /ATTACH)
(DREMOVE /DREMOVE)
(DSUBST /DSUBST)
(NCONC /NCONC)
(NCONC1 /NCONC1)
(PUT /PUT)
(PUTPROP /PUTPROP)
(PUTD /PUTD)
(REMPROP /REMPROP)
(RPLACA /RPLACA)
(RPLACD /RPLACD)
(SET /SET)
(SETATOMVAL /SETATOMVAL)
(SETTOPVAL /SETTOPVAL)
(SETPROPLIST /SETPROPLIST)
(SET SAVESET)
(PRINT LISPXPRINT)
(PRIN1 LISPXPRIN1)
(PRIN2 LISPXPRIN2)
(SPACES LISPXSPACES)
(TAB LISPXTAB)
(TERPRI LISPXTERPRI)
(PRINT SHOWPRINT)
(PRIN2 SHOWPRIN2)
(PUTHASH /PUTHASH)
(QUOTE *)
(FNCLOSER /FNCLOSER)
(FNCLOSERA /FNCLOSERA)
(FNCLOSERD /FNCLOSERD)
(EVQ DELFILE)
(NILL SMASHFILECOMS)
(PUTASSOC /PUTASSOC)
(LISTPUT1 PUTL)
(NILL I.S.OPR)
(NILL RESETUNDO)
(NILL LISPXWATCH)
(QUOTE ADDSTATS)))
(FUNCTION (LAMBDA (X)
(MOVD? (CAR X)
(CADR X]
[MAPC (QUOTE ((TIME PRIN1 LISPXPRIN1)
(TIME SPACES LISPXSPACES)
(TIME PRINT LISPXPRINT)
(DEFC PRINT LISPXPRINT)
(DEFC PUTD /PUTD)
(DEFC PUTPROP /PUTPROP)
(DOLINK FNCLOSERD /FNCLOSERD)
(DOLINK FNCLOSERA /FNCLOSERA)
(DEFLIST PUTPROP /PUTPROP)
(SAVEDEF1 PUTPROP /PUTPROP)
(MKSWAPBLOCK PUTD /PUTD)))
(FUNCTION (LAMBDA (X)
(AND (CCODEP (CAR X))
(APPLY (QUOTE CHANGENAME)
X]
(COND ((NOT (MEMB (QUOTE HIST)
SYSFILES))
(SAVEDEF (QUOTE EVALQT))
[PUTDQ EVALQT (LAMBDA NIL
(PROG (TEM)
(COND [(EQ CLEARSTKLST T)
(COND
((EQ NOCLEARSTKLST NIL)
(* Follwoing control-d Do a CLEARSTK.
Standard case.)
(CLEARSTK))
(T (* clear all stack pointers EXCEPT those on
NOCLEARSTKLST.)
(MAPC (CLEARSTK T)
(FUNCTION
(LAMBDA (X)
(AND (NOT (FMEMB X
NOCLEARSTKLST))
(RELSTK X]
(T (* clear only those stack pointers on
CLEARSTKLST BREAK1, ERRORX2 SAVESET, and a
few other system functions store frames on
this list that can be eliminated after a
control-D.)
(MAPC CLEARSTKLST (FUNCTION RELSTK))
(SETQ CLEARSTKLST NIL)))
(RESETRESTORE NIL (QUOTE RESET))
LP
(PROMPTCHAR (QUOTE ←)
T)
(LISPX (LISPXREAD T T))
(GO LP]
(SETQ DFNFLG NIL)))
(PUTDQ? LISPX [LAMBDA (LISPXX)
(PRINT [AND LISPXX (PROG (LISPXLINE LISPXHIST TEM)
(RETURN (COND ((AND (NLISTP LISPXX)
(SETQ LISPXLINE
(READLINE T NIL T)
))
(APPLY LISPXX (CAR LISPXLINE)
))
(T (EVAL LISPXX]
T T])
[PUTDQ? LISPXREAD (LAMBDA (FILE RDTBL)
(COND [READBUF (PROG1 (CAR READBUF)
(SETQ READBUF (CDR READBUF]
(T (READ FILE RDTBL]
[PUTDQ? LISPXREADP (LAMBDA (FLG)
(COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF)))
T)
(T (READP T FLG]
[PUTDQ? LISPXUNREAD (LAMBDA (LST)
(SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF]
[PUTDQ? LISPXREADBUF (LAMBDA (RDBUF)
(PROG NIL LP (COND ((NLISTP RDBUF)
(RETURN NIL))
((EQ (CAR RDBUF)
HISTSTR0)
(SETQ RDBUF (CDR RDBUF))
(GO LP))
(T (RETURN RDBUF]
(PUTDQ? LISPX/ [LAMBDA (X)
X])
[PUTDQ? LOWERCASE (LAMBDA (FLG)
(PROG1 LCASEFLG (RAISE (NULL FLG))
(RPAQ LCASEFLG FLG]
[PUTDQ? FILEPOS (LAMBDA (STR FILE)
(PROG NIL LP (COND ((EQ (PEEKC FILE)
(NTHCHAR STR 1))
(RETURN T)))
(READC FILE)
(GO LP]
(PUTDQ? FILEPKGCOM [NLAMBDA NIL NIL])
(SETSYNTAX 0 (QUOTE SEPR)
FILERDTBL))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA SCRATCHLIST SELCHARQ RESETTOPVALS RESETLST RESETFORM USEDFREE
RESETBUFS DMPHASH FILESLOAD)
(NLAML CHARCODE XNLSETQ FILEMAP)
(LAMA WHENCLOSE ODDP EVENP MIN MAX IMIN IMAX FMIN FMAX NLIST)))
(LOCALVARS . T)))
(* * random machine-independent utilities)
(DEFINEQ
(LOAD?
[LAMBDA (FILE LDFLG PRINTFLG) (* wt: "20-FEB-78 11:40")
(COND
((NULL (GETP (NAMEFIELD FILE)
(QUOTE FILEDATES)))
(LOAD FILE LDFLG PRINTFLG])
(FILESLOAD
[NLAMBDA FILES (* lmm "11-MAR-83 12:38")
(* Calls to this are written on files by the FILES
command. This function does the load-time evaluation of
the command.)
(DOFILESLOAD FILES])
(DOFILESLOAD
[LAMBDA (FILES)
(DECLARE (USEDFREE LDFLG)) (* lmm "11-MAR-83 12:38")
(* does the work of FILESLOAD)
(for FILE inside FILES bind DIR LOADOPTIONSFLG FORCEDEXT? NOERRORFLG WORD (FN ←(QUOTE LOAD?))
(EXT ← COMPILE.EXT)
first (if (AND (BOUNDP (QUOTE LDFLG))
(NEQ T (INPUT)))
then
(* Under a load; give priority to directory of currently loading file. T is needed since FINDFILE does INFILEP
first iff no DIRLST is given.)
(SETQ DIR (CONS (PACKFILENAME (QUOTE VERSION)
NIL
(QUOTE NAME)
NIL
(QUOTE EXTENSION)
NIL
(QUOTE BODY)
(INPUT))
DIRECTORIES))
(SETQ LOADOPTIONSFLG LDFLG))
join (if (LITATOM FILE)
then (* Get the full name to print it out.)
[PROG NIL
LP [SETQ FILE (OR (FINDFILE (PACKFILENAME (QUOTE BODY)
FILE
(QUOTE EXTENSION)
EXT)
T DIR)
(AND (EQ EXT COMPILE.EXT)
(NULL FORCEDEXT?)
(FINDFILE FILE T DIR))
(if NOERRORFLG
then (RETURN)
else (SETQ FILE
(ERROR FILE (if DIR
then (APPEND (QUOTE (not found on))
DIR)
else "not found")))
(GO LP]
(RETURN (LIST (if (EQ FN (QUOTE CHECKIMPORTS))
then (* LOADOPTIONSFLG has a different meaning for imports)
(CHECKIMPORTS FILE T)
FILE
else (APPLY* FN FILE LOADOPTIONSFLG]
else (while (LISTP FILE)
do (SELECTQ (CAR FILE)
(LOADCOMP (SETQQ FN LOADCOMP?)
(SETQ LOADOPTIONSFLG NIL)
(SETQ EXT NIL))
(LOADFROM (SETQQ FN LOADFROM)
(SETQ EXT NIL))
[FROM (pop FILE)
(SETQ DIR
(MKLIST (if (OR (EQ (SETQ WORD (CAR FILE))
(QUOTE VALUEOF))
(if (AND (EQ WORD (QUOTE VALUE))
(EQ (CADR FILE)
(QUOTE OF)))
then (pop FILE)
T))
then (pop FILE)
(EVAL (CAR FILE))
elseif (AND (SELCHARQ (CHCON1 WORD)
(({ <)
NIL)
T)
[BOUNDP (SETQ WORD
(PACK* WORD (QUOTE
DIRECTORIES]
(SETQ WORD (EVALV WORD)))
then
(* What a Horrible KLUDGE! Whoever invented this should
have his CAR's shot!)
WORD
else (CAR FILE]
(COMPILED (SETQ FORCEDEXT? T)
(SETQ EXT COMPILE.EXT))
(LOAD (SETQQ FN LOAD?))
((EXTENSION EXT)
(SETQ FORCEDEXT? T)
(SETQ FILE (LISTP (CDR FILE)))
(SETQ EXT (CAR FILE)))
((SOURCE SYMBOLIC)
(SETQ EXT NIL))
(IMPORT (SETQQ FN CHECKIMPORTS)
(SETQ EXT NIL))
(NOERROR (SETQ NOERRORFLG T))
(if (FMEMB (CAR FILE)
LOADOPTIONS)
then (SETQ LOADOPTIONSFLG (CAR FILE))
else (* invalid option in FILESLOAD)
NIL))
(pop FILE))
NIL])
)
(DEFINEQ
(DMPHASH
[NLAMBDA L (* DD: " 7-Oct-81 20:36")
(MAPC L (FUNCTION (LAMBDA (ARRAYNAME)
(ERSETQ (PROG ((A (EVALV ARRAYNAME (QUOTE DMPHASH)))
AP)
[PRINT (LIST (QUOTE RPAQ)
ARRAYNAME
(COND
[(LISTP A)
(SETQ AP (CAR A))
(LIST (QUOTE CONS)
(LIST (QUOTE HARRAY)
(HARRAYSIZE AP))
(KWOTE (CDR A]
(T (LIST (QUOTE HARRAY)
(HARRAYSIZE A]
(MAPHASH (OR AP A)
(FUNCTION (LAMBDA (VAL ITEM)
(PRINT (LIST (QUOTE PUTHASH)
(KWOTE ITEM)
(KWOTE VAL)
ARRAYNAME])
(HASHOVERFLOW
[LAMBDA (HARRAY) (* rmk: "19-MAR-83 18:05")
(* Should be called from PUTHASH on hash overflow, but for implementations where PUTHASH calls ERRORX directly, may
be called from ERRORX2 when the offender is a listp.)
(COND
((LISTP HARRAY)
[PROG ((SIZE (HARRAYSIZE HARRAY))
(GROW (CDR HARRAY)))
(FRPLACA HARRAY (REHASH HARRAY (HARRAY (COND
((NULL GROW)
(* SIZE*1.5 -
favor to bbn, since pdp-11 doesnt have floatng point,
and LRSH on other systems might be faster than
IQUOTIENT)
(IPLUS SIZE (LRSH (ADD1 SIZE)
1)))
((FLOATP GROW)
(FTIMES SIZE GROW))
((NUMBERP GROW)
(IPLUS SIZE GROW))
((NUMBERP (APPLY* GROW HARRAY)))
(T
(* Default: multiply by 1.5)
(IPLUS SIZE (LRSH (ADD1 SIZE)
1]
HARRAY)
(T (ERRORX (LIST 26 HARRAY])
)
(DEFINEQ
(BKBUFS
[LAMBDA (BUFS ID) (* DD: " 6-Oct-81 15:34")
(PROG (L S)
[COND
((NLISTP BUFS)
(RETURN))
(T (SETQ L (CAR BUFS))
(SETQ S (CDR BUFS]
(COND
((READP T)
(* User types ahead before command causing buffer to be restored was executed. In this case, his type-ahead would
come BEFORE the restored buffer, when it should be after it, because the command causing the buffer to be restored
had to have been given before the type-ahead.)
(PRINTBELLS)
(DOBE)
(CLEARBUF T T)
(BKSYSBUF S)
(BKSYSBUF (SYSBUF T))
(SYSBUF))
(S (BKSYSBUF S)))
(COND
(L (AND ID (PRIN1 ID T))
(* ID will be suppressed by LISPX to prevent it being typed in middle of input. Note that anything put back in
SYSBUF will be printed (echoed) as it is read.)
(PRIN1 L T)
(BKLINBUF L)))
(RETURN])
(CONCATLIST
[LAMBDA (L) (* lmm "17-NOV-82 11:58")
(PROG [(STR (ALLOCSTRING (for X in L sum (NCHARS X]
(for X in L as I from 1 by (NCHARS X) do (RPLSTRING STR I X))
(RETURN STR])
(CHANGENAME
[LAMBDA (FN FROM TO) (* wt: "18-SEP-78 21:29")
(COND
((CHANGENAME1 (GETD FN)
FROM TO FN)
(AND FILEPKGFLG (EXPRP FN)
(MARKASCHANGED FN (QUOTE FNS)))
FN])
(CHNGNM
[LAMBDA (FN OLD FLG)
(PROG (NEW DEF X Y Z)
(SETQ FN (FNCHECK FN NIL T))
(* No error, becuase maybe OLD isnt efined yet, e.g. BREAK
((FOO IN FUM)) where FOO not defined.)
(SETQ OLD (OR (FNCHECK OLD T T)
OLD))
(SETQ DEF (GETD (OR (GETP FN (QUOTE ADVISED))
(GETP FN (QUOTE BROKEN))
FN)))
(SETQ NEW (PACK (LIST OLD (QUOTE -IN-)
FN)))
[COND
(FLG (AND (NULL (STKPOS NEW))
(/PUTD NEW))
[COND
([SETQ Z (/DREMOVE OLD (GETP FN (QUOTE NAMESCHANGED]
(/PUT FN (QUOTE NAMESCHANGED)
Z))
(T (/REMPROP FN (QUOTE NAMESCHANGED]
(/REMPROP NEW (QUOTE ALIAS))
(SETQ Y OLD)
(SETQ X NEW))
(T (SETQ Y NEW)
(SETQ X OLD)
(COND
((AND (MEMB OLD (GETP FN (QUOTE NAMESCHANGED)))
(GETD NEW)
(GETP NEW (QUOTE ALIAS)))
(RETURN NEW]
[COND
[(NULL DEF)
(RETURN (CONS DEF (QUOTE (not defined]
([NULL (RESETVARS ((NOLINKMESS T))
(RETURN (CHANGENAME1 DEF X Y FN]
(RETURN (CONS X (APPEND (QUOTE (not found in))
(LIST FN]
[COND
((NULL FLG)
(COND
((NULL (SETQ DEF (GETD OLD)))
(SETQ DEF (LIST (QUOTE NLAMBDA)
(GENSYM)))
(PRINT (CONS OLD (QUOTE (was undefined)))
T T)))
(/PUTD NEW (SAVED OLD NIL DEF OLD))
(/ADDPROP FN (QUOTE NAMESCHANGED)
OLD)
(/PUT NEW (QUOTE ALIAS)
(CONS FN OLD]
(RETURN Y])
(CLBUFS
[LAMBDA (NOCLEARFLG NOTYPEFLG BUF)
(* wt: 10-MAR-77 21 5)
(* NOCLEARFLG=T means CLEARBUF has already been done, and anything in the buffer now is type-ahead, e.g. calls from
EVALQT, and call from BREAK on control-h INTERRUPT.)
(* NOTYPEFLG=T means user should not be typing ahead. If READP is T, warn him to stop and wait.
Occurs when CLBUFS is being done BEFORE some action, e.g. DWIM interaction, loading SYSBUF for EXEC commands, etc.
as opposed to AFTER some action, e.g. an error occurred.)
(PROG (LBUF SBUF)
(COND
(NOCLEARFLG (GO SKIP))
((AND NOTYPEFLG (READP T))
(PRINTBELLS)
(DOBE)))
(CLEARBUF T T)
(SETQ READBUF BUF)
SKIP(SETQ CTRLUFLG NIL) (* In case user control-e's or control-d's after typing control-u and changing
his mind.)
(SETQ LBUF (LINBUF T))
(SETQ SBUF (SYSBUF T))
(LINBUF)
(SYSBUF)
(COND
((STREQUAL LBUF (QUOTE "
"))
(SETQ LBUF NIL)))
(RETURN (COND
((OR SBUF LBUF)
(CONS LBUF SBUF])
(CLOSEF?
[LAMBDA (FL) (* wt: 18-MAR-77 12 20)
(* useful for resetsaves, in case somebody else might close the file.)
(AND FL (OPENP FL)
(CLOSEF FL])
(DEFINE
[LAMBDA (X TYPE-IN) (* rmk: "31-JUL-81 18:03")
(MAPCAR X
(FUNCTION (LAMBDA (X)
(PROG (CX DEF NEWFLG)
(DECLARE (SPECVARS CX))
(* So the function name can be seen by advised sub-functions)
(COND
((NLISTP X)
(ERROR (QUOTE "incorrect defining form")
X)))
(SETQ CX (CAR X))
[SETQ DEF (COND
((NULL (CDDR X))
(CADR X))
(T (CONS (QUOTE LAMBDA)
(CDR X]
(COND
(TYPE-IN (FIXEDITDATE DEF)))
(COND
((OR (NULL DFNFLG)
(EQ DFNFLG T))
(SETQ NEWFLG (NULL (GETD CX)))
(COND
[(NULL NEWFLG)
(VIRGINFN CX T)
(COND
((EQUAL DEF (GETD CX))
(RETURN CX))
((NULL DFNFLG)
(LISPXPRINT (CONS CX (QUOTE (redefined)))
T T)
(SAVEDEF CX]
((GETPROP CX (QUOTE CLISPWORD))
(MAPRINT (CONS CX (QUOTE (defined, therefore disabled in CLISP.)))
T "****Note: " (QUOTE %
)
NIL NIL T))
((MEMB CX LISPXCOMS)
(MAPRINT (CONS CX
(QUOTE (is also the name of a history command. When
typed in, its interpretation as a history
command will take precedence.)))
T "****Note: " (QUOTE %
)
NIL NIL T)))
(COND
(ADDSPELLFLG (ADDSPELL CX)))
(/PUTD CX DEF))
(T (* DFNFLG is PROP or ALLPROP. However, treat anything else the same as PROP.)
(AND ADDSPELLFLG (ADDSPELL CX 0))
(/PUTPROP CX (QUOTE EXPR)
DEF)))
(COND
(FILEPKGFLG (MARKASCHANGED CX (QUOTE FNS)
NEWFLG)))
(RETURN CX])
(EQMEMB
[LAMBDA (X Y) (* lmm: 17 APR 75 305)
(OR (EQ X Y)
(AND (LISTP Y)
(FMEMB X Y)
T])
(EQUALN
[LAMBDA (X Y DEPTH) (* wt: "12-JUN-80 10:57")
(* lmm " 2-SEP-77 21:05")
(* like EQUAL but stops, returning T, if depth of car recursion plus depth of cdr
recursion ever exceeds DEPTH.)
(COND
((EQ X Y))
[(NLISTP X)
(COND
((NUMBERP X)
(AND (NUMBERP Y)
(EQP X Y)))
((STRINGP X)
(STREQUAL X Y))
((STACKP X)
(EQP X Y]
((NLISTP Y)
NIL)
((AND DEPTH (ILESSP DEPTH 1))
(QUOTE ?))
(T (SELECTQ [EQUALN (CAR X)
(CAR Y)
(AND DEPTH (SETQ DEPTH (SUB1 DEPTH]
(? (QUOTE ?))
(T (EQUALN (CDR X)
(CDR Y)
DEPTH))
NIL])
(FILEDATE
[LAMBDA (FILE CFLG) (* DD: " 6-Oct-81 15:51")
(* CFLG IS T FOR COMPILED FILES)
(PROG (X Y)
(AND FILE (XNLSETQ (PROG NIL
[COND
((SETQ X (OPENP FILE (QUOTE INPUT)))
(SETQ FILE X))
(T
(* INFILE used instead of INFILEP to allow for error correction.)
(SETQ FILE (INPUT (INFILE FILE]
(COND
((NULL (RANDACCESSP FILE))
(GO OUT)))
LP (COND
((NOT (FILEPOS (QUOTE "(FILECREATED")
FILE NIL (IPLUS (GETFILEPTR FILE)
20)))
(COND
((AND X (NOT (NUMBERP X)))
(* file was originally open. reset file pointer to 0 and try again. the eason we dont do this first, is that during
loadup, one or more reads are deliberately performed before calling filedate so as to getthe date corresponding to
the right symbolic file.)
(SETQ X (SETFILEPTR X 0))
(GO LP)))
(GO OUT)))
(AND CFLG (READ FILE FILERDTBL))
[SETQ Y (COND
((NLISTP (SETQ Y (READ FILE FILERDTBL)))
NIL)
((EQ (CAR Y)
(QUOTE FILECREATED))
(CAR (LISTP (CDR Y]
OUT (COND
((NULL X)
(CLOSEF FILE))
((NUMBERP X)
(SETFILEPTR FILE X)))
(RETURN Y))
NOBREAK)
(RETURN Y])
(FILEMAP
[NLAMBDA (FILEMAP) (* wt: 11-JUL-76 20 8)
(PUTFILEMAP (INPUT)
FILEMAP FILECREATEDLST])
(FNCHECK
[LAMBDA (FN NOERRORFLG SPELLFLG PROPFLG TAIL)
(* wt: "13-FEB-78 23:57")
(PROG (X)
TOP (COND
((NOT (LITATOM FN))
(GO ERROR))
((GETD FN))
((GETP FN (QUOTE EXPR))
(AND (NULL PROPFLG)
(GO ERROR)))
((AND DWIMFLG [CAR (NLSETQ (SETQ X (OR (MISSPELLED? FN 70 USERWORDS SPELLFLG TAIL
(FUNCTION GETD))
(MISSPELLED? FN 70 SPELLINGS2 SPELLFLG TAIL]
(NEQ X FN))
(SETQ FN X)
(GO TOP))
(T (GO ERROR)))
(AND ADDSPELLFLG (ADDSPELL FN 0))
(RETURN FN)
ERROR
(COND
(NOERRORFLG (RETURN NIL)))
[SETQ FN (ERROR FN (QUOTE "not a function")
(NULL (RELSTK (OR (STKPOS (QUOTE LOAD))
(STKPOS (QUOTE LOADFROM]
(GO TOP])
(FNTYP1
[LAMBDA (X)
(AND CLISPARRAY (SETQ X (GETHASH X CLISPARRAY))
(FNTYP X])
(FREEVARS
[LAMBDA (X) (* wt: 13-AUG-77 17 52)
(* dummy definition. dwim and errorcontext call freevars, which is defined
masterscope)
NIL])
(GETFILEMAP
[LAMBDA (FILE FL) (* rmk: "18-NOV-81 19:52"
)
(* Value is map for FILE either obtained from the
file itself, or from its property list.
FILE is full name of file, and is presumed open.
FL is (NAMEFIELD FL T))
(AND
USEMAPFLG
(PROG (TEM)
(RETURN
(COND
([EQ FILE (CAR (SETQ TEM (LISTP (GETPROP FL
(QUOTE FILEMAP]
(CADR TEM))
((PROG1
[AND
(RANDACCESSP FILE)
(EQ [CAR (SETQ TEM
(LISTP (PROGN (SETFILEPTR FILE 0)
(READ FILE FILERDTBL]
(QUOTE FILECREATED))
(NUMBERP (SETQ TEM (CADDDR TEM)))
(PROGN
(SETFILEPTR FILE TEM)
(AND [RESETVARS [(ERRORTYPELST
(QUOTE ((16 (ERROR!]
(* NLSETQ doesn't suppress the file-closing
operation on EOF; ERROR! bombs out with the file
left open.)
(RETURN (NLSETQ (SETQ TEM
(READ FILE
FILERDTBL]
(EQ (CAR (LISTP TEM))
(QUOTE FILEMAP]
(SETFILEPTR FILE 0))
(CADR TEM])
(LCSKIP
[LAMBDA (FN FLG) (* lmm "29-DEC-78 17:14")
(* Skip or copy FN, FLG T to copy)
(PROG (LEN LA)
[COND
((EQ (PEEKC)
(QUOTE % ))
(COND
((EQ (SETQ LA (READ NIL FILERDTBL))
(QUOTE BINARY))
(RETURN (BINSKIP FN FLG NIL NIL LA)))
((SETQ LEN (GETPROP LA (QUOTE CODEREADER)))
(* Peters hook for interfacing byte compiler.)
(RETURN (APPLY* (CDR LEN)
FN FLG NIL NIL LA]
(ERROR (QUOTE "Bad compiled function")
FN])
(LDIFFERENCE
[LAMBDA (X Y) (* lmm "31-DEC-78 15:25")
(PROG (VAL)
LP [COND
((OR (NLISTP X)
(NLISTP Y))
(RETURN (ENDCOLLECT VAL X)))
((NOT (MEMBER (CAR Y)
X))
(SETQ Y (CDR Y)))
((MEMBER (CAR X)
Y)
(SETQ X (CDR X)))
(T (SETQ VAL (DOCOLLECT (PROG1 (CAR X)
(SETQ X (CDR X)))
VAL]
(GO LP])
(MAPRINT
[LAMBDA (LST FILE LEFT RIGHT SEP PFN LSPXPRNTFLG)
(* wt: 15-SEP-77 15 43)
(RESETVARS ((LISPXPRINTFLG LSPXPRNTFLG))
[COND
((NULL PFN)
(SETQ PFN (FUNCTION LISPXPRIN1]
[COND
((NULL SEP)
(SETQ SEP (QUOTE % ]
(COND
(LEFT (LISPXPRIN1 LEFT FILE)))
(COND
((NLISTP LST)
(GO EXIT)))
LP (APPLY* PFN (CAR LST)
FILE)
(COND
((NULL (SETQ LST (CDR LST)))
(GO EXIT))
((NLISTP LST)
(LISPXPRIN1 (QUOTE " . ")
FILE)
(APPLY* PFN LST FILE)
(GO EXIT)))
(LISPXPRIN1 SEP FILE)
(GO LP)
EXIT(COND
(RIGHT (LISPXPRIN1 RIGHT FILE])
(MKLIST
[LAMBDA (X) (* lmm: 21 AUG 75 428)
(AND X (OR (LISTP X)
(LIST X])
(NAMEFIELD
[LAMBDA (FILE SUFFIXFLG DIRFLG)
(* lmm: "18-MAR-77 06:51:49")
(* IF SUFFIXFLG is T, returns name and suffix field, otherwise just NAMEFIELD)
(COND
((EQ DIRFLG (QUOTE ONLY))
(FILENAMEFIELD FILE (QUOTE DIRECTORY)))
((EQ SUFFIXFLG (QUOTE ONLY))
(FILENAMEFIELD FILE (QUOTE EXTENSION)))
(T (PACKFILENAME (QUOTE DIRECTORY)
(AND DIRFLG (FILENAMEFIELD FILE (QUOTE DIRECTORY)))
(QUOTE NAME)
(FILENAMEFIELD FILE (QUOTE NAME))
(QUOTE EXTENSION)
(AND SUFFIXFLG (FILENAMEFIELD FILE (QUOTE EXTENSION])
(NLIST
[LAMBDA N
(PROG (V (I N))
LP [COND
((ZEROP I)
(RETURN V))
((OR V (ARG N I))
(SETQ V (CONS (ARG N I)
V]
(SETQ I (SUB1 I))
(GO LP])
(PRINTBELLS
[LAMBDA NIL (* wt: 10-MAR-77 21 15)
(PRIN3 BELLS T])
(PROMPTCHAR
[LAMBDA (ID FLG HISTORY)
(DECLARE (SPECVARS ID HISTORY PROMPTSTR))
(* lmm " 5-NOV-82 00:05")
(* First checks READBUF, and strips off any leading pseudo-carriage rettursn, and computes the new readbuf for
repeated operations. If following this, READBUF is not NIL, never prints ID. Otherwise prints ID if FLG is T, or if
READP is NIL. FLG is T for calls from EVALQT and BREAK, NIL from editor.)
(PROG (N MOD PROMPTSTR)
(COND
(FLG (AND READBUF (SETQ READBUF (LISPXREADBUF READBUF))
(RETURN NIL))
(* redoing an event)
)
((LISPXREADP) (* LISPXREADP returns T if there is anything on this line, but returns NIL if
just a c.r.)
(RETURN NIL)))
NIL [COND
((AND HISTORY PROMPT#FLG)
(SETQ PROMPTSTR (COND
((IGREATERP (SETQ N (ADD1 (CADR HISTORY)))
(SETQ MOD (OR (CADDDR HISTORY)
100)))
(* This event is the roll-over event.)
(IDIFFERENCE N MOD))
(T N]
[COND
(PROMPTCHARFORMS
(* gives user a hook for operations to be performed each event, e.g. monitoring functions, checking if typescript
window is up etc. also these forms can change what is printed by resetting promptstr and / or id)
(MAPC PROMPTCHARFORMS (FUNCTION (LAMBDA (X)
(ERSETQ (EVAL X]
(AND PROMPTSTR (PRIN2 PROMPTSTR T))
(AND ID (PRIN1 ID T])
(PUTFILEMAP
[LAMBDA (FILE FILEMAP FILCREATEDLST)
(* wt: "24-NOV-77 00:18")
(* called from load, loadfns, prettydef, and filemap)
(AND FILEMAP BUILDMAPFLG (PROG (FL)
(/PUT (SETQ FL (NAMEFIELD FILE T))
(QUOTE FILEMAP)
(LIST FILE FILEMAP (COND
[(NULL FILCREATEDLST)
(* see comment in ddfile)
(CADDR (GETPROP FL (QUOTE FILEMAP]
(T (MAPCAR FILCREATEDLST (FUNCTION (LAMBDA (X)
(LIST (CAR X)
(CADR X])
(RAISEP
[LAMBDA (TTBL) (* wt: 1-AUG-77 14 15)
(* True if lisp is in mode where it raises lower case inputs to uppercase.)
(COND
((RAISE NIL TTBL)
(RAISE T TTBL)
T])
(READFILE
[LAMBDA (FILE)
(PROG (L TEM HELPCLOCK)
(SETQ FILE (INPUT (INFILE FILE)))
LP (COND
([NULL (NLSETQ (SETQ TEM (READ FILE FILERDTBL]
(RETURN L))
((EQ TEM (QUOTE STOP))
(CLOSEF FILE)
(RETURN L)))
(SETQ L (NCONC1 L TEM))
(GO LP])
(READLINE
[LAMBDA (RDTBL LINE LISPXFLG) (* lmm " 5-NOV-82 00:06")
(DECLARE (SPECVARS LINE LISPXFLG SPACEFLG))
(PROG (TEM SPACEFLG CHRCODE (FL T)
START)
TOP (COND
((LISTP READBUF)
(GO LP2))
((NULL (READP T))
(CLEARBUF T)
(* This is in case there is a c.r. in the single character buffer. Note that if there were other atoms on the line
terminated by a c.r., after readline finished, the c.r. would be gone. Thus this check for consistency.)
(RETURN LINE)))
LP (SETQ SPACEFLG NIL)
LP1 (COND
[(SYNTAXP [SETQ CHRCODE (CHCON1 (SETQ TEM (PEEKC FL (OR RDTBL T]
(QUOTE EOL))
(* C.R.)
(READC FL)
(COND
((AND LINE SPACEFLG)
(AND (EQ FL T)
(PRIN1 (QUOTE ...)
T))
(GO LP))
(T (GO OUT]
((OR (SYNTAXP CHRCODE (QUOTE RIGHTPAREN)
RDTBL)
(SYNTAXP CHRCODE (QUOTE RIGHTBRACKET)
RDTBL))
(READ FL RDTBL)
(AND LISPXFLG (NULL (CDR LINE))
(SETQ LINE (NCONC1 LINE NIL)))
(* The "]" is treated as NIL if it is the only thing on the line when READLINE is called with LISPXFLG=T.
The reason for CDR is that LISPX calls readline giving it the initial atom on the line.)
(GO OUT))
((AND (EQ CHRCODE (CHARCODE SPACE))
(SYNTAXP CHRCODE (QUOTE SEPR)
RDTBL))
(* SPACE the syntaxp check is to allow for space being a read macro)
(SETQ SPACEFLG T)
(READC FL)
(GO LP1)))
[SETQ TEM (COND
((EQ LISPXREADFN (QUOTE READ))
(* So the call will be linked, so the user can break on read.)
(READ FL RDTBL))
(T (APPLY* LISPXREADFN FL RDTBL]
(* The reason for not embedding the setq in the ncon1 is that the act of reading may change L, e.g. via a ↑W read
macro.)
(COND
((EQ TEM HISTSTR4)
(* fo implemeing read macros that are for effect only. ignore the value returned by read. if we had soft interrupts
from iowaits, we wouldnt needs this.)
(GO LP1)))
(SETQ LINE (NCONC1 LINE TEM))
(COND
((SYNTAXP (SETQ TEM (CHCON1 (LASTC FL)))
(QUOTE RIGHTBRACKET)
RDTBL)
(* The reason why readline is driven by the last character insead of doing a peekc before reding is that due to
eadmacros, it is possible for several things to be read, e.g. A B C ' (FOO) terminated by square bracket should
terminate the line. However, it is not sufficient just to check whether the value read is a list or not since "()"
and NIL must also be treated differently.)
(GO OUT))
((NULL (SYNTAXP TEM (QUOTE RIGHTPAREN)
RDTBL))
(GO LP))
((AND LISPXFLG (NULL SPACEFLG)
(NULL (CDDR LINE)))
(* A list terminates the line if if called from LISPX and is both the firt thing on a line and not preceded by a
space.)
(GO OUT))
(T (AND (EQ FL T)
(PRIN1 (QUOTE ...)
T))
(GO LP)))
(GO LP)
OUT [COND
((AND (LISTP LINE)
CTRLUFLG) (* User typed control-u during reading.)
(SETQ CTRLUFLG NIL)
(COND
((NULL (NLSETQ (EDITE LINE)))
(* Exited with a STOP.)
(SETQ REREADFLG (QUOTE ABORT]
(COND
(START [COND
((NEQ START (CADADR READBUF))
(SHOULDNT))
(T (* the rplaca is to handle small numbers)
(RPLACA (CDADR READBUF)
(SETN START (GETFILEPTR FL]
(SETFILEPTR FL -1)))
(RETURN LINE)
LP2 (COND
((EQ (CAR READBUF)
HISTSTR0)
(SETQ READBUF (CDR READBUF))
(RETURN LINE))
((NULL (SETQ READBUF (LISPXREADBUF READBUF)))
(* checks for things like HISTSTR2 etc. this can occur if you redo an event contaiing a readline.
can also occur under a break if you call a function which calls readline, becausebreak unreads stuff, leaving the
"from event" tag on.)
(GO TOP)))
(SETQ TEM READBUF)
(SETQ READBUF (CDR READBUF))
(SETQ LINE (NCONC1 LINE (CAR TEM)))
(COND
((NULL READBUF) (* really shouldnt happen, as there shuld be a "<c.r."
marker. however, in the case of a fix coand, user might delete it.)
(RETURN LINE)))
(GO LP2])
(REMPROPLIST
[LAMBDA (ATM PROPS) (* wt: 30-JUL-77 13 32)
(PROG (LST LST1 TEM)
(COND
([NULL (SETQ LST1 (SETQ LST (GETPROPLIST ATM]
(RETURN NIL)))
LP (COND
((NLISTP LST1)
(GO OUT))
((NOT (FMEMB (CAR LST1)
PROPS)))
((EQ LST1 LST)
(SETQ LST (CDDR LST)))
((SETQ TEM (CDDR LST1))
(RPLNODE2 LST1 TEM)
(GO LP))
(T (* the last property, also not the first one.)
(RPLACD (NLEFT LST 1 LST1))
(GO OUT)))
(SETQ LST1 (CDDR LST1))
(GO LP)
OUT (SETPROPLIST ATM LST)
(RETURN])
(RESETBUFS
[NLAMBDA FORMS (* lmm " 9-APR-78 00:27")
(DECLARE (LOCALVARS . T))
(PROG [($$BUFS (PROGN (LINBUF)
(SYSBUF)
(CLBUFS NIL T READBUF]
(RETURN (PROG1 (APPLY (FUNCTION PROGN)
FORMS
(QUOTE INTERNAL))
(AND $$BUFS (BKBUFS $$BUFS])
(TAB
[LAMBDA (POS MINSPACES FILE)
(PROG (X)
(COND
((NOT (IGREATERP (IPLUS (SETQ X (POSITION FILE))
(OR (NUMBERP MINSPACES)
1))
POS))
(SPACES (IDIFFERENCE POS X)
FILE))
((EQ MINSPACES T) (* MINSPACES=T means space over to POS unless you are already beyond it.)
)
(T (TERPRI FILE)
(SPACES POS FILE])
(UNSAVED1
[LAMBDA (FN TYP) (* lmm "22-MAY-80 21:12")
(PROG (DEF PROP)
TOP (COND
((NOT (LITATOM FN)))
([SETQ DEF (COND
((SETQ PROP TYP)
(GETP FN TYP))
[(GETP FN (SETQ PROP (QUOTE EXPR]
[(GETP FN (SETQ PROP (QUOTE CODE]
((GETP FN (SETQ PROP (QUOTE SUBR]
(AND (GETD FN)
(UNBREAK0 FN))
(/REMPROP FN PROP)
(COND
((NEQ DFNFLG T)
(SAVEDEF FN)))
(/PUTD FN DEF)
(AND ADDSPELLFLG (ADDSPELL FN))
(RETURN PROP))
[(OR (GETD FN)
(GETPROPLIST FN))
(* Not a misspelling)
(RETURN (COND
[TYP (CONS TYP (QUOTE (not found]
(T (QUOTE (nothing found]
((SETQ PROP (FNCHECK FN T))
(SETQ FN PROP)
(GO TOP)))
(ERROR FN (QUOTE "not a function"])
(UNSAVEDEF
[LAMBDA (X TYP) (* lmm "11-DEC-81 21:43")
(* THIS SIMPLE UNSAVEDEF IS REDEFINED IN FILEPKG)
(COND
[(LISTP X)
(MAPCAR X (FUNCTION (LAMBDA (X)
(UNSAVED1 X TYP]
(T (UNSAVED1 X TYP])
(UPDATEFILEMAP
[LAMBDA (FILE FILEMAP) (* lmm "12-OCT-82 17:15")
(PROG (FILEMAPADR FILEMAPLOCADR TEM (DECLARESTRING (CONCAT "(DECLARE: DONTCOPY
" "(FILEMAP")))
(SETFILEPTR FILE 0)
(SKIPSEPRS FILE FILERDTBL)
(* Could be some font shifts or other garbage)
(READC FILE) (* Skip paren or bracket)
(COND
((AND (EQ (RATOM FILE FILERDTBL)
(QUOTE FILECREATED))
[FIXP (SETQ FILEMAPADR (PROGN (SKREAD FILE)
(* Date)
(SKREAD FILE)
(* Name)
(SKIPSEPRS FILE FILERDTBL)
(SETQ FILEMAPLOCADR (GETFILEPTR FILE))
(* Address of first character of file-map location)
(RATOM FILE FILERDTBL]
(SETQ FILEMAPADR (OR (FFILEPOS DECLARESTRING FILE (FIX (TIMES FILEMAPADR .9)))
(FFILEPOS DECLARESTRING FILE 0)))
(EQ (PROGN (SKREAD FILE)
(RATOM FILE FILERDTBL))
(QUOTE STOP))
(ILEQ (NCHARS FILEMAPADR T FILERDTBL)
7))
(* normally, this will be called so that we are positioned at the filemap. -
check for (FILECREATED & & number --) first to avoid searching compiled files for filemap.)
(CLOSEF FILE)
(OR [NLSETQ (OPENFILE FILE (QUOTE BOTH)
(QUOTE OLD)
NIL
(QUOTE (DON'T.CHANGE.DATE]
(PROGN (INFILE FILE)
(RETURN)))
(SETFILEPTR FILE FILEMAPADR)
(PRIN3 "(DECLARE: DONTCOPY
" FILE)
(SETQ FILEMAPADR (GETFILEPTR FILE))
(PRIN3 "(FILEMAP " FILE)
(POSITION FILE (CONSTANT (NCHARS "(FILEMAP ")))
(RESETFORM (RADIX 10)
(PRIN2 FILEMAP FILE FILERDTBL))
(PRIN1 "))" FILE)
(TERPRI FILE)
(PRINT (QUOTE STOP)
FILE)
(SETFILEPTR FILE FILEMAPLOCADR)
(PRIN3 " " FILE)
(SETFILEPTR FILE FILEMAPLOCADR)
(PRINTNUM (QUOTE (FIX 7))
FILEMAPADR FILE)
(COND
((NEQ DFNFLG T)
(PRIN3 "****rewrote file map for " T)
(PRINT FILE T T])
(USEDFREE
[NLAMBDA A (* wt: "22-FEB-78 23:19")
(* dummy defiition for loading files that contain caals to localvars into
makesys's thatdont have the compiler)
A])
(WRITEFILE
[LAMBDA (X FILE) (* DD: " 6-Oct-81 16:46")
(* X is a list of expression (or an atom that evaluates to a list) X is written on FILE. If X begins with a
PRINTDATE expression, a new one is written. Following the PRETTYDEF conventions, if FILE is listed, it is left open.
Otherwise a stop is printed and it is closed.)
(RESETFORM (SETREADTABLE FILERDTBL)
(PROG ((Y (OUTPUT))
Z)
(COND
((LISTP FILE)
(SETQ FILE (CAR FILE))
(SETQ Z T)))
(OUTFILE FILE)
[COND
((ATOM X)
(SETQ X (EVAL X]
(PRIN1 (QUOTE "
(PRIN1 (QUOTE %"
WRITEFILE OF "))
(PRIN2 (OUTPUT))
(PRIN1 (QUOTE " MADE BY "))
(PRIN1 (USERNAME))
(PRIN1 (QUOTE " ON "))
(PRIN1 (DATE))
(PRIN1 (QUOTE "
%")T)
"))
[MAPC X (FUNCTION (LAMBDA (X1)
(PRINTDEF X1 NIL (EQ (CAR (LISTP X1))
(QUOTE DEFINEQ)))
(TERPRI]
(SETQ FILE (OUTPUT Y))
(AND (NULL Z)
(ENDFILE FILE))
(RETURN FILE])
(XNLSETQ
[NLAMBDA (XNLSETQX XNLSETFLG XNLSETFN)
(ERRORSET XNLSETQX XNLSETFLG XNLSETFN])
(PROG2
[LAMBDA (FIRST SECOND) (* lmm "17-MAY-82 23:33")
SECOND])
)
(DEFINEQ
(RESETFORM
[NLAMBDA RESETZ (* lmm " 8-SEP-78 14:47")
(* Similar to RESETVAR. Permits evaluation of a form while resetting a system state, and provides for the system to
be returned to that state after evaluation. RESETX is a form, e.g. (OUTPUT T), (PRINTLEVEL 2) etc. RESETX is
evaluated and its value saved. Then RESETY is evaaluated under errorset protection and then
(CAR RESETX) is applied to the result of the evaluation of X. If an error occurs during the evaluation of FORM, the
effect of RESETX is still 'undone', If a control-D occurs during the evaluation of FORM, the effect of RESETX is
still undone by EVALQT because its effects are saved on RESETVARSLST.)
(PROG ((OLDVALUE (EVAL (CAR RESETZ)
(QUOTE INTERNAL)))
MACROX MACROY RESETSTATE)
(DECLARE (LOCALVARS MACROX MACROY))
(SETQ MACROX (SETQ RESETVARSLST (CONS (LIST (LIST (CAR (CAR RESETZ))
OLDVALUE))
RESETVARSLST)))
[COND
((NOT (XNLSETQ (SETQ MACROY (APPLY (FUNCTION PROGN)
(CDR RESETZ)
(QUOTE INTERNAL)))
INTERNAL))
(SETQ RESETSTATE (QUOTE ERROR]
(SETQ RESETVARSLST (CDR MACROX))
(APPLY (CAAR RESETZ)
(CDAAR MACROX))
(RETURN (COND
(RESETSTATE (ERROR!))
(T MACROY])
(RESETLST
[NLAMBDA RESETX (* wt: "25-JUN-79 01:32")
(* RESETLST and RESETSAVE together permit the user to combine the effects of several RESETVAR's and RESETFORM's
under one function. RESETLST acts like an ERRORSET which takes an indefinite number of forms, i.e. like PROGN, and
errorset protects them, and restores all RESETSAVE's performed while inside of RESETLST. It also adds the
appropriate entries to RESETVARSLST so that control-D will cause restoration. RESETLST compiles open.)
(PROG (RESETY RESETZ (LISPXHIST LISPXHIST))
[RESETRESTORE RESETVARSLST (COND
((SETQ RESETY (ERRORSET (CONS (QUOTE PROGN)
RESETX)
(QUOTE INTERNAL)))
NIL)
(T (QUOTE ERROR]
[COND
(RESETY (RETURN (CAR RESETY]
(ERROR!])
(RESETTOPVALS
[NLAMBDA RESETX (* lmm "25-FEB-82 15:24")
(DECLARE (SPECVARS RESETX))
(* RESETTOPVALS is a RESETVARS that uniformly saves and sets the topvals in both deep and shallow system.
It is to be used not for variables that are global for efficiency reasons, but for variables whose top-value is
defined to contain the desired information, e.g. filepkg COMS and FNS lists, and all other vars dumped by the VARS
and ADDVARS commands. In essence, it is a RESETLST with a bunch of RESETSAVEs for the variable lists.
Note that unlike RESETVARS, the body is a PROGN body, not a PROG body--no labels and no return.
Compiles open.)
(PROG (RESETY RESETZ (LISPXHIST LISPXHIST))
[RESETRESTORE RESETVARSLST (COND
((SETQ RESETY (ERRORSET (CONS (QUOTE PROGN)
(CONS (QUOTE (RESETTOPVALS1 (CAR RESETX)))
(CDR RESETX)))
(QUOTE INTERNAL)))
NIL)
(T (QUOTE ERROR]
[COND
(RESETY (RETURN (CAR RESETY]
(ERROR!])
(RESETTOPVALS1
[LAMBDA (VLIST) (* rmk: " 5-JAN-82 21:03")
(* Does the resetsaves for interpreted calls to
RESETTOPVALS)
(DECLARE (LOCALVARS . T))
(MAPC VLIST (FUNCTION (LAMBDA (V)
(APPLY (FUNCTION RESETSAVE)
V])
)
(PUTPROPS RESETTOPVALS INFO (EVAL BINDS))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: EQUALN EQUALN)
(BLOCK: SUBPAIR SUBPAIR)
(BLOCK: NIL PROMPTCHAR NAMEFIELD CLOSEF? CLBUFS BKBUFS (NOLINKFNS PRINTBELLS)
(LINKFNS . T)
(LOCALVARS . T))
]
(* * LVLPRINT)
(DEFINEQ
(LVLPRINT
[LAMBDA (X FILE CARLVL CDRLVL TAIL)
(* wt: 12-MAY-76 22 6)
(LVLPRIN2 X FILE CARLVL CDRLVL TAIL)
(TERPRI FILE)
X])
(LVLPRIN1
[LAMBDA (X FILE CARLVL CDRLVL TAIL)
(* wt: 12-MAY-76 22 6)
(PROG (PRIN2FLG)
(LVLPRIN X CARLVL CDRLVL TAIL)
(RETURN X])
(LVLPRIN2
[LAMBDA (X FILE CARLVL CDRLVL TAIL)
(* wt: 12-MAY-76 22 6)
(PROG ((PRIN2FLG T))
(LVLPRIN X CARLVL CDRLVL TAIL)
(RETURN X])
(LVLPRIN
[LAMBDA (X CARLVL CDRLVL TAIL) (* wt: 12-MAY-76 22 23)
(COND
[(NLISTP X)
(COND
((AND TAIL (EQ X (CDR (LAST TAIL)))
(NOT (MEMB X TAIL)))
(PRIN1 (QUOTE "... . ")
FILE)
(COND
(PRIN2FLG (PRIN2 X FILE T))
(T (PRIN1 X FILE)))
(* We use standard system read table for printing on grounds that even if this is going to a file, user is only
dumping it with bpnt to look at it, not to read it back in.)
(PRIN1 (QUOTE %))
FILE))
(PRIN2FLG (PRIN2 X FILE T))
(T (PRIN1 X FILE]
(T (PRIN1 (COND
((AND TAIL (TAILP X TAIL))
(* Tail)
(QUOTE "... "))
(T (QUOTE %()))
FILE)
(LVLPRIN0 X CARLVL CDRLVL)
(PRIN1 (QUOTE %))
FILE])
(LVLPRIN0
[LAMBDA (X CARLVL CDRLVL) (* lmm "11-OCT-81 21:49")
(* LVLPRIN0 is like subprint %. it prints the interior segment of a list)
(AND (EQ (CAR X)
CLISPTRANFLG)
(SETQ X (CDDR X)))
(PROG ((CDRLVL0 CDRLVL))
(GO LP1)
LP (COND
((NULL (SETQ X (CDR X)))
(RETURN))
((NLISTP X)
(PRIN1 (QUOTE " . ")
FILE)
(COND
(PRIN2FLG (PRIN2 X FILE T))
(T (PRIN1 X FILE)))
(RETURN))
(T (SPACES 1 FILE)))
LP1 (COND
((ZEROP CDRLVL)
(PRIN1 (QUOTE --)
FILE)
(RETURN))
[(NLISTP (CAR X))
(COND
(PRIN2FLG (PRIN2 (CAR X)
FILE T T))
(T (PRIN1 (CAR X)
FILE]
([OR (ZEROP CARLVL)
(AND CDRLVL0 (ZEROP (SUB1 CDRLVL0]
(* the reason for the second check is that why bother to recurse only to print
(--). & is better)
(PRIN1 (QUOTE &)
FILE))
((AND (EQ FILE T)
(SUPERPRINTEQ (CAAR X)
COMMENTFLG)
**COMMENT**FLG)
(PRIN1 **COMMENT**FLG FILE))
(T (PRIN1 (QUOTE %()
FILE)
(LVLPRIN0 (CAR X)
[AND CARLVL (IPLUS CARLVL (COND
((MINUSP CARLVL)
1)
(T -1]
(AND CDRLVL0 (SUB1 CDRLVL0)))
(PRIN1 (QUOTE %))
FILE)))
(AND CDRLVL (SETQ CDRLVL (SUB1 CDRLVL)))
(GO LP])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: LVLPRINTBLOCK LVLPRINT LVLPRIN1 LVLPRIN2 LVLPRIN LVLPRIN0 (ENTRIES LVLPRINT LVLPRIN1 LVLPRIN2)
(LOCALFREEVARS FILE PRIN2FLG))
]
(* * SUBLIS and friends)
(DEFINEQ
(SUBLIS
[LAMBDA (ALST EXPR FLG) (* lmm " 4-DEC-77 18:57")
(SUBLIS0 EXPR])
(SUBPAIR
[LAMBDA (OLD NEW EXPR FLG) (* lmm "25-FEB-82 15:29")
(COND
((LISTP EXPR)
([LAMBDA (D A)
(COND
((OR (NEQ A (CAR EXPR))
(NEQ D (CDR EXPR))
FLG)
(CONS A D))
(T EXPR]
(AND (CDR EXPR)
(SUBPAIR OLD NEW (CDR EXPR)
FLG))
(SUBPAIR OLD NEW (CAR EXPR)
FLG)))
(T (PROG NIL
LP (RETURN (COND
((NULL OLD)
EXPR)
((NLISTP OLD)
(COND
((EQ EXPR OLD)
(COND
(FLG (COPY NEW))
(T NEW)))
(T EXPR)))
[(EQ EXPR (CAR OLD))
(COND
(FLG (COPY (CAR NEW)))
(T (CAR NEW]
(T (SETQ OLD (CDR OLD))
(SETQ NEW (CDR NEW))
(GO LP])
(SUBLIS0
[LAMBDA (X) (* lmm " 9-DEC-77 12:40")
(COND
[(LISTP X)
([LAMBDA (D A)
(COND
((OR (NEQ A (CAR X))
(NEQ D (CDR X))
FLG)
(CONS A D))
(T X]
(AND (CDR X)
(SUBLIS0 (CDR X)))
(SUBLIS0 (CAR X]
(T (SUBLIS1 X])
(DSUBLIS
[LAMBDA (ALST EXPR FLG) (* lmm " 9-DEC-77 12:45")
(COND
((NLISTP EXPR)
(SUBLIS1 EXPR))
(T (DSUBLIS0 EXPR)
EXPR])
(SUBLIS1
[LAMBDA (X) (* lmm " 9-DEC-77 12:38")
(PROG ((Y (FASSOC X ALST)))
(RETURN (COND
[Y (COND
(FLG (COPY (CDR Y)))
(T (CDR Y]
(T X])
(DSUBLIS0
[LAMBDA (X) (* lmm " 9-DEC-77 12:45")
[COND
((LISTP (CAR X))
(DSUBLIS0 (CAR X)))
(T (FRPLACA X (SUBLIS1 (CAR X]
(COND
[(NLISTP (CDR X))
(COND
((CDR X)
(FRPLACD X (SUBLIS1 (CDR X]
(T (DSUBLIS0 (CDR X])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: SUBBLOCK DSUBLIS SUBLIS1 SUBLIS SUBLIS0 (LOCALFREEVARS ALST FLG)
(ENTRIES SUBLIS DSUBLIS)
DSUBLIS0)
]
(DECLARE: DONTEVAL@LOAD DOCOPY
(* initialization of variables used in many places)
(ADDTOVAR CLISPARRAY )
(ADDTOVAR CLISPFLG )
(ADDTOVAR CTRLUFLG )
(ADDTOVAR EDITCALLS )
(ADDTOVAR EDITHISTORY )
(ADDTOVAR EDITUNDOSAVES )
(ADDTOVAR EDITUNDOSTATS )
(ADDTOVAR GLOBALVARS )
(ADDTOVAR LCASEFLG )
(ADDTOVAR LISPXBUFS )
(ADDTOVAR LISPXCOMS )
(ADDTOVAR LISPXFNS )
(ADDTOVAR LISPXHIST )
(ADDTOVAR LISPXHISTORY )
(ADDTOVAR LISPXPRINTFLG )
(ADDTOVAR NOCLEARSTKLST )
(ADDTOVAR NOFIXFNSLST )
(ADDTOVAR NOFIXVARSLST )
(ADDTOVAR P.A.STATS )
(ADDTOVAR PROMPTCHARFORMS )
(ADDTOVAR READBUF )
(ADDTOVAR READBUFSOURCE )
(ADDTOVAR REREADFLG )
(ADDTOVAR RESETSTATE )
(ADDTOVAR SPELLINGS1 )
(ADDTOVAR SPELLINGS2 )
(ADDTOVAR SPELLINGS3 )
(ADDTOVAR SPELLSTATS1 )
(ADDTOVAR USERWORDS )
(RPAQQ CHCONLST (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))
(RPAQQ CHCONLST1 (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))
(RPAQQ CHCONLST2 (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))
(RPAQQ CLEARSTKLST T)
(RPAQQ CLISPTRANFLG CLISP% )
(RPAQ HISTSTR0 "<c.r.>")
(RPAQ HISTSTR2 "repeat")
(RPAQ HISTSTR3 "from event:")
(RPAQ HISTSTR4 "ignore")
(RPAQQ LISPXREADFN READ)
(RPAQQ USEMAPFLG T)
)
(* * CHARCODE)
(DEFINEQ
(CHARCODE
[NLAMBDA (C COMPFLG) (* rmk: " 1-SEP-81 06:25")
(* COMPFLG T b (* If COMPFLG=T we are being called from a macro and therefore use the compiler-dependent as opposed
to current-system-dependent EOL.))
(COND
((LISTP C)
(CONS (APPLY* (FUNCTION CHARCODE)
(CAR C)
COMPFLG)
(APPLY* (FUNCTION CHARCODE)
(CDR C)
COMPFLG)))
((NOT (OR (ATOM C)
(STRINGP C)))
(ERROR "BAD CHARACTER SPECIFICATION" C))
((EQ 1 (NCHARS C))
(CHCON1 C))
(T (SELCHARQ (NTHCHARCODE C 1)
(↑ (LOGAND 31 (APPLY* (FUNCTION CHARCODE)
(SUBATOM C 2 -1)
COMPFLG)))
(# (IPLUS 128 (APPLY* (FUNCTION CHARCODE)
(SUBATOM C 2 -1)
COMPFLG)))
(PROG ((CC C))
RETRY
(RETURN (SELECTQ CC
(NIL NIL)
(CR 13)
(LF 10)
((SPACE SP)
32)
(TENEXEOL 31)
(EOL (SELECTQ (COND
(COMPFLG (COMPILEMODE))
(T (SYSTEMTYPE)))
((D ALTO)
13)
31))
(BS 8)
(TAB 9)
(BELL 7)
((ESC ESCAPE)
27)
(NULL 0)
((RUBOUT DEL)
127)
((FF FORM)
12)
(COND
([NEQ CC (SETQ CC (U-CASE (COND
((STRINGP CC)
(MKATOM CC))
(T CC]
(GO RETRY))
(T (ERROR "BAD CHARACTER SPECIFICATION" C])
(SELCHARQ
[NLAMBDA SELC (* DD: " 6-Oct-81 17:05")
(DECLARE (LOCALVARS . T))
(for CLAUSE (CHAR ←(EVAL (pop SELC)
(QUOTE SELECTQ)))
in old SELC while (CDR SELC) when [COND
[(LISTP (CAR CLAUSE))
(* Do the LISTP case special so CHARCODE doesn't build list structure)
(SOME (CAR CLAUSE)
(FUNCTION (LAMBDA (C)
(EQ CHAR (APPLY* (FUNCTION CHARCODE)
C]
(T (EQ CHAR (APPLY* (FUNCTION CHARCODE)
(CAR CLAUSE]
do (RETURN (APPLY (FUNCTION PROGN)
(CDR CLAUSE)
(QUOTE SELECTQ)))
finally (RETURN (EVAL (CAR SELC)
(QUOTE SELECTQ])
)
(PUTPROPS CHARCODE MACRO (C (KWOTE (APPLY* (QUOTE CHARCODE)
(CAR C)
T))))
(PUTPROPS SELCHARQ MACRO [F (CONS (QUOTE SELECTQ)
(CONS (CAR F)
(MAPLIST (CDR F)
(FUNCTION (LAMBDA (I)
(COND
((CDR I)
(CONS (APPLY* (FUNCTION CHARCODE)
(CAAR I))
(CDAR I)))
(T (CAR I])
(PUTPROPS ALPHACHARP MACRO ((CHAR)
([LAMBDA (UCHAR)
(DECLARE (LOCALVARS UCHAR))
(AND (IGEQ UCHAR (CHARCODE A))
(ILEQ UCHAR (CHARCODE Z]
(LOGAND CHAR 95))))
(PUTPROPS DIGITCHARP MACRO [LAMBDA (CHAR)
(AND (IGEQ CHAR (CHARCODE 0))
(ILEQ CHAR (CHARCODE 9])
(PUTPROPS UCASECODE MACRO (OPENLAMBDA (CHAR)
(COND
((ALPHACHARP CHAR)
(LOGAND CHAR 95))
(T CHAR))))
(ADDTOVAR DWIMEQUIVLST (SELCHARQ . SELECTQ))
(ADDTOVAR PRETTYEQUIVLST (SELCHARQ . SELECTQ))
(* * CONSTANTS)
(DEFINEQ
(CONSTANTOK
[LAMBDA (X DEPTH) (* lmm " 1-OCT-78 22:03")
(OR DEPTH (SETQ DEPTH 100))
(COND
((OR (SMALLP X)
(STRINGP X)
(FLOATP X))
DEPTH)
((FIXP X)
(AND (NOT (SMALLP (IPLUS X)))
DEPTH))
((LITATOM X)
(AND (IGREATERP (NCHARS X)
0)
DEPTH))
((LISTP X)
(AND (SETQ DEPTH (CONSTANTOK (CAR X)
(SUB1 DEPTH)))
(CONSTANTOK (CDR X)
DEPTH])
)
(MOVD? (QUOTE EVQ)
(QUOTE CONSTANT))
(MOVD? (QUOTE EVQ)
(QUOTE DEFERREDCONSTANT))
(* * SCRATCHLIST)
(DEFINEQ
(ADDTOSCRATCHLIST
[LAMBDA (VALUE) (* lmm "17-JAN-78 16:27")
(FRPLACA [SETQ !SCRATCHTAIL (OR (LISTP (CDR !SCRATCHTAIL))
(CDR (FRPLACD !SCRATCHTAIL (CONS]
VALUE])
(SCRATCHLIST
[NLAMBDA ARGS (* rmk: "23-JAN-79 21:54")
([LAMBDA (!SCRATCHLIST !SCRATCHTAIL)
(DECLARE (SPECVARS !SCRATCHLIST !SCRATCHTAIL))
(SETQ !SCRATCHTAIL !SCRATCHLIST)
(APPLY (FUNCTION PROGN)
(CDR ARGS)
(QUOTE INTERNAL))
(COND
((EQ !SCRATCHTAIL !SCRATCHLIST)
NIL)
(T (PROG ((L2 (CDR !SCRATCHLIST)))
(RPLACD !SCRATCHLIST (PROG1 (CDR !SCRATCHTAIL)
(RPLACD !SCRATCHTAIL NIL)))
(FRPLACD (FLAST !SCRATCHLIST)
L2)
(RETURN L2]
(OR (LISTP (EVAL (CAR ARGS)
(QUOTE INTERNAL)))
(CONS))
NIL])
)
(PUTPROPS SCRATCHLIST MACRO ((SCRATCHLIST . FORMS)
([LAMBDA (!SCRATCHLIST !SCRATCHTAIL)
(DECLARE (SPECVARS !SCRATCHLIST !SCRATCHTAIL))
(SETQ !SCRATCHTAIL !SCRATCHLIST)
(PROGN . FORMS)
(COND
((EQ !SCRATCHTAIL !SCRATCHLIST)
NIL)
(T (PROG ((L2 (CDR !SCRATCHLIST)))
(RPLACD !SCRATCHLIST (PROG1 (CDR !SCRATCHTAIL)
(RPLACD !SCRATCHTAIL NIL)))
(FRPLACD (FLAST !SCRATCHLIST)
L2)
(RETURN L2]
(OR (LISTP SCRATCHLIST)
(CONS))
NIL)))
(PUTPROPS ADDTOSCRATCHLIST MACRO ((VALUE)
(FRPLACA [SETQ !SCRATCHTAIL (OR (LISTP (CDR !SCRATCHTAIL))
(CDR (FRPLACD !SCRATCHTAIL
(CONS]
VALUE)))
(PUTPROPS SCRATCHLIST INFO EVAL)
(* * COMPARE)
(DEFINEQ
(COMPARELST
[LAMBDA (X Y LOOSEMATCH) (* lmm "29-AUG-78 19:01")
[COND
((EQ LOOSEMATCH -1)
(SETQ LOOSEMATCH (COMPAREMAX X Y]
(COMPARE1 X Y])
(COMPARE1
[LAMBDA (X Y) (* lmm "29-AUG-78 18:35")
(* returns T if X and Y are similar; if LOOSEMATCH then sets DIFFERENCES to
changes)
(AND [OR (EQ X Y)
(COND
[(LISTP X)
(COND
[(LISTP Y)
(OR (AND (EQ (CAR X)
COMMENTFLG)
(EQ (CAR Y)
COMMENTFLG))
(PROG NIL
LP (RETURN (COND
((NLISTP X)
(OR (EQUAL X Y)
(COMPAREFAIL X Y)))
((NLISTP Y)
(COMPAREFAIL X Y))
((NOT (COMPARE1 (CAR X)
(CAR Y)))
NIL)
(T (SETQ X (CDR X))
(SETQ Y (CDR Y))
(GO LP]
(T (COMPAREFAIL X Y]
(T (OR (EQUAL X Y)
(COMPAREFAIL X Y]
(OR LOOSEMATCH T])
(COMPAREPRINT
[LAMBDA (X Y) (* rrb "22-JUL-83 12:28")
(RESETFORM (PRINTLEVEL 1 1)
(PROG ((PLVLFILEFLG T)
FIN)
(COND
((EQUAL X Y)
(RETURN NIL)))
(COND
((OR (NLISTP X)
(NLISTP Y))
(PRINT X)
(PRINT Y)
(GO FIN)))
(PRIN1 (QUOTE %()) (* Print list X by comparison with list Y)
(COMPAREPRINT1 X Y)
(PRIN1 (QUOTE %)))
(TERPRI)
(PRIN1 (QUOTE %()) (* Do same for other list)
(COMPAREPRINT1 Y X)
(PRIN1 (QUOTE %)))
(TERPRI)
FIN (RETURN T])
(COMPAREPRINT1
[LAMBDA (A B) (* DD: "28-FEB-83 08:29")
(PROG (X Y SPACE DOTFLAG L1 X1 Y1 (N 0)
K)
(SETQ X1 A)
(SETQ Y1 B)
L1 [COND
(DOTFLAG (SETQ X X1)
(SETQ Y Y1))
(T (SETQ X (CAR X1))
(SETQ Y (CAR Y1]
[COND
((EQ (SETQ K (COMPAREMAX X Y))
(SETQ K (COMPARELST X Y K)))
(* If two sublists are the same just type "&")
(COND
((AND (NOT SPACE)
(LITATOM X)
(EQ N 0))
(PRIN2 X)
(GO NX1))
(T (ADD1VAR N)
(GO NX]
(COMPAREPRINTN N SPACE T)
(SETQ N 0)
(COND
((OR (NLISTP X)
(NLISTP Y)))
[(EQ (CAR X)
COMMENTFLG)
(PRIN1 **COMMENT**FLG)
(COND
((NEQ (CAR Y)
COMMENTFLG)
(SETQ X1 (CDR X1))
(GO L1]
((EQ (CAR Y)
COMMENTFLG)
(SPACES (NCHARS **COMMENT**FLG))
(SETQ Y1 (CDR Y1))
(GO L1)))
[AND (NULL K)
(NULL DOTFLAG)
(COND
((AND (LISTP (CDR X1))
(COMPARELST (CADR X1)
Y -1))
(PRIN2 X)
(SETQ X1 (CDR X1))
(GO L1))
((AND (LISTP (CDR Y1))
(COMPARELST (CADR Y1)
X -1))
(SPACES (NCHARS (CAR Y1)
T))
(SETQ Y1 (CDR Y1))
(GO L1]
[COND
((OR (NLISTP X)
(NLISTP Y)) (* If they are unequal and one is not a list let PRIN2 type out something
(atom or list))
(PRIN2 X))
(T (PRIN1 (QUOTE %())
(* Otherwise print "()" and subanalyze)
(COMPAREPRINT1 X Y)
(PRIN1 (QUOTE %)]
NX1 (SETQ SPACE T)
NX (COND
((OR DOTFLAG (NOT (CDR X1)))
(* X list ran out)
(COMPAREPRINTN N SPACE))
(T (SETQ DOTFLAG (NLISTP (CDR X1)))
(COND
((CDR Y1)
(SETQ X1 (CDR X1))
(SETQ Y1 (CDR Y1))
(GO L1)))
(COMPAREPRINTN N SPACE)
(COND
(DOTFLAG (PRIN1 (QUOTE " . "))
(PRIN2 (CDR X1)))
(T (SPACES 1)
(PRIN2 (CADR X1))
(AND (CDDR X1)
(PRIN1 (QUOTE " --"])
(COMPARELISTS
[LAMBDA (X Y) (* lmm "29-AUG-78 18:29")
(* functionally equivalent to CPLISTS)
(RESETFORM (OUTPUT T)
(PROG (DIFFERENCES)
[COND
((NOT (COMPARELST X Y T))
(COMPAREPRINT X Y))
[DIFFERENCES (MAPC DIFFERENCES (FUNCTION (LAMBDA (X)
(PRIN2 X)
(SPACES 1]
(T (PRIN1 (QUOTE SAME]
(TERPRI])
(COMPAREPRINTN
[LAMBDA (N SPACE FLG) (* lmm "29-AUG-78 18:18")
[COND
((NEQ N 0)
(COND
(SPACE (SPACES 1))
(T (SETQ SPACE T)))
(SELECTQ N
(1 (PRIN1 (QUOTE &)))
(PROGN (COND
((NOT (ILESSP (IPLUS (POSITION)
7)
(LINELENGTH)))
(TERPRI)))
(PRIN1 (QUOTE -))
(PRIN2 N)
(PRIN1 (QUOTE -]
(AND FLG SPACE (SPACES 1])
(COMPAREFAIL
[LAMBDA (X Y) (* lmm "30-AUG-78 02:19")
(OR [SOME COMPARETRANSFORMS (FUNCTION (LAMBDA (FN)
(APPLY* FN X Y]
(AND LOOSEMATCH (COND
((NUMBERP LOOSEMATCH)
(IGREATERP [SETQ LOOSEMATCH (COUNTDOWN Y (COUNTDOWN X (SUB1 LOOSEMATCH]
0))
([AND (NLISTP X)
(OR (NLISTP Y)
(EVERY Y (FUNCTION NLISTP]
(PROG ((OLD (FASSOC X DIFFERENCES)))
[COND
(OLD (RETURN (EQUAL Y (CADDR OLD]
(RETURN (SETQ DIFFERENCES (NCONC1 DIFFERENCES (SETQ Y (LIST X (QUOTE ->)
Y])
(COMPAREMAX
[LAMBDA (X Y) (* lmm "30-AUG-78 02:19")
(IQUOTIENT (IDIFFERENCE 65 (IPLUS (COUNTDOWN X 30)
(COUNTDOWN Y 30)))
5])
(COUNTDOWN
[LAMBDA (X N) (* lmm "30-AUG-78 02:37")
(COND
((OR (NLISTP X)
(NOT (IGREATERP N 0)))
N)
(T (COUNTDOWN (CDR X)
(COUNTDOWN (CAR X)
(SUB1 N])
)
(ADDTOVAR COMPARETRANSFORMS )
(DECLARE: EVAL@COMPILE DONTCOPY
(PUTPROPS COUNTDOWN BLKLIBRARYDEF [LAMBDA (X N)
(LOC (ASSEMBLE NIL (CQ X)
(CQ2 (VAG N))
(PUSHJ CP , COUNT1)
(MOVE 1 , 2)
(JRST OUT)
A
(PUSHP)
(CAR1)
(PUSHJ CP , COUNT1)
(POPP)
(CDR1)
COUNT1
(JUMPLE 2 , R)
(STN (QUOTE LISTT))
(SOJG 2 , A)
R
(RET)
OUT])
(ADDTOVAR BLKLIBARY COUNTDOWN)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: COMPARELISTSBLOCK COMPARELISTS COMPARELST COMPARE1 COMPAREPRINT COMPAREPRINT1 COMPAREMAX
(ENTRIES COMPARELISTS COMPARELST)
(GLOBALVARS COMPARETRANSFORMS)
(LOCALFREEVARS DIFFERENCES LOOSEMATCH)
(NOLINKFNS . T)
COMPAREPRINTN COMPAREFAIL (GLOBALVARS COMMENTFLG **COMMENT**FLG))
(BLOCK: COUNTDOWN COUNTDOWN)
]
(* * MIN and MAX)
(DEFINEQ
(FLESSP
[LAMBDA (X Y)
(FGREATERP Y X])
(FMAX
[LAMBDA K (* lmm "28-SEP-81 10:23")
(COND
((ZEROP K)
MIN.FLOAT)
(T (PROG ((J 1)
(X (FLOAT (ARG K 1)))
Y)
(OR (NUMBERP X)
(ERRORX (LIST 10 X)))
LP (COND
((EQ J K)
(RETURN X)))
(ADD1VAR J)
(COND
((FGREATERP (SETQ Y (FLOAT (ARG K J)))
X)
(SETQ X Y)))
(GO LP])
(FMIN
[LAMBDA K (* lmm "28-SEP-81 10:23")
(COND
((ZEROP K)
MAX.FLOAT)
(T (PROG ((J 1)
(X (FLOAT (ARG K 1)))
Y)
(OR (NUMBERP X)
(ERRORX (LIST 10 X)))
LP (COND
((EQ J K)
(RETURN X)))
(ADD1VAR J)
(COND
([FGREATERP X (SETQ Y (FLOAT (ARG K J]
(SETQ X Y)))
(GO LP])
(GEQ
[LAMBDA (X Y)
(NOT (LESSP X Y])
(IGEQ
[LAMBDA (X Y)
(NOT (ILESSP X Y])
(ILEQ
[LAMBDA (X Y)
(NOT (IGREATERP X Y])
(IMAX
[LAMBDA K (* lmm "24-JAN-80 14:25")
(COND
((ZEROP K)
MIN.INTEGER)
(T (PROG ((J 1)
(X (ARG K 1)))
LP (COND
((EQ J K)
(RETURN X)))
(ADD1VAR J)
[COND
((ILESSP X (ARG K J))
(SETQ X (ARG K J]
(GO LP])
(IMIN
[LAMBDA K (* lmm "24-JAN-80 14:25")
(COND
((ZEROP K)
MAX.INTEGER)
(T (PROG ((J 1)
(X (ARG K 1)))
LP (COND
((EQ J K)
(RETURN X)))
(ADD1VAR J)
[COND
((IGREATERP X (ARG K J))
(SETQ X (ARG K J]
(GO LP])
(LEQ
[LAMBDA (X Y)
(NOT (GREATERP X Y])
(MAX
[LAMBDA K (* lmm "24-JAN-80 14:15")
(COND
((ZEROP K)
MIN.FLOAT)
(T (PROG ((J 1)
(X (ARG K 1))
Y)
(OR (NUMBERP X)
(ERRORX (LIST 10 X)))
LP (COND
((EQ J K)
(RETURN X)))
(ADD1VAR J)
(COND
((GREATERP (SETQ Y (ARG K J))
X)
(SETQ X Y)))
(GO LP])
(MIN
[LAMBDA K (* lmm "24-JAN-80 14:14")
(COND
((ZEROP K)
MAX.FLOAT)
(T (PROG ((J 1)
(X (ARG K 1))
Y)
(OR (NUMBERP X)
(ERRORX (LIST 10 X)))
LP (COND
((EQ J K)
(RETURN X)))
(ADD1VAR J)
(COND
((GREATERP X (SETQ Y (ARG K J)))
(SETQ X Y)))
(GO LP])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS MAX.INTEGER MIN.INTEGER MAX.FLOAT MIN.FLOAT)
)
(DEFINEQ
(POWEROFTWOP
[LAMBDA (X)
(DECLARE (LOCALVARS . T)) (* JonL "18-OCT-82 21:09")
(* Non-NIL iff arg is some power of 2)
(* Extend this to Bignums someday)
(SELECTQ (SYSTEMTYPE)
[D (* Hacked for Interlisp-D so as not to do any consing.)
(SELECTC (NTYPX X)
(\SMALLP (if (IGREATERP X 0)
then (.2↑NP. X)))
[\FIXP (PROG ((HX (fetch (FIXP HINUM) of X))
(LX (fetch (FIXP LONUM) of X)))
(RETURN (if (ZEROP HX)
then (.2↑NP. LX)
elseif (ZEROP LX)
then (AND (NEQ HX \SIGNBIT)
(.2↑NP. HX]
(POWEROFTWOP (FIX X]
(if (IGREATERP X 0)
then (.2↑NP. X])
(IMOD
[LAMBDA (X N) (* lmm "20-OCT-82 15:07")
(COND
((IGEQ (SETQ X (IREMAINDER X N))
0)
X)
(T (IPLUS N X])
(EVENP
(LAMBDA X (* JonL "29-OCT-82 22:34")
(ZEROP (IMOD (ARG X 1)
(if (EQ X 2)
then (ARG X 2)
else 2)))))
(ODDP
(LAMBDA X (* JonL "29-OCT-82 22:34")
(NOT (ZEROP (IMOD (ARG X 1)
(if (EQ X 2)
then (ARG X 2)
else 2))))))
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS .2↑NP. MACRO [(X)
(ZEROP (LOGAND X (SUB1 X])
)
)
(* * WHENCLOSE)
(DEFINEQ
(AFTERCLOSE
[LAMBDA (FILE) (* rmk "24-APR-79 15:32")
(DECLARE (LOCALVARS . T))
[MAPC (GETPROP FILE (QUOTE AFTERCLOSE))
(FUNCTION (LAMBDA (FN)
(APPLY* FN FILE]
(REMPROPLIST FILE (QUOTE (BEFORECLOSE AFTERCLOSE CLOSEALL STATUSFN EOFCLOSE)))
FILE])
(EOFCLOSEF
[LAMBDA (FILE) (* rmk: "23-FEB-82 21:28")
(DECLARE (LOCALVARS . T))
(PROG (VAL FULLNAME) (* We are called with the user argument to the reading
function, which can be NIL. Hence, we have to find the
FULLNAME ourselves.)
[SETQ FULLNAME (COND
((NOT (LITATOM FILE)) (* Special check cause OPENP bombs on strings on the 10)
(RETURN (CLOSEF FILE)))
(FILE
(* Don't bother doing anything if it's already closed; somebody must have gotten confused, tried to close twice, and
we probably were run the first time.)
(OR (OPENP FILE (QUOTE INPUT))
(RETURN)))
((INPUT]
(COND
([AND (LITATOM FULLNAME)
(SETQ VAL (GETPROP FULLNAME (QUOTE EOFCLOSE]
(* LITATOM test so don't get an error from GETPROP; CLOSEF will handle any other cases (e.g. strings). Note that a
string can come from INPUT, even if LITATOM test up above fails.)
(APPLY* VAL FULLNAME))
(T (CLOSEF FULLNAME])
(WHENCLOSE
[LAMBDA NARGS (* rmk: " 8-OCT-79 22:44")
(DECLARE (LOCALVARS . T))
(PROG [FILE (ARG1 (AND (IGREATERP NARGS 0)
(ARG NARGS 1]
(OR [COND
[ARG1 (AND (NEQ ARG1 T)
(SETQ FILE (OPENP ARG1]
[(NEQ T (SETQ FILE (INPUT]
((NEQ T (SETQ FILE (OUTPUT]
(ERRORX (LIST 13 ARG1)))
[for I FN from 2 to NARGS by 2 do [SETQ FN (AND (IGREATERP NARGS I)
(ARG NARGS (ADD1 I]
(SELECTQ (ARG NARGS I)
[CLOSEALL (PUTPROP FILE (QUOTE CLOSEALL)
(SELECTQ FN
(NO T)
(YES NIL)
(ERRORX
(LIST 27 FN]
[BEFORE (COND
(FN (ADDPROP FILE (QUOTE BEFORECLOSE)
FN T]
[AFTER (COND
(FN (ADDPROP FILE (QUOTE AFTERCLOSE)
FN T]
(STATUS (PUTPROP FILE (QUOTE STATUSFN)
FN))
(EOF (PUTPROP FILE (QUOTE EOFCLOSE)
FN))
(ERRORX (LIST 27 (ARG NARGS I]
(RETURN FILE])
(CLOSEALL
[LAMBDA (ALLFLG) (* wt: "24-JUL-78 23:03")
(DECLARE (LOCALVARS . T))
(* The OPENP in the when catches the case where a WHENCLOSE on an earlier file closes a later file in the original
value of OPENP)
(MAPCONC (OPENP)
(FUNCTION (LAMBDA (FL)
(AND (OPENP FL)
[OR ALLFLG (NOT (GETPROP FL (QUOTE CLOSEALL]
(LIST (CLOSEF FL])
(NEWCLOSEF
[LAMBDA (FILE) (* rmk: "12-MAR-82 23:07")
(PROG (FULLNAME)
[SETQ FULLNAME (COND
((NOT (LITATOM FILE))
(RETURN (OLDCLOSEF FILE)))
[FILE (OR (OPENP FILE)
(ERRORX (LIST 13 FILE]
((NEQ (SETQ FULLNAME (INPUT))
T)
FULLNAME)
(T (OUTPUT]
(RETURN (COND
((AND (LITATOM FULLNAME)
(GETPROPLIST FULLNAME)) (* LITATOM test because to avoid strings on Dorado.
Eventually should have a machinedependent way of
accessing the whenclose properties)
[MAPC (GETPROP FULLNAME (QUOTE BEFORECLOSE))
(FUNCTION (LAMBDA (FN)
(APPLY* FN FULLNAME]
(AFTERCLOSE (OLDCLOSEF FULLNAME)))
(T (OLDCLOSEF FULLNAME])
(RESTOREFILES
[LAMBDA (BEFOREFLG) (* rmk "24-APR-79 15:32")
(* Saves file state if BEFOREFLG, which is the call before sysout. Restores file state if not BEFOREFLG, which is
the call from aftersysout forms)
(COND
[BEFOREFLG (SETQ RESTOREFILELST (PROG ((LST (OPENP))
VAL FL FN)
LP [SETQ FL (CAR (OR (LISTP LST)
(RETURN (ENDCOLLECT VAL]
[COND
((OR (SETQ FN (GETPROP FL (QUOTE STATUSFN)))
(GETPROP FL (QUOTE AFTERCLOSE)))
(SETQ VAL (DOCOLLECT (CONS FL
(AND FN (APPLY* FN FL)))
VAL]
(SETQ LST (CDR LST))
(GO LP]
(T [MAPC RESTOREFILELST (FUNCTION (LAMBDA (R)
(COND
[(CDR R)
(COND
((APPLY (CADR R)
(CDDR R)))
(T (AFTERCLOSE (CAR R))
(LISPXPRIN1 "*****WARNING: Couldn't restore file " T)
(LISPXPRINT (CAR R)
T]
(T (AFTERCLOSE (CAR R]
(SETQ RESTOREFILELST NIL])
)
(PUTPROPS WHENCLOSE ARGNAMES (NIL (FILE PROPNAME FN ...) . NARGS))
(ADDTOVAR BEFORESYSOUTFORMS (RESTOREFILES T))
(ADDTOVAR AFTERSYSOUTFORMS (RESTOREFILES))
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD? (QUOTE CLOSEF)
(QUOTE OLDCLOSEF))
(MOVD (QUOTE NEWCLOSEF)
(QUOTE CLOSEF))
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL AFTERCLOSE EOFCLOSEF WHENCLOSE CLOSEALL NEWCLOSEF RESTOREFILES (LOCALVARS . T)
(GLOBALVARS RESTOREFILELST))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS SYSFILES LOADOPTIONS UPDATEMAPFLG LISPXCOMS CLISPTRANFLG COMMENTFLG
**COMMENT**FLG HISTSTR4 LISPXREADFN REREADFLG HISTSTR0 FILEPKGFLG CTRLUFLG NOLINKMESS
PROMPTCHARFORMS PROMPT#FLG USEMAPFLG FILERDTBL BUILDMAPFLG DFNFLG ERRORTYPELST SPELLINGS2
DWIMFLG USERWORDS ADDSPELLFLG BELLS LISPXPRINTFLG CLISPARRAY)
)
[COND (SHALLOWFLG (MOVD (QUOTE EVALV)
(QUOTE GETATOMVAL))
(MOVD (QUOTE SET)
(QUOTE SETATOMVAL))
(MOVD (QUOTE PROG)
(QUOTE RESETVARS)))
(T (MOVD (QUOTE GETTOPVAL)
(QUOTE GETATOMVAL))
(MOVD (QUOTE SETTOPVAL)
(QUOTE SETATOMVAL]
[MAPC (QUOTE ((APPLY BLKAPPLY)
(APPLY* BLKAPPLY*)
(RPLACA FRPLACA)
(RPLACD FRPLACD)
(STKNTH FSTKNTH)
(STKNAME FSTKNAME)
(CHARACTER FCHARACTER)
(STKARG FSTKARG)
(CHCON DCHCON)
(UNPACK DUNPACK)
(ADDPROP /ADDPROP)
(ATTACH /ATTACH)
(DREMOVE /DREMOVE)
(DSUBST /DSUBST)
(NCONC /NCONC)
(NCONC1 /NCONC1)
(PUT /PUT)
(PUTPROP /PUTPROP)
(PUTD /PUTD)
(REMPROP /REMPROP)
(RPLACA /RPLACA)
(RPLACD /RPLACD)
(SET /SET)
(SETATOMVAL /SETATOMVAL)
(SETTOPVAL /SETTOPVAL)
(SETPROPLIST /SETPROPLIST)
(SET SAVESET)
(PRINT LISPXPRINT)
(PRIN1 LISPXPRIN1)
(PRIN2 LISPXPRIN2)
(SPACES LISPXSPACES)
(TAB LISPXTAB)
(TERPRI LISPXTERPRI)
(PRINT SHOWPRINT)
(PRIN2 SHOWPRIN2)
(PUTHASH /PUTHASH)
(QUOTE *)
(FNCLOSER /FNCLOSER)
(FNCLOSERA /FNCLOSERA)
(FNCLOSERD /FNCLOSERD)
(EVQ DELFILE)
(NILL SMASHFILECOMS)
(PUTASSOC /PUTASSOC)
(LISTPUT1 PUTL)
(NILL I.S.OPR)
(NILL RESETUNDO)
(NILL LISPXWATCH)
(QUOTE ADDSTATS)))
(FUNCTION (LAMBDA (X)
(MOVD? (CAR X)
(CADR X]
[MAPC (QUOTE ((TIME PRIN1 LISPXPRIN1)
(TIME SPACES LISPXSPACES)
(TIME PRINT LISPXPRINT)
(DEFC PRINT LISPXPRINT)
(DEFC PUTD /PUTD)
(DEFC PUTPROP /PUTPROP)
(DOLINK FNCLOSERD /FNCLOSERD)
(DOLINK FNCLOSERA /FNCLOSERA)
(DEFLIST PUTPROP /PUTPROP)
(SAVEDEF1 PUTPROP /PUTPROP)
(MKSWAPBLOCK PUTD /PUTD)))
(FUNCTION (LAMBDA (X)
(AND (CCODEP (CAR X))
(APPLY (QUOTE CHANGENAME)
X]
(COND ((NOT (MEMB (QUOTE HIST)
SYSFILES))
(SAVEDEF (QUOTE EVALQT))
[PUTDQ EVALQT (LAMBDA NIL (PROG (TEM)
(COND [(EQ CLEARSTKLST T)
(COND ((EQ NOCLEARSTKLST NIL)
(* Follwoing control-d Do a CLEARSTK. Standard
case.)
(CLEARSTK))
(T (* clear all stack pointers EXCEPT those on
NOCLEARSTKLST.)
(MAPC (CLEARSTK T)
(FUNCTION (LAMBDA
(X)
(AND (NOT (FMEMB X
NOCLEARSTKLST))
(RELSTK X]
(T (* clear only those stack pointers on CLEARSTKLST
BREAK1, ERRORX2 SAVESET, and a few other system
functions store frames on this list that can be
eliminated after a control-D.)
(MAPC CLEARSTKLST (FUNCTION RELSTK))
(SETQ CLEARSTKLST NIL)))
(RESETRESTORE NIL (QUOTE RESET))
LP
(PROMPTCHAR (QUOTE ←)
T)
(LISPX (LISPXREAD T T))
(GO LP]
(SETQ DFNFLG NIL)))
(PUTDQ? LISPX [LAMBDA (LISPXX)
(PRINT [AND LISPXX (PROG (LISPXLINE LISPXHIST TEM)
(RETURN (COND ((AND (NLISTP LISPXX)
(SETQ LISPXLINE
(READLINE T NIL T)))
(APPLY LISPXX (CAR LISPXLINE)))
(T (EVAL LISPXX]
T T])
[PUTDQ? LISPXREAD (LAMBDA (FILE RDTBL)
(COND [READBUF (PROG1 (CAR READBUF)
(SETQ READBUF (CDR READBUF]
(T (READ FILE RDTBL]
[PUTDQ? LISPXREADP (LAMBDA (FLG)
(COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF)))
T)
(T (READP T FLG]
[PUTDQ? LISPXUNREAD (LAMBDA (LST)
(SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF]
[PUTDQ? LISPXREADBUF (LAMBDA (RDBUF)
(PROG NIL LP (COND ((NLISTP RDBUF)
(RETURN NIL))
((EQ (CAR RDBUF)
HISTSTR0)
(SETQ RDBUF (CDR RDBUF))
(GO LP))
(T (RETURN RDBUF]
(PUTDQ? LISPX/ [LAMBDA (X)
X])
[PUTDQ? LOWERCASE (LAMBDA (FLG)
(PROG1 LCASEFLG (RAISE (NULL FLG))
(RPAQ LCASEFLG FLG]
[PUTDQ? FILEPOS (LAMBDA (STR FILE)
(PROG NIL LP (COND ((EQ (PEEKC FILE)
(NTHCHAR STR 1))
(RETURN T)))
(READC FILE)
(GO LP]
(PUTDQ? FILEPKGCOM [NLAMBDA NIL NIL])
(SETSYNTAX 0 (QUOTE SEPR)
FILERDTBL)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA SCRATCHLIST SELCHARQ RESETTOPVALS RESETLST RESETFORM USEDFREE RESETBUFS DMPHASH
FILESLOAD)
(ADDTOVAR NLAML CHARCODE XNLSETQ FILEMAP)
(ADDTOVAR LAMA WHENCLOSE ODDP EVENP MIN MAX IMIN IMAX FMIN FMAX NLIST)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS MACHINEINDEPENDENT COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (9725 13634 (LOAD? 9735 . 9918) (FILESLOAD 9920 . 10274) (DOFILESLOAD 10276 . 13632)) (
13635 15425 (DMPHASH 13645 . 14285) (HASHOVERFLOW 14287 . 15423)) (15426 42292 (BKBUFS 15436 . 16419)
(CONCATLIST 16421 . 16689) (CHANGENAME 16691 . 16901) (CHNGNM 16903 . 18435) (CLBUFS 18437 . 19626) (
CLOSEF? 19628 . 19851) (DEFINE 19853 . 21519) (EQMEMB 21521 . 21655) (EQUALN 21657 . 22384) (FILEDATE
22386 . 23864) (FILEMAP 23866 . 24012) (FNCHECK 24014 . 24822) (FNTYP1 24824 . 24914) (FREEVARS 24916
. 25141) (GETFILEMAP 25143 . 26189) (LCSKIP 26191 . 26769) (LDIFFERENCE 26771 . 27176) (MAPRINT 27178
. 27877) (MKLIST 27879 . 27995) (NAMEFIELD 27997 . 28648) (NLIST 28650 . 28854) (PRINTBELLS 28856 .
28955) (PROMPTCHAR 28957 . 30525) (PUTFILEMAP 30527 . 31123) (RAISEP 31125 . 31368) (READFILE 31370 .
31681) (READLINE 31683 . 36182) (REMPROPLIST 36184 . 36832) (RESETBUFS 36834 . 37150) (TAB 37152 .
37544) (UNSAVED1 37546 . 38378) (UNSAVEDEF 38380 . 38666) (UPDATEFILEMAP 38668 . 40768) (USEDFREE
40770 . 41019) (WRITEFILE 41021 . 42097) (XNLSETQ 42099 . 42196) (PROG2 42198 . 42290)) (42293 46002 (
RESETFORM 42303 . 43679) (RESETLST 43681 . 44522) (RESETTOPVALS 44524 . 45625) (RESETTOPVALS1 45627 .
46000)) (46280 49085 (LVLPRINT 46290 . 46474) (LVLPRIN1 46476 . 46677) (LVLPRIN2 46679 . 46884) (
LVLPRIN 46886 . 47670) (LVLPRIN0 47672 . 49083)) (49302 51134 (SUBLIS 49312 . 49412) (SUBPAIR 49414 .
50143) (SUBLIS0 50145 . 50459) (DSUBLIS 50461 . 50628) (SUBLIS1 50630 . 50831) (DSUBLIS0 50833 . 51132
)) (52788 54953 (CHARCODE 52798 . 54205) (SELCHARQ 54207 . 54951)) (55901 56350 (CONSTANTOK 55911 .
56348)) (56471 57324 (ADDTOSCRATCHLIST 56481 . 56686) (SCRATCHLIST 56688 . 57322)) (58122 63783 (
COMPARELST 58132 . 58311) (COMPARE1 58313 . 59098) (COMPAREPRINT 59100 . 59779) (COMPAREPRINT1 59781
. 61941) (COMPARELISTS 61943 . 62395) (COMPAREPRINTN 62397 . 62787) (COMPAREFAIL 62789 . 63370) (
COMPAREMAX 63372 . 63556) (COUNTDOWN 63558 . 63781)) (64682 67027 (FLESSP 64692 . 64740) (FMAX 64742
. 65124) (FMIN 65126 . 65497) (GEQ 65499 . 65545) (IGEQ 65547 . 65595) (ILEQ 65597 . 65648) (IMAX
65650 . 65948) (IMIN 65950 . 66251) (LEQ 66253 . 66302) (MAX 66304 . 66667) (MIN 66669 . 67025)) (
67131 68647 (POWEROFTWOP 67141 . 68045) (IMOD 68047 . 68235) (EVENP 68237 . 68437) (ODDP 68439 . 68645
)) (68781 73547 (AFTERCLOSE 68791 . 69101) (EOFCLOSEF 69103 . 70262) (WHENCLOSE 70264 . 71323) (
CLOSEALL 71325 . 71746) (NEWCLOSEF 71748 . 72548) (RESTOREFILES 72550 . 73545)))))
STOP