(FILECREATED " 2-Sep-85 13:21:16" {ERIS}<LISPCORE>SOURCES>MACHINEINDEPENDENT.;45 81297
changes to: (FNS LOAD?)
previous date: "16-Aug-85 04:56:58" {ERIS}<LISPCORE>SOURCES>MACHINEINDEPENDENT.;44)
(* Copyright (c) 1983, 1984, 1985 by Xerox Corporation. All rights reserved. The following program was
created in 1983 but has not been published within the meaning of the copyright law, is furnished
under license, and may not be used, copied and/or disclosed except in accordance with the terms of
said license.)
(PRETTYCOMPRINT MACHINEINDEPENDENTCOMS)
(RPAQQ MACHINEINDEPENDENTCOMS ((COMS (* * random machine-independent utilities)
(FNS LOAD? FILESLOAD DOFILESLOAD)
(FNS DMPHASH HASHOVERFLOW)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST
HASHOVERFLOW.UPDATEARRAY))
(FNS BKBUFS CHANGENAME CHNGNM CLBUFS DEFINE FNS.PUTDEF EQMEMB
EQUALN FILEDATE FILEMAP FNCHECK FNTYP1 FREEVARS
LISPSOURCEFILEP \LISPSOURCEFILEP1 GETFILEMAP LCSKIP MAPRINT
MKLIST NAMEFIELD NLIST PRINTBELLS PROMPTCHAR PUTFILEMAP
RAISEP READFILE READLINE REMPROPLIST RESETBUFS TAB UNSAVED1
UPDATEFILEMAP USEDFREE WRITEFILE XNLSETQ PROG2
UNSAFE.TO.MODIFY)
(VARS UNSAFE.TO.MODIFY.FNS)
(PROP ARGNAMES PROG2)
(P (MOVD? (QUOTE COPYBYTES)
(QUOTE COPYCHARS)))
(FNS RESETFORM RESETLST RESETTOPVALS RESETTOPVALS1)
(PROP INFO RESETTOPVALS))
(COMS (* * LVLPRINT)
(FNS LVLPRINT LVLPRIN1 LVLPRIN2 LVLPRIN LVLPRIN0))
(COMS (* used by PRINTOUT)
(FNS FLUSHRIGHT PRINTPARA PRINTPARA1))
[COMS (* * SUBLIS and friends)
(FNS SUBLIS SUBPAIR DSUBLIS)
(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 * CHARCODECOMS)
[COMS (* * CONSTANTS)
(FNS CONSTANTOK)
(P (MOVD? (QUOTE EVQ)
(QUOTE CONSTANT))
(MOVD? (QUOTE EVQ)
(QUOTE DEFERREDCONSTANT))
(MOVD? (QUOTE EVQ)
(QUOTE LOADTIMECONSTANT]
(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]
(GLOBALVARS SYSFILES LOADOPTIONS UPDATEMAPFLG LISPXCOMS CLISPTRANFLG COMMENTFLG
**COMMENT**FLG HISTSTR4 LISPXREADFN REREADFLG HISTSTR0 FILEPKGFLG CTRLUFLG
NOLINKMESS PROMPTCHARFORMS PROMPT#FLG USEMAPFLG FILERDTBL BUILDMAPFLG DFNFLG
SPELLINGS2 DWIMFLG USERWORDS ADDSPELLFLG BELLS LISPXPRINTFLG CLISPARRAY)
(FNS NLAMBDA.ARGS)
[P [MAPC (QUOTE ((APPLY BLKAPPLY)
(SETTOPVAL SETATOMVAL)
(GETTOPVAL GETATOMVAL)
(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]
(MAPC [QUOTE ([EVALQT (LAMBDA NIL (PROG (TEM)
(RESETRESTORE NIL (QUOTE RESET))
LP
(PROMPTCHAR (QUOTE ←)
T)
(LISPX (LISPXREAD T T))
(GO LP]
(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])
[LISPXREAD (LAMBDA (FILE RDTBL)
(COND [READBUF (PROG1 (CAR READBUF)
(SETQ READBUF (CDR READBUF]
(T (READ FILE RDTBL]
[LISPXREADP (LAMBDA (FLG)
(COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF))
)
T)
(T (READP T FLG]
[LISPXUNREAD (LAMBDA (LST)
(SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF]
[LISPXREADBUF (LAMBDA (RDBUF)
(PROG NIL LP (COND ((NLISTP RDBUF)
(RETURN NIL))
((EQ (CAR RDBUF)
HISTSTR0)
(SETQ RDBUF (CDR RDBUF))
(GO LP))
(T (RETURN RDBUF]
(LISPX/ [LAMBDA (X)
X])
[LOWERCASE (LAMBDA (FLG)
(PROG1 LCASEFLG (RAISE (NULL FLG))
(RPAQ LCASEFLG FLG]
[FILEPOS (LAMBDA (STR FILE)
(PROG NIL LP (COND ((EQ (PEEKC FILE)
(NTHCHAR STR 1))
(RETURN T)))
(READC FILE)
(GO LP]
(FILEPKGCOM (NLAMBDA NIL NIL]
(FUNCTION (LAMBDA (L)
(OR (GETD (CAR L))
(PUTD (CAR L)
(CADR L]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA SCRATCHLIST RESETTOPVALS RESETLST RESETFORM USEDFREE RESETBUFS
DMPHASH FILESLOAD)
(NLAML CHARCODE XNLSETQ FILEMAP)
(LAMA PROG2 READFILE NLIST)))
(LOCALVARS . T)))
(* * random machine-independent utilities)
(DEFINEQ
(LOAD?
[LAMBDA (FILE LDFLG PRINTFLG) (* lmm " 2-Sep-85 13:15")
(bind FULL until (SETQ FULL (FINDFILE FILE)) do (SETQ FILE (LISPERROR "FILE NOT FOUND" FILE T))
finally (RETURN (if (FMEMB FULL LOADEDFILELST)
then FULL
else (LET* [(ROOT (ROOTFILENAME FULL T))
(DATES (GETPROP ROOT (QUOTE FILEDATES)))
(FILEPROP (GETPROP ROOT (QUOTE FILE]
(if [AND DATES (if (EQ (FILENAMEFIELD FULL (QUOTE EXTENSION))
COMPILE.EXT)
then (AND [OR (NULL FILEPROP)
(FMEMB (CDAR FILEPROP)
(QUOTE (Compiled COMPILED]
(EQUAL (CAAR DATES)
(FILEDATE FULL T)))
else (AND FILEPROP (EQ (CDAR FILEPROP)
T)
(OR (EQ (CDAR DATES)
FULL)
(EQUAL (CAAR DATES)
(FILEDATE FULL]
then FULL
else (LOAD FULL LDFLG PRINTFLG])
(FILESLOAD
[NLAMBDA FILES (* lmm "10-Dec-84 17:23")
(* Calls to this are written on files by the FILES
command. This function does the load-time evaluation of
the command.)
(DOFILESLOAD (NLAMBDA.ARGS FILES])
(DOFILESLOAD
[LAMBDA (FILES)
(DECLARE (USEDFREE LDFLG)) (* lmm "29-Mar-85 20:29")
(* does the work of FILESLOAD)
(for FILE inside FILES bind DIR LOADOPTIONSFLG FORCEDEXT? NOERRORFLG WORD (FN ←(QUOTE LOAD?))
(EXT ← COMPILE.EXT)
first (COND
((AND (BOUNDP (QUOTE LDFLG))
(NEQ T (INPUT)))
(* 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 (COND
[(LITATOM FILE) (* Get the full name to print it out.)
(PROG NIL
(COND
((AND (EQ FN (QUOTE LOAD?))
(GETPROP (ROOTFILENAME FILE)
(QUOTE FILEDATES))) (* Already loaded)
(RETURN)))
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))
(COND
(NOERRORFLG (RETURN))
(T [SETQ FILE (ERROR FILE
(COND
(DIR (APPEND (QUOTE (not found on))
DIR))
(T "not found"]
(GO LP]
(RETURN (LIST (SELECTQ FN
(CHECKIMPORTS
(* LOADOPTIONSFLG has a different meaning for imports)
(CHECKIMPORTS FILE T)
FILE)
(LOAD? (* already weeded out the ones with filedates)
(LOAD FILE LOADOPTIONSFLG))
(APPLY* FN FILE LOADOPTIONSFLG]
(T (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 (COND
((OR (EQ (SETQ WORD (CAR FILE))
(QUOTE VALUEOF))
(COND
((AND (EQ WORD (QUOTE VALUE))
(EQ (CADR FILE)
(QUOTE OF)))
(pop FILE)
T)))
(pop FILE)
(EVAL (CAR FILE)))
((AND (SELCHARQ (CHCON1 WORD)
(({ <)
NIL)
T)
[BOUNDP (SETQ WORD
(PACK* WORD (QUOTE
DIRECTORIES]
(SETQ WORD (EVALV WORD)))
(* KLUDGE: Turns, e.g., (FROM LISPUSERS) into
(FROM VALUEOF LISPUSERSDIRECTORIES))
WORD)
(T (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))
(COND
((FMEMB (CAR FILE)
LOADOPTIONS)
(SETQ LOADOPTIONSFLG (CAR FILE)))
(T (* invalid option in FILESLOAD)
NIL)))
(pop FILE))
NIL])
)
(DEFINEQ
(DMPHASH
[NLAMBDA L (* rmk: " 6-Apr-84 14:30")
(MAPC L (FUNCTION (LAMBDA (ARRAYNAME)
(DECLARE (SPECVARS 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 (HARRAYPROP AP (QUOTE OVERFLOW]
(KWOTE (CDR A]
(T (LIST (QUOTE HASHARRAY)
(HARRAYSIZE A)
(KWOTE (HARRAYPROP AP (QUOTE OVERFLOW]
(MAPHASH (OR AP A)
(FUNCTION (LAMBDA (VAL ITEM)
(PRINT (LIST (QUOTE PUTHASH)
(KWOTE ITEM)
(KWOTE VAL)
ARRAYNAME])
(HASHOVERFLOW
[LAMBDA (HARRAY) (* bvm: "15-Feb-85 01:00")
(* 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. HARRAY is guaranteed to be either HARRAYP or
(LIST HARRAYP))
(PROG ((OLDARRAY (HASHOVERFLOW.ARRAYTEST HARRAY))
NEWARRAY NEWSIZE OLDNUMKEYS OVACTION NEWOVFLW)
[COND
((LISTP HARRAY)
(SETQ OVACTION (CDR HARRAY)) (* Get OVERFLOW method from original HARRAY since it
would erroneously be ERROR if we got the method from
the coerced OLDARRAY)
(SETQ NEWOVFLW (QUOTE ERROR)))
(T (SETQ OVACTION (SETQ NEWOVFLW (HARRAYPROP OLDARRAY (QUOTE OVERFLOW]
(SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY (QUOTE NUMKEYS)))
[SETQ NEWSIZE (SELECTQ OVACTION
(NIL (* SIZE*1.5 -
favor to bbn, since pdp-11 doesnt have floatng point,
and LRSH on other systems might be faster than
IQUOTIENT)
(IPLUS OLDNUMKEYS (LRSH (ADD1 OLDNUMKEYS)
1)))
[ERROR (do (ERRORX (LIST 26 HARRAY]
(if (FLOATP OVACTION)
then (FTIMES OLDNUMKEYS OVACTION)
elseif (FIXP OVACTION)
then (IPLUS OLDNUMKEYS OVACTION)
elseif [AND (FNTYP OVACTION)
(NUMBERP (SETQ OVACTION (APPLY* OVACTION HARRAY]
then OVACTION
else (* Default: multiply by 1.5)
(IPLUS OLDNUMKEYS (LRSH (ADD1 OLDNUMKEYS)
1]
[SETQ NEWARRAY (REHASH OLDARRAY (HASHARRAY NEWSIZE NEWOVFLW (HARRAYPROP OLDARRAY
(QUOTE HASHBITSFN))
(HARRAYPROP OLDARRAY (QUOTE EQUIVFN]
(HASHOVERFLOW.UPDATEARRAY HARRAY NEWARRAY OLDARRAY)
(RETURN HARRAY])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
[PROGN [PUTPROPS HASHOVERFLOW.ARRAYTEST MACRO ((HARRAY)
(CAR (OR (LISTP HARRAY)
(ERRORX (LIST 27 HARRAY]
(PUTPROPS HASHOVERFLOW.ARRAYTEST DMACRO ((HARRAY)
(\DTEST HARRAY (QUOTE HARRAYP]
[PROGN (PUTPROPS HASHOVERFLOW.UPDATEARRAY MACRO ((HARRAY NEWARRAY OLDARRAY)
(FRPLACA HARRAY NEWARRAY)))
(PUTPROPS HASHOVERFLOW.UPDATEARRAY DMACRO ((HARRAY NEWARRAY OLDARRAY)
(\COPYHARRAYP NEWARRAY OLDARRAY]
)
)
(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])
(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])
(DEFINE
[LAMBDA (X TYPE-IN) (* mpl "15-Jul-85 11:22")
(MAPCAR X (FUNCTION (LAMBDA (X)
(COND
((NLISTP X)
(ERROR (QUOTE "incorrect defining form")
X)))
(FNS.PUTDEF (CAR X)
(QUOTE FNS)
[COND
((NULL (CDDR X))
(CADR X))
(T (CONS (QUOTE LAMBDA)
(CDR X]
(if TYPE-IN
then (QUOTE DEFINED)
else (QUOTE LOAD])
(FNS.PUTDEF
[LAMBDA (NAME TYPE DEFINITION REASON) (* lmm " 4-Aug-85 02:27")
(PROG NIL
(if (OR (AND DEFINITION (NLISTP DEFINITION))
(NOT (FMEMB (CAR DEFINITION)
LAMBDASPLST)))
then (ERROR DEFINITION "Illegal function definition"))
(SELECTQ DFNFLG
((NIL T)
(if (UNSAFE.TO.MODIFY NAME "redefine")
then (ERROR NAME " not redefined" T)))
NIL)
(if (EQ REASON (QUOTE DEFINED))
then (FIXEDITDATE DEFINITION))
(COND
((OR (NULL DFNFLG)
(EQ DFNFLG T))
(COND
[(GETD NAME)
(VIRGINFN NAME T)
(COND
((EQUAL DEFINITION (GETD NAME))
(RETURN NAME))
((NULL DFNFLG)
(LISPXPRINT (CONS NAME (QUOTE (redefined)))
T T)
(SAVEDEF NAME]
((GETPROP NAME (QUOTE CLISPWORD))
(MAPRINT (CONS NAME (QUOTE (defined, therefore disabled in CLISP.)))
T "****Note: " (QUOTE %
)
NIL NIL T))
((MEMB NAME LISPXCOMS)
(MAPRINT (CONS NAME
(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 NAME)))
(/PUTD NAME DEFINITION))
(T (* DFNFLG is PROP or ALLPROP.
However, treat anything else the same as PROP.)
(AND ADDSPELLFLG (ADDSPELL NAME 0))
(/PUTPROP NAME (QUOTE EXPR)
DEFINITION)))
(COND
(FILEPKGFLG (MARKASCHANGED NAME (QUOTE FNS)
REASON)))
(RETURN NAME])
(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) (* bvm: "20-NOV-83 15:56")
(* CFLG IS T FOR COMPILED FILES)
(COND
(FILE (CAR (XNLSETQ (PROG (OPENED OLDPTR VALUE)
[COND
((SETQ OPENED (OPENP FILE (QUOTE INPUT)))
(SETQ FILE OPENED))
(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 OPENED (NOT OLDPTR))
(* 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 OLDPTR (GETFILEPTR OPENED))
(SETFILEPTR OPENED 0)
(GO LP)))
(GO OUT)))
(AND CFLG (READ FILE FILERDTBL))
[SETQ VALUE (COND
((NLISTP (SETQ VALUE (READ FILE FILERDTBL)))
NIL)
((EQ (CAR VALUE)
(QUOTE FILECREATED))
(CAR (LISTP (CDR VALUE]
OUT (COND
((NULL OPENED)
(CLOSEF FILE))
(OLDPTR (SETFILEPTR FILE OLDPTR)))
(RETURN VALUE))
NOBREAK])
(FILEMAP
[NLAMBDA (FILEMAP) (* wt: 11-JUL-76 20 8)
(PUTFILEMAP (INPUT)
FILEMAP FILECREATEDLST])
(FNCHECK
[LAMBDA (FN NOERRORFLG SPELLFLG PROPFLG TAIL) (* bvm: "30-OCT-83 21:59")
(PROG (X BLOCK BLOCK/FN)
TOP (COND
((NOT (LITATOM FN))
(GO ERROR))
((GETD FN))
((GETP FN (QUOTE EXPR))
(AND (NULL PROPFLG)
(GO ERROR)))
((NULL DWIMFLG)
(GO ERROR))
((AND [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))
([AND (EQ (SYSTEMTYPE)
(QUOTE D))
[for FL in (WHEREIS FN) thereis (for FILE inside (OR (GETP FL (QUOTE FILEGROUP))
FL)
thereis (SETQ BLOCK
(find B in (FILECOMSLST FILE
(QUOTE BLOCKS))
suchthat (AND (CAR X)
(MEMB FN BLOCK]
(GETD (SETQ BLOCK/FN (PACK* (QUOTE \)
(CAR BLOCK)
(QUOTE /)
FN]
(* In Interlisp-D, get actual name of internal block fn. This is a little odd, since in a truly block-compiled
system you couldn't get at the subfns)
(SETQ FN BLOCK/FN))
(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])
(LISPSOURCEFILEP
(LAMBDA (FILE) (* JonL "11-Mar-84 00:30")
(* * If the first few characters of FILE "look like" those output by MAKEFILE then return the alleged address in
the file of its FILEMAP expression.)
((LAMBDA (FULL)
(if (AND FULL (NOT (RANDACCESSP FULL)))
then (* Currently we don't handle this -- it could be "faked"
)
NIL
else (RESETLST (if FULL
then (RESETSAVE NIL (LIST (QUOTE SETFILEPTR)
FULL
(GETFILEPTR FULL)))
(SETFILEPTR FULL 0)
else (RESETSAVE (SETQ FULL (OPENFILE FILE (QUOTE INPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE)))))
(\LISPSOURCEFILEP1 FULL))))
(OPENP FILE))))
(\LISPSOURCEFILEP1
(LAMBDA (FILE FL) (* JonL "11-Mar-84 00:30")
(* FILE must be the fullname of an open file.)
(* FL arg non-null means entry from GETFILEMAP)
(PROG (MAPADDR (ERRORTYPELST (QUOTE ((16 (ERROR!))))))
(DECLARE (SPECVARS ERRORTYPELST))
(* * NLSETQ doesn't suppress the file-closing operation of EOF; ERROR! bombs out with the file left open.)
(NLSETQ (if (AND (EQ (SKIPSEPRS FILE FILERDTBL)
(QUOTE %())
(NOT (find C
in (QUOTE (%( F I L E C R E A T E D % ))
suchthat (NEQ C (READC FILE FILERDTBL)))))
then (SKREAD FILE)
(SKREAD FILE)
(SETQ MAPADDR (FIXP (READ FILE FILERDTBL)))
(if (AND FL MAPADDR)
then (PROG (MAP (NMAPADDR MAPADDR))
(SETQ MAPADDR) (* Nullify in case something causes an error.
After winnitude has been determined, then set it back to
final result)
(if (ILESSP (OR NMAPADDR MAX.FIXP)
(OR (GETEOFPTR FILE)
MAX.FIXP))
then (SETFILEPTR FILE NMAPADDR)
(SETQ MAP (READ FILE FILERDTBL))
(AND (EQ (CAR (LISTP MAP))
(QUOTE FILEMAP))
(SETQ MAPADDR (CADR MAP))))))))
(RETURN MAPADDR))))
(GETFILEMAP
(LAMBDA (FILE FL) (* JonL "11-Mar-84 00:33")
(* 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 ((LAMBDA (MAP)
(if (AND FL (EQ FILE (CAR (SETQ MAP (LISTP (GETPROP FL (QUOTE FILEMAP)))))))
then (CADR MAP)
elseif (NOT (OPENP FILE (QUOTE INPUT)))
then (ERRORX (LIST 13 FILE))
elseif (NOT (RANDACCESSP FILE))
then (* Sorry, we just cant get to the FILEMAP on a non
RANDACCESSP device.)
NIL
else (SETQ MAP (GETFILEPTR FILE))
(SETFILEPTR FILE 0)
(PROG1 (\LISPSOURCEFILEP1 FILE T)
(SETFILEPTR FILE MAP))))))))
(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])
(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 (* bvm: "14-Feb-85 23:48")
(PROG (V (I N))
LP [COND
((EQ I 0)
(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 " 9-Jun-85 20:53")
(* 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)))
[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 \READFILE.ARGCNT
(PROGN (QUOTE DEFUN) (* ARGLIST = (FILE &OPTIONAL
(RDTBL FILERDTBL) (ENDTOKEN
(QUOTE STOP))))
(DECLARE (LOCALVARS \READFILE.ARGCNT))
(LET ((FILE (ARG \READFILE.ARGCNT 1))
ENDTOKEN RDTBL)
(SETQ RDTBL (if (IGREATERP 2 \READFILE.ARGCNT)
then FILERDTBL
else (ARG \READFILE.ARGCNT 2)))
(SETQ ENDTOKEN (if (IGREATERP 3 \READFILE.ARGCNT)
then (QUOTE STOP)
else (ARG \READFILE.ARGCNT 3)))
(* lmm "14-Jun-85 02:29")
(DECLARE (GLOBALVARS LOADPARAMETERS)
(SPECVARS HELPCLOCK))
(RESETLST [RESETSAVE NIL (LIST (QUOTE CLOSEF?)
(SETQ FILE (OPENSTREAM FILE (QUOTE INPUT)
NIL NIL LOADPARAMETERS]
(bind TEM HELPCLOCK until (OR [NOT (NLSETQ (SETQ TEM (READ FILE RDTBL]
(EQ TEM ENDTOKEN))
collect TEM])
(READLINE
[LAMBDA (RDTBL LINE LISPXFLG) (* AJB " 1-Aug-85 14:50")
(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
((OR (EQ LISPXREADFN (QUOTE READ))
(IMAGESTREAMTYPEP T (QUOTE TEXT))) (* So the call will be linked, so the user can break on
read.)
(* TEXTSTREAMS must use 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 "18-Apr-85 21:38")
(PROG (DEF PROP)
TOP (COND
((NOT (LITATOM FN)))
([SETQ DEF (COND
((SETQ PROP TYP)
(GETPROP FN TYP))
[(GETPROP FN (SETQ PROP (QUOTE EXPR]
[(GETPROP FN (SETQ PROP (QUOTE CODE]
((GETPROP FN (SETQ PROP (QUOTE SUBR]
(VIRGINFN FN T)
(/REMPROP FN PROP)
(COND
((NEQ DFNFLG T)
(SAVEDEF FN)))
(/PUTD FN DEF T)
(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"])
(UPDATEFILEMAP
[LAMBDA (FILE FILEMAP) (* jds " 6-Sep-84 13:36")
(PROG (FILEMAPADR FILEMAPLOCADR TEM (DECLARESTRING (CONCAT "(DECLARE: DONTCOPY
" "(FILEMAP"))
FILEMAPLOCLEN)
(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))
[PROGN (SKREAD FILE) (* Date)
(SKREAD FILE) (* Name)
(do (COND
((EQ (SETQ TEM (READC FILE))
(QUOTE % )) (* found a space)
(RETURN T))
((NOT (SYNTAXP (CHCON1 TEM)
(QUOTE SEPRCHAR)
FILERDTBL)) (* no spaces, lose)
(RETURN]
[FIXP (SETQ FILEMAPADR (PROGN (* skip over seprs)
(SETQ FILEMAPLOCADR (GETFILEPTR FILE))
(* Address of first character of file-map location)
(PROG1 (RATOM FILE FILERDTBL)
(SETQ FILEMAPLOCLEN (IDIFFERENCE (GETFILEPTR
FILE)
FILEMAPLOCADR]
(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)
FILEMAPLOCLEN))
(* 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)
(PRINTNUM (LIST (QUOTE FIX)
FILEMAPLOCLEN)
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 U (* JonL "25-Jun-84 06:13")
(if (ILESSP U 2)
then (ERROR "Too few arguments")
else (ARG U 2))))
(UNSAFE.TO.MODIFY
[LAMBDA (FN OPTION) (* lmm "31-Jul-85 02:06")
(if (FMEMB FN UNSAFE.TO.MODIFY.FNS)
then (PRINTOUT T "Warning: " FN " may be unsafe to " (OR OPTION "modify")
" -- continue? ")
(if (EQ (if (GETD (QUOTE ASKUSER))
then (ASKUSER DWIMWAIT (QUOTE N))
else (READ T))
(QUOTE Y))
then NIL
else T])
)
(RPAQQ UNSAFE.TO.MODIFY.FNS (QUOTE APPLY PRINT BLOCK TIMEREXPIRED? PRIN1 PRIN2 LISPXPUT PRIN3
DSPCLIPPINGREGION ADDCHAR BLTCHAR TTWAITFORINPUT READ READLINE
/PUTD /REMPROP ADDCHAR /PUT ADDSPELL ADVISEWDS ALLOCSTRING APPLY
ASSOC AWAIT.EVENT BITBLT.ERASE BITMAPCOPY BITMAPCREATE BKBITBLT
BLOCK BLTCHAR BLTSHADE BREAK BREAK0 BREAK1 BREAK1A BREAK2
BREAKRESETFN BRKLASTPOS CHARSET CHCON1 CLEAR.LINE? CLOCK
CLOCKDIFFERENCE CLOSEW CONCAT CREATEW CROCK.PROCESS CURSOR
CURSORHOTSPOT DELETETO DO.CRLF DRAWLINE DSPBACKUP
DSPCLIPPINGREGION DSPCREATE DSPDESTINATION DSPFILL DSPFONT
DSPLEFTMARGIN DSPRIGHTMARGIN DSPSCROLL DSPSOURCETYPE DSPXOFFSET
DSPXPOSITION DSPYPOSITION EQLENGTH EQP EQUAL ERASE.TO.END.OF.LINE
ERASE.TO.END.OF.PAGE ERRORMESS1 ERRORSET EVAL EVALQT EXPRP FASSOC
FILENAMEFIELD FIXR FLIPCURSOR GENSYM GETBREAKWINDOW GETMOUSESTATE
GETPROP GETPUP GETXIP HELP HISTORYSAVE IDLE.OUT IMAGESTREAMTYPEP
IMOD INIT.CURSOR INTEGERLENGTH INTERRUPTABLE INTERSECTREGIONS
IREMAINDER LAST LASTC LISPX LISPX/ LISPXFIND LISPXFIND1 LISPXPRINT
LISPXPUT LISPXREAD LISPXREADBUF LISPXUNREAD LISTGET LISTPUT MEMB
MKATOM MKSTRING MONITOR.AWAIT.EVENT MOVETOUPPERLEFT NOTIFY.EVENT
NTH NTHCHARCODE OBTAIN.MONITORLOCK OPENW OVERFLOW? PACK*
PAGEHEIGHT PERIODICALLYRECLAIM PRIN1 PRIN2 PRIN3 PRINT PRINTCCODE
PRINTLEVEL PROGN PROMPTCHAR PUTWINDOWPROP READ READLINE READP
REALSTKNTH REGIONP RELEASE.PUP RELEASEBREAKWINDOW RELSTK
RESETRESTORE RESHOWTITLE RESTORE RETFROM RPLCHARCODE RPLSTRING
SAVED SENDPUP SETBREAKTTY SETCURSOR SETTERMTABLE SHOWPRIN2
SHOWPRINT SHOWWFRAME SHOWWTITLE SKIPSEPRS SPACES SPACEWINDOWA0003
STKPOS SUBATOM SUBSTRING SYNTAXP TERPRI TIMEREXPIRED? TOTOPW TTBIN
TTBITWIDTH TTCRLF TTDELETELINE TTSKREAD TTWAITFORINPUT
TTYDISPLAYSTREAM TTYIN TTYIN.CLEANUP TTYIN.FINISH TTYIN.READ
TTYIN.SETUP TTYIN1 TTYIN1RESTART TTYINREAD TYPENAME UNBREAK0
UNDOSAVE UNPACKFILENAME.STRING UPDATE.SPACE.WINDOW
UPDATE.SPACE.WINDOW.PLINE WFROMDS WINDOW.MOUSE.HANDLER))
(PUTPROPS PROG2 ARGNAMES (NIL (FIRST SECOND ...) . U))
(MOVD? (QUOTE COPYBYTES)
(QUOTE COPYCHARS))
(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))
(* * 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)
(DECLARE (SPECVARS FILE PRIN2FLG))
(PROG (PRIN2FLG)
(LVLPRIN X CARLVL CDRLVL TAIL)
(RETURN X])
(LVLPRIN2
[LAMBDA (X FILE CARLVL CDRLVL TAIL)
(DECLARE (SPECVARS FILE PRIN2FLG)) (* 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) (* bvm: "14-Feb-85 23:48")
(* 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
((EQ CDRLVL 0)
(PRIN1 (QUOTE --)
FILE)
(RETURN))
[(NLISTP (CAR X))
(COND
(PRIN2FLG (PRIN2 (CAR X)
FILE T T))
(T (PRIN1 (CAR X)
FILE]
((OR (EQ CARLVL 0)
(AND CDRLVL0 (EQ (SUB1 CDRLVL0)
0))) (* 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])
)
(* used by PRINTOUT)
(DEFINEQ
(FLUSHRIGHT
(LAMBDA (POS X MIN P2FLAG CENTERFLAG FILE) (* rmk: "22-MAY-81 11:59") (* Right-flushes X at position
POS. If P2FLAG, uses PRIN2-pname; if CENTERFLAG, centers X between current position and POS) (SETQ POS
(IDIFFERENCE (COND ((MINUSP POS) (IDIFFERENCE (POSITION FILE) POS)) ((ZEROP POS) (LINELENGTH NIL FILE
)) (T POS)) (NCHARS X P2FLAG))) (COND (CENTERFLAG (SETQ POS (LRSH (IPLUS POS (POSITION FILE)) 1)))) (
TAB POS MIN FILE) (COND (P2FLAG (PRIN2 X FILE)) (T (PRIN1 X FILE)))))
(PRINTPARA
(LAMBDA (LMARG RMARG LIST P2FLAG PARENFLAG FILE) (* rmk: "22-MAY-81 13:45") (* Prints LIST in
paragraph format. The first line starts at the current line position, but all subsequent lines begin
at LMARG (0 is the left margin, NIL is the current POSITION, negative LMARG is (POSITION) + LMARG) %.
Printing is with PRIN2 if P2FLAG, otherwise PRIN1. The right margin is at column RMARG if RMARG is
positive, (LINELENGTH NIL FILE) minus RMARG for RMARG LEQ 0) (DECLARE (SPECVARS LMARG RMARG P2FLAG
FILE)) (COND ((NULL LMARG) (SETQ LMARG (POSITION FILE))) ((MINUSP LMARG) (SETQ LMARG (IDIFFERENCE (
POSITION FILE) LMARG)))) (COND ((ILEQ RMARG 0) (SETQ RMARG (IPLUS RMARG (LINELENGTH NIL FILE))))) (
POSITION FILE (PRINTPARA1 LIST (POSITION FILE) (COND (PARENFLAG 1) (T 0)) (COND (PARENFLAG 1) (T 0))))
))
(PRINTPARA1
(LAMBDA (LIST POS OPENCOUNT CLOSECOUNT) (* wt: " 9-SEP-78 09:54") (* PRIN3 and PRIN4 are used here, so
we don't have to set and unset LINELENGTH. We keep our own idea of the current line position in POS,
which is returned as the value of PRINTPARA1. OPENCOUNT is the number of open parens that must precede
the first non-list we print, CLOSECOUNT is the number of close parens that should follow the last
non-list we print. They are passed as arguments so that their numbers can be taken into account in
deciding whether a non-list fits on the line or not.) (PROG ($$VAL L LEN (CC 0)) $$LP (SETQ L (CAR (OR
(LISTP LIST) (GO $$OUT)))) (* POS is the correct column position at the end of each iteration) (COND
((NLISTP (CDR LIST)) (SETQ CC CLOSECOUNT))) (* The last iteration. Now we really want to use
CLOSECOUNT, so we move it to CC.) (COND ((LISTP L) (SETQ POS (PRINTPARA1 L POS (ADD1 OPENCOUNT) (ADD1
CC))) (SETQ OPENCOUNT 0) (* The lower call printed the open and closed parens, including the ones for
this level, if any.) (SETQ CC 0)) (T (COND ((ILESSP RMARG (IPLUS OPENCOUNT CC (SETQ POS (IPLUS POS (
SETQ LEN (NCHARS L P2FLAG)))))) (TERPRI FILE) (* TAB wouldn't work, cause POSITION doesn't know where
we are.) (RPTQ LMARG (PRIN3 (QUOTE % ) FILE)) (SETQ POS (IPLUS LMARG LEN)))) (COND ((IGREATERP
OPENCOUNT 0) (RPTQ OPENCOUNT (PRIN3 (QUOTE %() FILE)) (SETQ POS (IPLUS POS OPENCOUNT)) (SETQ OPENCOUNT
0))) (COND (P2FLAG (PRIN4 L FILE)) (T (PRIN3 L FILE))))) (COND ((AND (IGREATERP RMARG (ADD1 POS)) (
LISTP (CDR LIST))) (PRIN3 (QUOTE % ) FILE) (SETQ POS (ADD1 POS)))) $$ITERATE (SETQ LIST (CDR LIST)) (
GO $$LP) $$OUT (RPTQ CC (COND ((ILESSP RMARG (SETQ POS (ADD1 POS))) (TERPRI FILE) (* We do the closes
one-by-one, in case they won't fit on a line with only 1 atom) (RPTQ LMARG (PRIN3 (QUOTE % ) FILE)) (
PRIN3 (QUOTE %)) FILE) (SETQ POS (ADD1 LMARG))) (T (PRIN3 (QUOTE %)) FILE)))) (RETURN $$VAL)) POS))
)
(* * SUBLIS and friends)
(DEFINEQ
(SUBLIS
[LAMBDA (ALST EXPR FLG)
(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)
(SUBLIS ALST (CDR EXPR)
FLG))
(SUBLIS ALST (CAR EXPR)
FLG)))
(T (LET ((Y (FASSOC EXPR ALST)))
(COND
[Y (COND
(FLG (COPY (CDR Y)))
(T (CDR Y]
(T 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])
(DSUBLIS
[LAMBDA (ALST EXPR FLG)
(COND
((NLISTP EXPR)
(SUBLIS ALST EXPR FLG))
(T (LET ((A (DSUBLIS ALST (CAR EXPR)
FLG)))
(OR (EQ A (CAR EXPR))
(RPLACA EXPR A)))
(LET ((D (DSUBLIS ALST (CDR EXPR)
FLG)))
(OR (EQ D (CDR EXPR))
(RPLACD EXPR D)))
EXPR])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(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)
)
(RPAQQ CHARCODECOMS ((FNS CHARCODE CHARCODE.DECODE)
(VARS CHARACTERNAMES CHARACTERSETNAMES)
(PROP MACRO CHARCODE SELCHARQ ALPHACHARP DIGITCHARP UCASECODE)
(ALISTS (DWIMEQUIVLST SELCHARQ)
(PRETTYEQUIVLST SELCHARQ))))
(DEFINEQ
(CHARCODE
[NLAMBDA (CHAR)
(CHARCODE.DECODE CHAR])
(CHARCODE.DECODE
[LAMBDA (C) (* lmm "31-Jul-85 01:33")
(DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES))
(AND
C
(COND
[(LISTP C)
(CONS (CHARCODE.DECODE (CAR C))
(CHARCODE.DECODE (CDR C]
((NOT (OR (ATOM C)
(STRINGP C)))
(ERROR "BAD CHARACTER SPECIFICATION" C))
((EQ (NCHARS C)
1)
(CHCON1 C))
(T (SELECTQ
(NTHCHAR C 1)
[↑ (LOGAND (LOGNOT 140Q)
(CHARCODE.DECODE (SUBSTRING C 2 -1]
[# (IPLUS 200Q (CHARCODE.DECODE (SUBSTRING C 2 -1]
(LET ((STR (MKSTRING C)))
(for X in CHARACTERNAMES when (STRING.EQUAL (CAR X)
STR)
do [RETURN (if (NUMBERP (CADR X))
then (CADR X)
else (CHARCODE.DECODE (CADR X]
finally (RETURN (LET ((POS (STRPOSL (QUOTE (, - "." "|"))
STR)))
(if POS
then (PSETQ POS (SUBATOM STR 1 (SUB1 POS))
STR
(SUBATOM STR (ADD1 POS)
-1))
(SETQ STR (if (FIXP STR)
then (PACK* STR (QUOTE Q))
else (CHARCODE.DECODE STR)))
(LOGOR (LSH (if (FIXP POS)
then (PACK* POS (QUOTE Q))
else (OR (CADR (ASSOC POS
CHARACTERSETNAMES))
(ERROR
"BAD CHARACTERSET SPECIFICATION"
C)))
10Q)
STR)
else (ERROR "BAD CHARACTERSET SPECIFICATION" C])
)
(RPAQQ CHARACTERNAMES ((PAGE 12)
(FORM 12)
(FF 12)
(DEL 127)
(RUBOUT 127)
(NULL 0)
(ESCAPE 27)
(ESC 27)
(BELL 7)
(TAB 9)
(BS 8)
(NEWLINE 13)
(TENEXEOL 31)
(SPACE 32)
(SP 32)
(LINEFEED 10)
(LF 10)
(CR 13)
(RETURN 13)
(INFINITY 8551)
(RIGHTPAREN 41)
(BACKSPACE ↑H)
(PI GREEK-163)
(EOL 13)))
(RPAQQ CHARACTERSETNAMES ((GREEK 38)
(CYRILLIC 39)
(HIRA 36)
(HIRAGANA 36)
(KATA 37)
(KATAKANA 37)
(KANJI 48)))
(PUTPROPS CHARCODE MACRO (DEFMACRO (C)
(KWOTE (CHARCODE.DECODE C T))))
(PUTPROPS SELCHARQ MACRO [F (CONS (QUOTE SELECTQ)
(CONS (CAR F)
(MAPLIST (CDR F)
(FUNCTION (LAMBDA (I)
(COND
((CDR I)
(CONS (CHARCODE.DECODE (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
((AND (IGEQ CHAR (CHARCODE a))
(ILEQ CHAR (CHARCODE z)))
(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))
(MOVD? (QUOTE EVQ)
(QUOTE LOADTIMECONSTANT))
(* * 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))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS SYSFILES LOADOPTIONS UPDATEMAPFLG LISPXCOMS CLISPTRANFLG COMMENTFLG **COMMENT**FLG
HISTSTR4 LISPXREADFN REREADFLG HISTSTR0 FILEPKGFLG CTRLUFLG NOLINKMESS PROMPTCHARFORMS
PROMPT#FLG USEMAPFLG FILERDTBL BUILDMAPFLG DFNFLG SPELLINGS2 DWIMFLG USERWORDS
ADDSPELLFLG BELLS LISPXPRINTFLG CLISPARRAY)
)
(DEFINEQ
(NLAMBDA.ARGS
[LAMBDA (X) (* lmm "14-Aug-84 19:02")
(* standard function to take argument to NLAMBDA
function, e.g. BREAK, and check to see if accidentally
quoted)
(COND
((LISTP X)
(if (EQ (CAR X)
(QUOTE QUOTE))
then (CDR X)
elseif (AND (LISTP (CAR X))
(EQ (CAAR X)
(QUOTE QUOTE)))
then (CONS (CADR (CAR X))
(NLAMBDA.ARGS (CDR X)))
else X))
(X (LIST X])
)
[MAPC (QUOTE ((APPLY BLKAPPLY)
(SETTOPVAL SETATOMVAL)
(GETTOPVAL GETATOMVAL)
(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]
[MAPC [QUOTE ([EVALQT (LAMBDA NIL (PROG (TEM)
(RESETRESTORE NIL (QUOTE RESET))
LP
(PROMPTCHAR (QUOTE ←)
T)
(LISPX (LISPXREAD T T))
(GO LP]
(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])
[LISPXREAD (LAMBDA (FILE RDTBL)
(COND [READBUF (PROG1 (CAR READBUF)
(SETQ READBUF (CDR READBUF]
(T (READ FILE RDTBL]
[LISPXREADP (LAMBDA (FLG)
(COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF)))
T)
(T (READP T FLG]
[LISPXUNREAD (LAMBDA (LST)
(SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF]
[LISPXREADBUF (LAMBDA (RDBUF)
(PROG NIL LP (COND ((NLISTP RDBUF)
(RETURN NIL))
((EQ (CAR RDBUF)
HISTSTR0)
(SETQ RDBUF (CDR RDBUF))
(GO LP))
(T (RETURN RDBUF]
(LISPX/ [LAMBDA (X)
X])
[LOWERCASE (LAMBDA (FLG)
(PROG1 LCASEFLG (RAISE (NULL FLG))
(RPAQ LCASEFLG FLG]
[FILEPOS (LAMBDA (STR FILE)
(PROG NIL LP (COND ((EQ (PEEKC FILE)
(NTHCHAR STR 1))
(RETURN T)))
(READC FILE)
(GO LP]
(FILEPKGCOM (NLAMBDA NIL NIL]
(FUNCTION (LAMBDA (L)
(OR (GETD (CAR L))
(PUTD (CAR L)
(CADR L]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA SCRATCHLIST RESETTOPVALS RESETLST RESETFORM USEDFREE RESETBUFS DMPHASH FILESLOAD)
(ADDTOVAR NLAML CHARCODE XNLSETQ FILEMAP)
(ADDTOVAR LAMA PROG2 READFILE NLIST)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS MACHINEINDEPENDENT COPYRIGHT ("Xerox Corporation" T 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7818 13257 (LOAD? 7828 . 8936) (FILESLOAD 8938 . 9309) (DOFILESLOAD 9311 . 13255)) (
13258 16205 (DMPHASH 13268 . 14071) (HASHOVERFLOW 14073 . 16203)) (16696 48400 (BKBUFS 16706 . 17689)
(CHANGENAME 17691 . 17901) (CHNGNM 17903 . 19435) (CLBUFS 19437 . 20626) (DEFINE 20628 . 21150) (
FNS.PUTDEF 21152 . 23029) (EQMEMB 23031 . 23165) (EQUALN 23167 . 23894) (FILEDATE 23896 . 25419) (
FILEMAP 25421 . 25567) (FNCHECK 25569 . 27056) (FNTYP1 27058 . 27148) (FREEVARS 27150 . 27375) (
LISPSOURCEFILEP 27377 . 28201) (\LISPSOURCEFILEP1 28203 . 29682) (GETFILEMAP 29684 . 30558) (LCSKIP
30560 . 31138) (MAPRINT 31140 . 31839) (MKLIST 31841 . 31957) (NAMEFIELD 31959 . 32610) (NLIST 32612
. 32943) (PRINTBELLS 32945 . 33044) (PROMPTCHAR 33046 . 34711) (PUTFILEMAP 34713 . 35309) (RAISEP
35311 . 35554) (READFILE 35556 . 36689) (READLINE 36691 . 41421) (REMPROPLIST 41423 . 42071) (
RESETBUFS 42073 . 42389) (TAB 42391 . 42783) (UNSAVED1 42785 . 43785) (UPDATEFILEMAP 43787 . 46301) (
USEDFREE 46303 . 46552) (WRITEFILE 46554 . 47630) (XNLSETQ 47632 . 47729) (PROG2 47731 . 47924) (
UNSAFE.TO.MODIFY 47926 . 48398)) (50694 54403 (RESETFORM 50704 . 52080) (RESETLST 52082 . 52923) (
RESETTOPVALS 52925 . 54026) (RESETTOPVALS1 54028 . 54401)) (54472 57607 (LVLPRINT 54482 . 54658) (
LVLPRIN1 54660 . 54854) (LVLPRIN2 54856 . 55103) (LVLPRIN 55105 . 55889) (LVLPRIN0 55891 . 57605)) (
57637 60909 (FLUSHRIGHT 57647 . 58142) (PRINTPARA 58144 . 58964) (PRINTPARA1 58966 . 60907)) (60941
62554 (SUBLIS 60951 . 61449) (SUBPAIR 61451 . 62180) (DSUBLIS 62182 . 62552)) (64216 65998 (CHARCODE
64226 . 64289) (CHARCODE.DECODE 64291 . 65996)) (67749 68198 (CONSTANTOK 67759 . 68196)) (68371 69224
(ADDTOSCRATCHLIST 68381 . 68586) (SCRATCHLIST 68588 . 69222)) (70126 75787 (COMPARELST 70136 . 70315)
(COMPARE1 70317 . 71102) (COMPAREPRINT 71104 . 71783) (COMPAREPRINT1 71785 . 73945) (COMPARELISTS
73947 . 74399) (COMPAREPRINTN 74401 . 74791) (COMPAREFAIL 74793 . 75374) (COMPAREMAX 75376 . 75560) (
COUNTDOWN 75562 . 75785)) (76993 77595 (NLAMBDA.ARGS 77003 . 77593)))))
STOP