(FILECREATED " 3-Jan-84 13:29:51" {PHYLUM}<LISPCORE>SOURCES>DWIM.;4 45801
changes to: (FNS CLISPTRAN)
previous date: "31-Dec-83 13:41:05" {PHYLUM}<LISPCORE>SOURCES>DWIM.;2)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT DWIMCOMS)
(RPAQQ DWIMCOMS [(FNS DWIM NEWQUOTE NEWFAULT1 CHECKTRAN)
(VARS DWIMODELST (DWIMWAIT 10)
(LCASEFLG T))
[DECLARE: DONTEVAL@LOAD DOCOPY (P (SAVEDEF (QUOTE QUOTE))
(MOVD (QUOTE NEWQUOTE)
(QUOTE QUOTE]
(FNS RETDWIM2 RETDWIM3 FIXATOM2 SPLIT89 WTFIXLOADEF CLISP% )
(COMS (FNS VARSBOUNDINEDITCHAIN VARSBOUNDINFORM)
(BLOCKS (VARSBOUNDINEDITCHAIN VARSBOUNDINEDITCHAIN VARSBOUNDINFORM CHECKTRAN)))
(* * DWIMLOADFNS?)
(FNS DWIMLOADFNS?)
(APPENDVARS (DWIMUSERFORMS (DWIMLOADFNS?)))
(VARS (DWIMLOADFNSFLG T))
(FNS CLISPLOOKUP0 CLISPLOOKUP1 CLISPLOOKUP2 CLISPERROR CLISPDEC CLISPDEC0 CLISPDEC1
GETLOCALDEC)
(COMS * PRINTOUTCOMS)
(FNS COMPILEUSERFN COMPILEUSERFN1 USEDFREE CLISPTRAN)
(FNS CLISPFORERR CLISPFORERR1 I.S.OPR WARNUSER)
(DECLARE: EVAL@COMPILE DONTCOPY (ADDVARS (NLAML BREAK1)))
(BLOCKS (NEWFAULT1BLOCK NEWFAULT1 CHECKTRAN (ENTRIES NEWFAULT1)
(GLOBALVARS #CLISPARRAY)
(NOLINKFNS WTFIX))
(CLISPLOOKUP0 CLISPLOOKUP0 CLISPLOOKUP1 CLISPLOOKUP2 (GLOBALVARS DECLWORDS
CLISPRECORDTYPES
CLISPTRANFLG)
(LOCALFREEVARS WORD CLASS CLASSDEF VAR1 VAR2)
(NOLINKFNS RECORDECL))
(CLISPFORERRBLOCK WARNUSER CLISPFORERR CLISPFORERR1 (GLOBALVARS DWIMESSGAG)
(ENTRIES CLISPFORERR WARNUSER))
(CLISPDECBLOCK CLISPDEC CLISPDEC0 CLISPDEC1 GETLOCALDEC
(GLOBALVARS CLISPRECORDTYPES DECLWORDS CLISPARITHOPLST
CLISPARITHCLASSLST COMMENTFLG SKORLST1)
(ENTRIES CLISPDEC CLISPDEC0 GETLOCALDEC)
(LOCALFREEVARS FAULTFN))
(COMPILEUSERFNBLOCK COMPILEUSERFN COMPILEUSERFN1 CHECKTRAN (ENTRIES
COMPILEUSERFN)
(SPECVARS EXP)
(GLOBALVARS DWIMESSGAG CLISPTRANFLG CLISPARRAY DWIMFLG
NOFIXVARSLST0 NOFIXFNSLST NOFIXFNSLST0
NOFIXVARSLST FILEPKGFLG NOSPELLFLG
#CLISPARRAY))
(NIL DWIM (GLOBALVARS DWIMODELST DWIMFLG ADDSPELLFLG)
RETDWIM2 RETDWIM3 WTFIXLOADEF (GLOBALVARS DWIMKEYLST DWIMWAIT LCASEFLG
NOLINKMESS)
(LINKFNS . T)
(NOLINKFNS WTFIX)
CLISPTRAN
(GLOBALVARS RECORDSTATS CLISPTRANFLG CLISPARRAY #CLISPARRAY)
I.S.OPR
(GLOBALVARS I.S.OPRSLST CLISPFORWORDSPLST I.S.OPRLST FILEPKGFLG DFNFLG))
(NIL SPLIT89 (GLOBALVARS SKORLST3))
(NIL DWIMLOADFNS? (GLOBALVARS DWIMLOADFNSFLG))
(NIL CLISPERROR (GLOBALVARS DWIMESSGAG))
(NIL CLISP% (GLOBALVARS CLISPTRANFLG CLISPARRAY #CLISPARRAY)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA USEDFREE CLISP% NEWQUOTE)
(NLAML)
(LAMA FIXATOM2])
(DEFINEQ
(DWIM
[LAMBDA (X) (* wt: "22-OCT-78 21:02")
(COND
((NULL X)
(/PUTD (QUOTE FAULT1)
(GETD (QUOTE OLDFAULT1)))
(/SETATOMVAL (QUOTE DWIMFLG)
NIL)
(/SETATOMVAL (QUOTE ADDSPELLFLG)
NIL))
((SETQ X (ASSOC X DWIMODELST))
(/PUTD (QUOTE FAULT1)
(GETD (QUOTE NEWFAULT1)))
(/SETATOMVAL (QUOTE DWIMFLG)
T)
(/SETATOMVAL (QUOTE ADDSPELLFLG)
T)
[MAPC (CDDR X)
(FUNCTION (LAMBDA (X)
(AND (LISTP X)
(SET (CAR X)
(CDR X]
(CADR X))
(T (ERROR (QUOTE "not on DWIMODELST.")
(QUOTE "")
T])
(NEWQUOTE
[NLAMBDA X
(COND
((NULL (CDR X))
(CAR X))
(T (PROG (TEM)
[COND
([AND (NEQ (SETQ TEM (STKNAME (STKNTH -1)))
(QUOTE QUOTE))
(EQ (GETD TEM)
(GETD (QUOTE NEWQUOTE]
(* e.g. user didMOVD (QUOTE FOO) when he meant original quote, not new one
The EQ GETD check is just to make sure the STKNAME found the right guy.)
(/PUTD TEM (GETPROP (QUOTE QUOTE)
(QUOTE SUBR)))
(RETURN (CAR X]
(ERROR (QUOTE "parenthesis error in")
(CONS (QUOTE QUOTE)
X])
(NEWFAULT1
[LAMBDA (FAULTX FAULTARGS FAULTAPPLYFLG) (* lmm " 1-SEP-83 17:40")
(* Replaces FAULT1)
(PROG [(FAULTZ (if FAULTAPPLYFLG
then FAULTX
elseif (LISTP FAULTX)
then (CAR FAULTX]
(if [AND FAULTZ (LITATOM FAULTZ)
(GETD FAULTZ)
(SETQ FAULTZ (CHECKTRAN (GETD FAULTZ]
then (if FAULTAPPLYFLG
then (GO RETAPPLY)
else (SETQ FAULTZ (CONS FAULTZ (CDR FAULTX)))
(GO RETEVAL)))
(* Covers the case where an atom has a definition that has a clisp translation,
e.g. FOO is defined as (QLAMBDA --) There are two cases, FOO
(args) and (FOO args))
(if (LISTP FAULTX)
then (if (SETQ FAULTZ (CHECKTRAN FAULTX))
then
(* Covers the case where the form has a clis translation itself,
(most common), and the case where faultx is a function object being applied and
has a clisptranslation.)
(if FAULTAPPLYFLG
then (GO RETAPPLY)
else (GO RETEVAL)))
(if (AND (NULL FAULTAPPLYFLG)
(LISTP FAULTX)
(LISTP (SETQ FAULTZ (CAR FAULTX)))
(SETQ FAULTZ (CHECKTRAN FAULTZ)))
then (* Covers the case where car of form is a
function objection with a clisp
translation, e.g. ((QLAMBDA --) --))
(SETQ FAULTZ (CONS FAULTZ (CDR FAULTX)))
(GO RETEVAL)))
(SETQ FAULTZ (WTFIX FAULTX FAULTARGS FAULTAPPLYFLG))
(* info for diagnostic printed by
original FAULT1.)
(RETURN (OLDFAULT1 FAULTX FAULTARGS FAULTAPPLYFLG FAULTZ))
RETAPPLY
(RETAPPLY (FUNCTION FAULTAPPLY)
FAULTZ FAULTARGS T (QUOTE INTERNAL))
RETEVAL
(RETEVAL (QUOTE FAULTEVAL)
FAULTZ])
(CHECKTRAN
[LAMBDA (X) (* lmm "10-MAR-83 22:37")
(DECLARE (GLOBALVARS #CLISPARRAY CLISPARRAY CLISPTRANFLG))
(OR (AND CLISPARRAY (GETHASH X CLISPARRAY))
(AND CLISPTRANFLG (EQ (CAR X)
CLISPTRANFLG)
(PROG1 (CADR X)
(COND
((OR CLISPARRAY #CLISPARRAY)
(CLISPTRAN X (CADR X))
(/RPLNODE X (CADDR X)
(CDDDR X])
)
(RPAQQ DWIMODELST ((C CAUTIOUS (APPROVEFLG . T))
(T TRUSTING (APPROVEFLG))))
(RPAQQ DWIMWAIT 10)
(RPAQQ LCASEFLG T)
(DECLARE: DONTEVAL@LOAD DOCOPY
(SAVEDEF (QUOTE QUOTE))
(MOVD (QUOTE NEWQUOTE)
(QUOTE QUOTE))
)
(DEFINEQ
(RETDWIM2
[LAMBDA (X $TAIL N M) (* wt: 25-FEB-76 2 3)
(* N is a printlevel affecting TAILS, M one affecting
elementens. Value is a copy of X as though printed with
these levels.)
(AND (NULL N)
(SETQ N 3))
(AND (NULL M)
(SETQ M 1))
(RETDWIM3 X $TAIL N M])
(RETDWIM3
[LAMBDA (X $TAIL N1 M1) (* wt: 25-FEB-76 2 3)
(COND
((NLISTP X)
X)
((ILESSP M1 0)
(QUOTE &))
(T (CONS (RETDWIM3 (CAR X)
NIL N1 (SUB1 M1))
(COND
[$TAIL (COND
((EQ X $TAIL)
(* Only begin counting down when you reach TAIL.)
(RETDWIM3 (CDR X)
NIL
(SUB1 N1)
M1))
(T (RETDWIM3 (CDR X)
$TAIL N1 M1]
((IGREATERP N1 0)
(RETDWIM3 (CDR X)
$TAIL
(SUB1 N1)
M1))
((CDR X)
(QUOTE (--])
(FIXATOM2
[LAMBDA X (* Value is the last argument on the
stack.)
(ARG X X])
(SPLIT89
[LAMBDA (N POS)
(* Generates command that replaces atoms containing 8 or 9 with the
corresponding atom or atoms separated by the 8 or 9 so macro calling it can
determine where to insert or remove parentheses.)
(PROG (X Y Z)
(SETQ X (DUNPACK (CAR L)
SKORLST3))
[SETQ Y (COND
(POS (SETQ Y (NLEFT X POS)))
(T (FMEMB N X]
[COND
((NULL Y)
(* User has already corrected atom containing 8 or 9 Now we must guess what
form it is. Assume if N is 8, was error of form 8CONS, if 9, X9)
(RETURN (LIST (COND
((EQ N 8)
(QUOTE B))
(T (QUOTE A)))
N]
[COND
((CDR Y)
(SETQ Z (CONS (PACK (CDR Y))
Z]
(SETQ Z (CONS N Z))
[COND
((NEQ Y X)
(SETQ Z (CONS (PACK (LDIFF X Y))
Z]
(SETQ SPLIT89FLG Z)
(RETURN (CONS (QUOTE :)
Z])
(WTFIXLOADEF
[LAMBDA (FAULTEM1) (* lmm "11-JUN-81 11:07")
(* FAULTEM1 is the value of the FILEDEF property.)
(PROG (FAULTEM2 FAULTEM3)
(SETQ FAULTFN NIL) (* So file package wont try to update it)
(RETURN (COND
((AND DWIMIFYFLG DWIMIFYING))
((NULL (SETQ FAULTEM2 (FINDFILE (PACKFILENAME (QUOTE BODY)
[SETQ FAULTEM2
(COND
((ATOM FAULTEM1)
(* FAULTEM1 is the name of the file.)
FAULTEM1)
(T
(* (CAR FAULTEM1) is the name of the file.
CDR is the list of functions.)
(PROG1 (CAR FAULTEM1)
(SETQ FAULTEM1
(CDR FAULTEM1]
(QUOTE EXTENSION)
COMPILE.EXT)
T)))
(* If file isnt there dont bother to ask.)
NIL)
((COND
((OR (ATOM FAULTEM1)
(NLISTP (CAR FAULTEM1)))
(EQ (ASKUSER DWIMWAIT (QUOTE Y)
(LIST (QUOTE "Shall I load ")
FAULTEM1)
DWIMKEYLST)
(QUOTE Y)))
([STRINGP (SETQ FAULTEM3 (EVAL (PROG1 (CAR FAULTEM1)
(SETQ FAULTEM1 (CDR FAULTEM1]
(* (CAR FAULTEM1) computes either a string to be typed, or T or NIL, meaning do it or dont do it.
not sure if this is being used aaymore)
(FIXSPELL1 (QUOTE "")
FAULTEM3
(QUOTE "")
NIL
(QUOTE MUSTAPPROVE)))
(T FAULTEM3))
[PROG ((NOLINKMESS T))
(RETURN (COND
((ATOM FAULTEM1)
(LOAD FAULTEM2 (QUOTE SYSLOAD)))
(T (LOADFNS FAULTEM1 FAULTEM2 (QUOTE SYSLOAD]
T])
(CLISP%
[NLAMBDA CLISPX
(PROG (CLISPTEM)
[COND
((AND (OR CLISPARRAY #CLISPARRAY)
(EQ [CAR (SETQ CLISPTEM (PROG1 (BLIPVAL (QUOTE EVAL)
(SETQ CLISPTEM (STKNTH -1 CLISPTRANFLG)))
(RELSTK CLISPTEM]
CLISPTRANFLG)
(EQ (CDR CLISPTEM)
CLISPX))
(CLISPTRAN CLISPTEM (CADR CLISPTEM))
(/RPLNODE CLISPTEM (CADDR CLISPTEM)
(CDDDR CLISPTEM]
(RETURN (EVAL (CAR CLISPX)
(QUOTE INTERNAL])
)
(DEFINEQ
(VARSBOUNDINEDITCHAIN
[LAMBDA (EDITCHAIN) (* lmm "27-FEB-83 10:55")
(* Climbs EDITCHAIN and makes list of all bound variabes.
Sets EXPR to the top level expression, i.e.
(CAR (LAST EDITCHAIN)))
(MAPCONC EDITCHAIN (FUNCTION VARSBOUNDINFORM])
(VARSBOUNDINFORM
[LAMBDA (FORM) (* lmm "23-JUL-83 22:27")
(DECLARE (GLOBALVARS LAMBDASPLST COMPILERMACROPROPS))
(PROG ((FN (CAR FORM))
TEM MACRO)
(RETURN (AND (LITATOM FN)
(COND
((FMEMB FN LAMBDASPLST)
(APPEND (ARGLIST FORM)))
[(EQMEMB (QUOTE BINDS)
(GETPROP FN (QUOTE INFO)))
(MAPCAR (CADR FORM)
(FUNCTION (LAMBDA (X)
(COND
((NLISTP X)
X)
(T (CAR X]
((EQ [CAR (LISTP (SETQ TEM (GETPROP FN (QUOTE CLISPWORD]
(QUOTE FORWORD))
(PROG ((TAIL FORM)
VAL INVAR ELT)
FORWORDLP
(SETQ INVAR (SELECTQ (CDR TEM)
((for bind as)
T)
NIL))
LP (OR (SETQ TAIL (CDR TAIL))
(RETURN VAL))
(SETQ ELT (CAR TAIL))
[COND
((NOT (LITATOM ELT))
[COND
((AND INVAR (EQ (CADR (LISTP ELT))
(QUOTE ←)))
(SETQ VAL (CONS (CAR ELT)
VAL]
(GO LP))
((EQ [CAR (LISTP (SETQ TEM (GETPROP ELT (QUOTE CLISPWORD]
(QUOTE FORWORD))
(GO FORWORDLP))
((EQ ELT (QUOTE ←))
(SETQ TAIL (CDR TAIL)))
(INVAR (SETQ VAL (CONS ELT VAL]
(GO LP)))
((SETQ TEM (CHECKTRAN FORM))
(VARSBOUNDINFORM TEM))
((AND (SETQ TEM (GETLIS FN COMPILERMACROPROPS))
(NOT (EQUAL (SETQ TEM (MACROEXPANSION FORM (CADR TEM)))
FORM)))
(VARSBOUNDINFORM TEM])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: VARSBOUNDINEDITCHAIN VARSBOUNDINEDITCHAIN VARSBOUNDINFORM CHECKTRAN)
]
(* * DWIMLOADFNS?)
(DEFINEQ
(DWIMLOADFNS?
[LAMBDA NIL (* wt: "27-SEP-79 18:15")
(PROG [TEM (FN (COND
(FAULTAPPLYFLG FAULTX)
(T (CAR FAULTX]
(RETURN (COND
((AND DWIMLOADFNSFLG (NULL (AND DWIMIFYFLG DWIMIFYING))
(LITATOM FN)
(NULL (FGETD FN))
(SETQ TEM (EDITLOADFNS? FN))
(OR (EQ (CAR (SETQ TEM (LOADFNS (LISPXPRINT FN T T)
TEM)))
FN)
(PROGN (LISPXPRINT (CAR TEM)
T)
NIL)))
[AND (NULL TYPE-IN?)
(SETQ SIDES (CDR (LISTGET1 LISPXHIST (QUOTE SIDE]
FAULTX])
)
(APPENDTOVAR DWIMUSERFORMS (DWIMLOADFNS?))
(RPAQQ DWIMLOADFNSFLG T)
(DEFINEQ
(CLISPLOOKUP0
[LAMBDA (WORD VAR1 VAR2 DECLST LISPFN CLASS CLASSDEF)
(* lmm " 5-SEP-83 23:53")
(* LISPFN is returned if no local declaration is found affecting FN. CLASS is the CLASS for FN, e.g. RPLACA, +,
MEMB, etc. CLASS is supplied when looking up local record declaration (in his case it is RECORD) or when looking up
a local value for a variable, such as VARDEFAULT ina pattern match, in which case it is VALUE.)
(* To define a new class of functions a la RPLACA, FRPLACA, and /RPLACA, one must add all three names to DECLWORDS,
put the name of the standard one on the property lits of each under property CLISPCLASS, and put under the standard
one on property CLISPCLASSDEF the property (ACCESS standard undoable fast) version, where undoable or fast can be
NIL. Then CLISPDEC STANDARD, UNDOABLE, or FAST will have the right effect, and calling CLISPLOOKUP on the names of
either of the functions will eturn the current "Setting".)
(PROG (TEM)
[COND
((OR (NULL DECLST)
(NULL CLASS)) (* CLISPLOOKUP0 is always supposed to be called with a non-NIL CLASS and DECLST.)
(SHOULDNT (QUOTE CLISPLOOKUP0]
[OR CLASSDEF (SETQ CLASSDEF (GETPROP CLASS (QUOTE CLISPCLASSDEF]
(SETQ VAR1 (CLISPLOOKUP2 VAR1))
(SETQ VAR2 (CLISPLOOKUP2 VAR2))
(RETURN (COND
((SETQ TEM (CLISPLOOKUP1 DECLST))
TEM)
(T
(* The last GETP in the OR below , i.e. for CLASS, is so we dont have to implement global declaraions by puttig a
LISPFN property on each member of the class.)
(SELECTQ CLASS
(VALUE (GETATOMVAL WORD))
((RECORD RECORDFIELD)
NIL)
(OR LISPFN (GETPROP WORD (QUOTE LISPFN))
(GETPROP CLASS (QUOTE LISPFN))
WORD])
(CLISPLOOKUP1
[LAMBDA (LST) (* wt: 25-FEB-76 1 48)
(* Searches LST for a delcaration releveant to CLASS,
which is equal to (GETP WORD
(QUOTE CLISPCLASS.)))
(PROG (TEM VAL)
LP (COND
((NULL LST)
(RETURN VAL))
[(LISTP (SETQ TEM (CAR LST)))
(AND CLISPTRANFLG (EQ (CAR TEM)
CLISPTRANFLG)
(SETQ TEM (CDDR TEM)))
(COND
[(EQ (CADR TEM)
(QUOTE =))
(AND (EQ CLASS (QUOTE VALUE))
(EQ (CAR TEM)
WORD)
(SETQ VAL (CADDR TEM]
[(OR (EQ CLASS (QUOTE RECORD))
(EQ CLASS (QUOTE RECORDFIELD)))
(AND (FMEMB (CAR TEM)
CLISPRECORDTYPES)
[COND
[(EQ CLASS (QUOTE RECORDFIELD))
(FMEMB WORD (CAR (RECORDECL TEM]
(T (EQ WORD (CADR (RECORDECL TEM]
(SETQ VAL (CAR LST]
((EQ (CAR TEM)
CLASS)
(* So user can look up his own 'classes', e.g. say
(CLISP: (FOOTYPE)) and then look up FOOTYPE.
Terry uses this.)
(SETQ VAL (CAR LST)))
([AND (OR (EQ (SETQ TEM (CAAR LST))
VAR1)
(EQ TEM VAR2))
(SETQ TEM (CLISPLOOKUP1 (CDAR LST]
(RETURN TEM]
[[ATOM (SETQ TEM (GETPROP (CAR LST)
(QUOTE CLISPCLASS]
(* E.g. WORD is FRPLACA CLASS is RPLACA, and
(CAR LST) is /RPLACA. TEM is also RPLACA.)
(AND (EQ TEM CLASS)
(SETQ VAL (CAR LST]
([AND (EQ (CAR TEM)
(CAR CLASSDEF))
(SETQ TEM (CAR (NTH (CDR CLASSDEF)
(CDR TEM]
(* E.G. WORD is FRPLACA and (CAR LST) is FAST. or WORD is + and (CAR LST) is FLOATING. The eason for checking that
the nth element is not nil is that FAST does not apply to NCONC, even though both are ACCESS type declarations,
similaly, undoable does not apply to LAST.)
(SETQ VAL TEM)))
LP1 (SETQ LST (CDR LST))
(GO LP])
(CLISPLOOKUP2
[LAMBDA (X)
(COND
((NLISTP X)
X)
((OR (EQ (CAR X)
(QUOTE SETQ))
(EQ (CAR X)
(QUOTE SETQQ)))
(CADR X))
((EQ (CADR X)
(QUOTE ←))
(CAR X])
(CLISPERROR
[LAMBDA (TYPE FLG) (* wt: " 1-OCT-78 00:22")
(COND
(FLG (EVQ FAULTFN)
(EVQ PARENT)
(EVQ TAIL)
(EVQ TYPE-IN?)))
(AND (NULL DWIMESSGAG)
(NEQ TYPE (QUOTE ALREADYPRINTED))
(PROG (TEM AT IN)
(COND
((NULL TYPE-IN?)
(FIXPRINTIN FAULTFN)
(LISPXSPACES 1 T)))
(LISPXPRIN1 (SELECTQ [SETQ TEM (COND
((ATOM TYPE)
TYPE)
(T (CAR TYPE]
(1 (QUOTE "missing operand"))
(2 (QUOTE "missing operator"))
((: :: -> =>)
(LISPXPRIN1 (QUOTE "improper use of ")
T)
TEM)
(4 (QUOTE "bad if statement"))
(← (QUOTE "incorrect use of ←"))
(FIELDNAME (QUOTE "undefined field name"))
(PHRASE (QUOTE "can't parse this phrase"))
(CARATOM (QUOTE "car or cdr of non-list taken"))
(COND
((EQ (CAR (LISTP TEM))
(QUOTE BRACKET))
(LISPXPRIN1 (QUOTE "missing ")
T)
(CADR TEM))
(T TEM)))
T)
(COND
((LISTP TYPE)
(GO A))
((NEQ PARENT TAIL)
(LISPXPRIN1 (QUOTE " at ")
T)
(LISPXPRIN2 (RETDWIM2 (CAR TAIL))
T T)))
(LISPXPRIN1 (QUOTE " in ")
T)
(LISPXPRIN2 (RETDWIM2 (OR PARENT FAULTX)
TAIL)
T T)
(LISPXTERPRI T)
(RETURN)
A (SETQ AT (CADR TYPE))
(SETQ IN (CADDR TYPE))
(COND
((OR (EQ AT IN)
(NULL IN))
(LISPXPRIN1 (QUOTE " in ")
T)
(LISPXPRINT (RETDWIM2 AT)
T T)
(RETURN)))
(LISPXTERPRI T)
(LISPXPRIN1 (QUOTE "at ")
T)
(MAPRINT (RETDWIM2 AT (CDDR AT))
T
(QUOTE "... ")
(QUOTE %))
NIL NIL T)
(LISPXTERPRI T)
(LISPXPRIN1 (QUOTE "in ")
T)
(LISPXPRINT (RETDWIM2 IN)
T T)
(RETURN])
(CLISPDEC
[LAMBDA (DECLST) (* wt: "10-AUG-78 00:31")
(* Does global declaratin)
(AND DECLST (ATOM DECLST)
(SETQ DECLST (LIST DECLST)))
(PROG ((LST DECLST)
TEM CLASSDEF)
TOP (COND
((NULL LST)
(RETURN DECLST)))
(COND
[(LISTP (CAR LST))
(COND
((FMEMB (CAAR LST)
CLISPRECORDTYPES)
(EVAL (CAR LST)))
(T (GO ERROR]
[(FMEMB (CAR LST)
CLISPARITHCLASSLST)
(MAPC CLISPARITHOPLST
(FUNCTION (LAMBDA (X) (* E.g. X IS *, /, +, ETC.)
(COND
((SETQ TEM (GETPROP X (QUOTE LISPFN)))
(* May have been disabled)
(/REMPROP TEM (QUOTE CLISPINFIX))
(COND
([SETQ TEM (CAR (NTH [CDR (OR (GETPROP X (QUOTE CLISPCLASSDEF))
(GETPROP (GETPROP X (QUOTE CLISPCLASS))
(QUOTE CLISPCLASSDEF]
(CDR (GETPROP (CAR LST)
(QUOTE CLISPCLASS]
(/PUT X (QUOTE LISPFN)
TEM)
(* E.G. CLISPCLASS for FLOATING is (ARITH . 2), for * is (ARITH ITIMES FTIMES TIMES) meaning the FLOATING version
|
for * is FTIMES.)
(/PUT TEM (QUOTE CLISPINFIX)
X]
[(SETQ CLASSDEF (GETPROP (CAR LST)
(QUOTE CLISPCLASS)))
(COND
[(LISTP CLASSDEF)
(* e.g. clipdec (fast))
(MAPC DECLWORDS (FUNCTION (LAMBDA (X)
(COND
([AND [EQ (CAR CLASSDEF)
(CAR (SETQ TEM (GETPROP X (QUOTE CLISPCLASSDEF]
(SETQ TEM (CAR (NTH (CDR TEM)
(CDR CLASSDEF]
(/PUT X (QUOTE LISPFN)
TEM]
(T (* e.g. clispdec (fassoc))
(/PUT CLASSDEF (QUOTE LISPFN)
(CAR LST]
[(FMEMB (CAR LST)
DECLWORDS)
(COND
([ATOM (SETQ TEM (GETPROP (CAR LST)
(QUOTE CLISPCLASS]
(/PUT TEM (QUOTE LISPFN)
(CAR LST)))
(T (GO ERROR]
((SETQ TEM (OR (PROG (TYPE-IN? FAULTFN)
(RETURN (FIXSPELL (CAR LST)
NIL DECLWORDS)))
(GO ERROR)))
(/RPLNODE LST TEM (CDR LST))
(GO TOP)))
(SETQ LST (CDR LST))
(GO TOP)
ERROR
(ERROR (QUOTE "illegal declaration")
(CAR LST])
(CLISPDEC0
[LAMBDA (X FN) (* wt: 29-JUL-76 20 56)
(/RPLNODE X COMMENTFLG (CONS (QUOTE DECLARATIONS:)
(CLISPDEC1 (CDR X)
FN)))
(CDDR X])
(CLISPDEC1
[LAMBDA (X FAULTFN) (* wt: "13-JUN-78 17:31")
(MAPCON X (FUNCTION (LAMBDA (X)
(PROG (TEM TYPE-IN?)
TOP (RETURN (COND
[(LISTP (CAR X))
(LIST (COND
((OR (EQ (CADAR X)
(QUOTE =))
(FMEMB (CAAR X)
CLISPRECORDTYPES)
(EQ (CAAR X)
(QUOTE RECORDS)))
(CAR X))
(T (CONS (CAAR X)
(CLISPDEC1 (CDAR X]
((FMEMB (CAR X)
DECLWORDS)
(LIST (CAR X)))
((FIXSPELL (CAR X)
NIL DECLWORDS NIL X NIL NIL NIL (DUNPACK (CAR X)
SKORLST1))
(GO TOP))
(T (ERROR (QUOTE "illegal declaration")
(CAR X])
(GETLOCALDEC
[LAMBDA (EXPR FN) (* lmm " 7-JUL-83 23:33")
(AND (LISTP EXPR)
(COND
((FMEMB (CAR EXPR)
LAMBDASPLST)
(for (TL ←(CDDR EXPR)) by (CDR TL) while TL bind X when (LISTP (SETQ X (CAR TL)))
do (SELECTQ (CAR X)
(BREAK1 (SETQ TL (CADR X)))
[ADV-PROG (SETQ TL (CADR (CADAR (LAST (CADDR (CADDR X]
(COND
((AND (EQ (CAR X)
COMMENTFLG)
(EQ (CADR X)
(QUOTE DECLARATIONS:)))
(RETURN (CDDR X)))
[(EQ (CAR X)
(QUOTE CLISP:))
(RETURN (CLISPDEC0 X (OR FN FAULTFN]
((FMEMB (CAR X)
(QUOTE (DECLARE DECLARE:)))
(RETURN (for Y in (CDR X)
do [COND
((EQ (CAR Y)
(QUOTE CLISP:))
(RETURN (CDR Y]
(COND
((AND (EQ (CAR Y)
COMMENTFLG)
(EQ (CADR Y)
(QUOTE DECLARATIONS:)))
(RETURN (CDDR Y])
)
(RPAQQ PRINTOUTCOMS ((FNS PRINTCOMSTRAN PRINTOUTTRAN)
(BLOCKS (NIL PRINTCOMSTRAN PRINTOUTTRAN (LOCALVARS . T)
(GLOBALVARS COMMENTFLG LCASEFLG PRINTOUTMACROS)))
(ADDVARS (PRINTOUTMACROS))
(VARS PRINTOUTTOKENS)
(PROP CLISPWORD PRINTOUT printout)
(* USED IN TRANSLATIONS)
(FNS FLUSHRIGHT PRINTPARA PRINTPARA1)))
(DEFINEQ
(PRINTCOMSTRAN
[LAMBDA (FORM TAIL MACROS FILEFORM FROMDWIM) (* rmk: "31-Dec-83 13:40")
(* This function computes the translations for PRINTOUT type CLISP forms. FORM is the form beginning with the
CLISPWORD. After it is dwimified, TAIL is applied to obtain the TAIL of printing commands.
If FILEFORM~=NIL, it is applied to FORM after dwimification to produce the output file specification.)
(AND FROMDWIM (SETQ CLISPCHANGE T))
(PROG (FORMATLIST (VARS (APPEND (MAPCAR MACROS (FUNCTION CAR))
PRINTOUTTOKENS VARS)))
(DECLARE (SPECVARS VARS))
(for ARG in (CDR FORM) bind (TYPE POINT WIDTH)
when [AND (LITATOM ARG)
(NOT (FASSOC ARG FORMATLIST))
(EQ (CHCON1 ARG)
(CHARCODE %.))
(SELCHARQ (SETQ TYPE (NTHCHARCODE ARG 2))
((I F)
T)
NIL)
(FIXP (SETQ WIDTH (SUBATOM ARG 3 (AND (SETQ POINT (STRPOS (QUOTE %.)
ARG 3))
(SUB1 POINT]
do (SETQ VARS (CONS ARG VARS)) (* Suppress spelling-correction of formatcode atoms)
(SETQ FORMATLIST
(CONS [CONS ARG (KWOTE (CONS (COND
((EQ TYPE (CHARCODE I))
(QUOTE FIX))
(T (QUOTE FLOAT)))
(CONS WIDTH
(while POINT
collect (SUBATOM
ARG
(ADD1 POINT)
(AND (SETQ POINT
(STRPOS (QUOTE %.)
ARG
(ADD1 POINT)))
(SUB1 POINT]
FORMATLIST))) (* Since we did all the work to decode the format, save
it for later.)
(AND FROMDWIM (DWIMIFY0? (CDR FORM)
FORM NIL NIL NIL FAULTFN))
[COND
(FILEFORM (SETQ FILEFORM (LIST (COND
((EQ FILEFORM T)
T)
(T (APPLY* FILEFORM FORM]
(SETQ TAIL (APPLY* TAIL FORM))
(RETURN
(while TAIL bind (ARG TEMP RESETOUT)
collect
[COND
((SETQ TEMP (ASSOC (CAR TAIL)
MACROS))
(SETQ RESETOUT T) (* Probably should pass FILEFORM to macrofn, but then
would have to explain interface, smashing etc.)
(SETQ TAIL (APPLY* (CADR TEMP)
TAIL))
(pop TAIL))
(T (SELECTQ (SETQ ARG (pop TAIL))
(.TAB0 (BQUOTE (TAB , (pop TAIL)
0 ,@ FILEFORM)))
(.TAB (BQUOTE (TAB , (pop TAIL)
NIL ,@ FILEFORM)))
((0 T)
(BQUOTE (TERPRI ,@ FILEFORM)))
(.RESET (BQUOTE (PRIN1 (CONSTANT (CHARACTER (CHARCODE CR)))
,@ FILEFORM)))
(# (SETQ RESETOUT T)
(pop TAIL))
(.P2 (BQUOTE (PRIN2 , (pop TAIL)
,@ FILEFORM)))
((.PPF .PPV .PPFTL .PPVTL)
(BQUOTE (PRINTDEF , (pop TAIL)
(POSITION ,@ FILEFORM)
,
(OR (EQ ARG (QUOTE .PPF))
(EQ ARG (QUOTE .PPFTL)))
,
(OR (EQ ARG (QUOTE .PPVTL))
(EQ ARG (QUOTE .PPFTL)))
NIL ,@ FILEFORM)))
(.FONT (SETQ ARG (pop TAIL))
(BQUOTE (CHANGEFONT , (COND
((FIXP ARG)
(PACK* (QUOTE FONT)
ARG))
(T ARG))
,@ FILEFORM)))
[(.SUB .SUP .BASE)
(BQUOTE
(AND FONTCHANGEFLG
(PROGN (CHANGEFONT SUPERSCRIPTFONT ,@ FILEFORM)
(PRIN3 , (KWOTE (SELECTQ ARG
(.SUB (CONSTANT (CHARACTER
20)))
(.SUP (CONSTANT (CHARACTER
8)))
(.BASE (CONSTANT (CHARACTER
14)))
NIL))
,@ FILEFORM]
(, (BQUOTE (SPACES 1 ,@ FILEFORM)))
(,, (BQUOTE (SPACES 2 ,@ FILEFORM)))
(,,, (BQUOTE (SPACES 3 ,@ FILEFORM)))
(.SP (BQUOTE (SPACES , (pop TAIL)
,@ FILEFORM)))
[.SKIP (BQUOTE (FRPTQ , (pop TAIL)
(TERPRI ,@ FILEFORM]
(.N (BQUOTE (PRINTNUM , (pop TAIL)
,
(pop TAIL)
,@ FILEFORM)))
((.FR .FR2 .CENTER .CENTER2)
(BQUOTE (FLUSHRIGHT , (pop TAIL)
,
(pop TAIL)
0 , (SELECTQ ARG
((.FR2 .CENTER2)
T)
NIL)
,
(SELECTQ ARG
((.CENTER .CENTER2)
T)
NIL)
,@ FILEFORM)))
((.PARA .PARA2)
(BQUOTE (PRINTPARA , (pop TAIL)
,
(pop TAIL)
,
(pop TAIL)
,
(EQ ARG (QUOTE .PARA2))
NIL ,@ FILEFORM)))
[.PAGE (BQUOTE (PROGN (PRIN3 , (KWOTE (CHARACTER (CHARCODE FORM)))
,@ FILEFORM)
(POSITION (PROGN ,@ FILEFORM)
0]
(COND
((SETQ TEMP (CDR (FASSOC ARG FORMATLIST)))
(BQUOTE (PRINTNUM , TEMP , (pop TAIL)
,@ FILEFORM)))
((NOT (FIXP ARG))
(BQUOTE (PRIN1 , ARG ,@ FILEFORM)))
((MINUSP ARG)
(BQUOTE (SPACES , (IMINUS ARG)
,@ FILEFORM)))
(T (BQUOTE (TAB , ARG NIL ,@ FILEFORM]
finally (RETURN (COND
((AND (CAR FILEFORM)
RESETOUT)
(BQUOTE (RESETFORM (OUTPUT , (PROG1 (CAR FILEFORM)
(RPLACA FILEFORM NIL)))
,@ $$VAL)))
[(LISTP (CAR FILEFORM))
(BQUOTE ([LAMBDA ($$OUTPUT)
(DECLARE (LOCALVARS $$OUTPUT))
,@ $$VAL]
,
(PROG1 (CAR FILEFORM)
(RPLACA FILEFORM (QUOTE $$OUTPUT]
(T (CONS (QUOTE PROGN)
$$VAL])
(PRINTOUTTRAN
[LAMBDA (FORM) (* lmm "11-NOV-82 16:52")
(* Performs the printing translation for PRINTOUT. Uses lambda to bind variables so RETURN's inside the printout
form will go through the PROG in the user's code.)
(CLISPTRAN FORM (PRINTCOMSTRAN FORM (QUOTE CDDR)
PRINTOUTMACROS
(QUOTE CADR)
T))
(AND LCASEFLG (NEQ (CAR FORM)
(QUOTE printout))
(/RPLNODE FORM (QUOTE printout)
(CDR FORM)))
FORM])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL PRINTCOMSTRAN PRINTOUTTRAN (LOCALVARS . T)
(GLOBALVARS COMMENTFLG LCASEFLG PRINTOUTMACROS))
]
(ADDTOVAR PRINTOUTMACROS )
(RPAQQ PRINTOUTTOKENS (.RESET .TAB # , ,, ,,, .P2 .PPF .PPV .PPFTL .PPVTL .TAB0 .FR .FR2 .CENTER
.CENTER2 .PARA .PARA2 .PAGE .FONT .SUP .SUB .BASE .SP .SKIP .N))
(PUTPROPS PRINTOUT CLISPWORD (PRINTOUTTRAN . printout))
(PUTPROPS printout CLISPWORD (PRINTOUTTRAN . printout))
(* USED IN TRANSLATIONS)
(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])
)
(DEFINEQ
(COMPILEUSERFN
[LAMBDA (X Y) (* lmm "26-FEB-83 06:31")
(PROG (TEM)
(RETURN (COND
((CHECKTRAN Y))
[(LISTP (CAR Y))
(COND
((SETQ TEM (CHECKTRAN (CAR Y)))
(CONS TEM (CDR Y)))
(DWIMFLG (COMPILEUSERFN1 Y)
(COND
((CHECKTRAN Y))
((SETQ TEM (CHECKTRAN (CAR Y)))
(CONS TEM (CDR Y]
([AND (NLISTP (GETPROP (CAR Y)
(QUOTE CLISPWORD)))
(NOT (AND (FMEMB (CAR Y)
LAMBDASPLST)
(NOT (FMEMB (CAR Y)
(QUOTE (LAMBDA NLAMBDA]
NIL)
(DWIMFLG (COMPILEUSERFN1 Y)
(COND
((AND CLISPARRAY (GETHASH Y CLISPARRAY)))
((AND CLISPTRANFLG (EQ (CAR Y)
CLISPTRANFLG))
(CADR Y))
((NULL (GETPROP (CAR Y)
(QUOTE CLISPWORD)))
(* IF's are transled directly into COND's, and dont use hashing.)
Y)
((NULL DWIMESSGAG)
(* user can set DWIMESSGAG to T and go away and the compilation will go through.)
(PRIN1 (QUOTE "unable to dwimify ")
T)
(PRINT Y T)
(CAR (NLSETQ ([LAMBDA (EXP)
(BREAK1 EXP T compilation]
Y])
(COMPILEUSERFN1
[LAMBDA (Y) (* lmm "24-SEP-81 23:46")
(PROG [(FLG (AND (LISTP COREFLG)
(CDR (FASSOC FN COREFLG]
(RESETVARS ((NOSPELLFLG (OR NOSPELLFLG (NULL FLG)))
(FILEPKGFLG (AND FILEPKGFLG FLG)))
(* FILEKGFLG is T when when compiling from in core, so that if function is
changed, it will be marked.)
(SETQ NOFIXFNSLST0 NOFIXFNSLST)
(SETQ NOFIXVARSLST0 NOFIXVARSLST)
(DWIMIFY0 Y FN (UNION ARGS OTHERVARS)
DEF)
(COND
((TAILP NOFIXFNSLST NOFIXFNSLST0)
(* For purposes of compilation, want anything added to NOFIXFNSLST0 to persist
throughout copiling the whole file.)
(SETQ NOFIXFNSLST NOFIXFNSLST0)))
(COND
((TAILP NOFIXVARSLST NOFIXVARSLST0)
(SETQ NOFIXVARSLST NOFIXVARSLST0])
(USEDFREE
[NLAMBDA A (* wt: "20-SEP-77 22:10")
(* permits the user to declare freevars which will then
|
be "noticed" by dwimify in thatthey wont be spelling
|
corrected.)
(SETQ FREEVARS (APPEND A FREEVARS])
(CLISPTRAN
[LAMBDA (X TRAN) (* rmk: " 3-Jan-84 13:16")
(COND
((OR CLISPARRAY (COND
(#CLISPARRAY (SETQ CLISPARRAY (HASHARRAY #CLISPARRAY))
(SETQ #CLISPARRAY NIL) (* Latter so user can turn clisphashing on and off by
simply reseting CLISPARRAY.)
T))) (* Otherwise use CLISP% translation.)
(/PUTHASH X TRAN CLISPARRAY))
(TRAN (* Can be called erase a translation.)
(/RPLNODE X CLISPTRANFLG (CONS TRAN (CONS (CAR X)
(CDR X])
)
(DEFINEQ
(CLISPFORERR
[LAMBDA (X Y TYPE) (* lmm " 4-SEP-83 22:56")
(AND (NULL DWIMESSGAG)
(PROG (TEM)
(AND (FIXPRINTIN FAULTFN)
(SPACES 1 T))
(LISPXPRIN1 (QUOTE "error in iterative statement")
T)
(AND TYPE (LISPXPRINT (QUOTE ,)
T)
(LISPXPRIN1 (SELECTQ TYPE
(BOTH (QUOTE "can't use both of these operators together"))
(TWICE (QUOTE "operator appears twice"))
(MISSING (QUOTE "missing operand"))
(WHAT (LISPXPRIN1 (CADR X)
T)
(QUOTE " what ? (no i.v. specified)"))
NIL)
T))
(LISPXPRINT (QUOTE :)
T)
(COND
((OR (AND X (NLISTP X))
(AND Y (NLISTP Y)))
(LISPXPRIN2 X T T)
(AND Y (LISPXPRIN2 Y T T))
(RETURN))
((TAILP X Y)
(SETQ TEM X)
(SETQ X Y)
(SETQ Y TEM)))
(CLISPFORERR1 X Y)
(COND
(Y (LISPXSPACES 1 T)
(CLISPFORERR1 Y)))
(TERPRI T)
(RETURN)))
(DWIMERRORRETURN])
(CLISPFORERR1
[LAMBDA (X Y) (* wt: 25-MAR-77 22 58)
(PROG (TEM)
(COND
((NEQ X I.S.)
(LISPXPRIN1 (QUOTE " ... ")
T)))
(SETQ TEM (OR [CADADR (SOME I.S.PTRS (FUNCTION (LAMBDA (Z)
(TAILP (CADR Z)
X]
Y))
LP (LISPXPRIN2 (RETDWIM2 (CAR X)
NIL 3)
T T)
(COND
((AND (SETQ X (CDR X))
(NEQ X TEM))
(LISPXSPACES 1 T)
(GO LP])
(I.S.OPR
[LAMBDA (NAME FORM OTHERS EVALFLG) (* wt: "18-SEP-78 23:22")
(* E.g. NAME=SUM, FORM= (SETQ $$VAL ($$VAL + BODY)), OTHERS= (FIRST $$VAL←0) I f evalflg is T, means form and others
are to be EVALUATED at translation time.)
(PROG ((UC (U-CASE NAME))
LC NEWPROP OLDPROP NEWFLG)
[COND
((NEQ NAME UC)
(* LC is the name used for clispifying. for mostcases it is the lower case, but thi check lets users define i.s.oprs
|
contaiing some lowercase and some uppercase letters)
(SETQ LC NAME))
(T (SETQ LC (L-CASE NAME] (* so tha user can call it with either loer or uppercase
|
version.)
(SETQ NEWFLG (NEQ (CAR (GETP LC (QUOTE CLISPWORD)))
(QUOTE FORWORD)))
(COND
((AND FORM (ATOM FORM)
(NEQ FORM (QUOTE MODIFIER)))
(* Synonym)
(/PUT UC (QUOTE CLISPWORD)
(SETQ NEWPROP (LIST (QUOTE FORWORD)
LC FORM)))
(SETQ OLDPROP (GETP LC (QUOTE CLISPWORD)))
(/PUT LC (QUOTE CLISPWORD)
NEWPROP)
(/REMPROP LC (QUOTE I.S.OPR)))
((AND OTHERS (NLISTP OTHERS)
(NULL EVALFLG))
(ERROR "OTHERS must be a list of operators and operands" OTHERS))
((AND OTHERS (NEQ (CAR (GETPROP (CAR OTHERS)
(QUOTE CLISPWORD)))
(QUOTE FORWORD))
(NULL EVALFLG))
(ERROR (QUOTE "OTHERS must begin with an operator")
OTHERS))
(T (/PUT UC (QUOTE CLISPWORD)
(SETQ NEWPROP (CONS (QUOTE FORWORD)
LC)))
(/PUT LC (QUOTE CLISPWORD)
NEWPROP)
[SETQ NEWPROP (COND
((EQ FORM (QUOTE MODIFIER))
(QUOTE MODIFIER))
[EVALFLG (CONS (AND FORM (CONS (QUOTE =)
FORM))
(AND OTHERS (CONS (QUOTE =)
OTHERS]
(T (CONS FORM OTHERS]
(SETQ OLDPROP (GETP LC (QUOTE I.S.OPR)))
(/PUT LC (QUOTE I.S.OPR)
NEWPROP)))
[COND
((EQUAL NEWPROP OLDPROP)
(RETURN NAME))
[(NULL NEWFLG)
(* redefined)
[COND
((EQ UC (QUOTE COLLECT))
(/REMPROP (QUOTE fcollect)
(QUOTE I.S.OPR]
(AND (NEQ DFNFLG T)
(LISPXPRINT [CONS (QUOTE i.s.opr)
(CONS NAME (QUOTE (redefined]
T))
(AND CLISPARRAY (MAPHASH CLISPARRAY (FUNCTION (LAMBDA (TRAN EXP)
(AND (OR (MEMB UC EXP)
(MEMB LC EXP))
(/PUTHASH EXP NIL CLISPARRAY]
(T (* defined for the first time)
(/NCONC1 CLISPFORWORDSPLST UC)
(/NCONC I.S.OPRLST (LIST UC LC]
(AND FILEPKGFLG (MARKASCHANGED (COND
((EQ NAME UC)
UC)
(T
(* file package doesnt care whether you give upper or lower case named to dumpi.s.oprs, however if user took pains
|
to define thi i.ssop giving it a owercase definition, (Or mixed upper and lower case) then inform him about this
|
i.s.opr in that fashion.)
LC))
(QUOTE I.S.OPRS)
NEWFLG))
(RETURN NAME])
(WARNUSER
[LAMBDA (X) (* wt: "24-MAR-80 08:23")
[SOME PROGVARS (FUNCTION (LAMBDA (VAR)|
(COND|
((EDITFINDP (CADR X)|
(COND|
((LISTP VAR)|
(CAR VAR))|
(T VAR)))|
(PROG (TEM)|
(LISPXPRIN1 "****Warning: the iterative statement:
" T)|
(LISPXPRIN2 (RETDWIM2 EXP NIL 8 2)|
T)|
(LISPXPRIN1 "
now translates so that " T)|
(CLISPFORERR1 X T)|
(LISPXPRIN1 " ... is evaluated BEFORE " T)|
(COND|
((LISTP VAR)|
(LISPXPRIN2 (CAR VAR)|
T)|
(LISPXPRIN1 " is bound and initialized to:
" T)|
(LISPXPRIN2 (RETDWIM2 (CADR VAR)|
3)|
T))|
(T (LISPXPRIN1 " it is bound" T)))|
(LISPXTERPRI T))|
T]|
(CADR X])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(ADDTOVAR NLAML BREAK1)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NEWFAULT1BLOCK NEWFAULT1 CHECKTRAN (ENTRIES NEWFAULT1)
(GLOBALVARS #CLISPARRAY)
(NOLINKFNS WTFIX))
(BLOCK: CLISPLOOKUP0 CLISPLOOKUP0 CLISPLOOKUP1 CLISPLOOKUP2 (GLOBALVARS DECLWORDS CLISPRECORDTYPES
CLISPTRANFLG)
(LOCALFREEVARS WORD CLASS CLASSDEF VAR1 VAR2)
(NOLINKFNS RECORDECL))
(BLOCK: CLISPFORERRBLOCK WARNUSER CLISPFORERR CLISPFORERR1 (GLOBALVARS DWIMESSGAG)
(ENTRIES CLISPFORERR WARNUSER))
(BLOCK: CLISPDECBLOCK CLISPDEC CLISPDEC0 CLISPDEC1 GETLOCALDEC (GLOBALVARS CLISPRECORDTYPES DECLWORDS
CLISPARITHOPLST
CLISPARITHCLASSLST
COMMENTFLG SKORLST1)
(ENTRIES CLISPDEC CLISPDEC0 GETLOCALDEC)
(LOCALFREEVARS FAULTFN))
(BLOCK: COMPILEUSERFNBLOCK COMPILEUSERFN COMPILEUSERFN1 CHECKTRAN (ENTRIES COMPILEUSERFN)
(SPECVARS EXP)
(GLOBALVARS DWIMESSGAG CLISPTRANFLG CLISPARRAY DWIMFLG NOFIXVARSLST0 NOFIXFNSLST NOFIXFNSLST0
NOFIXVARSLST FILEPKGFLG NOSPELLFLG #CLISPARRAY))
(BLOCK: NIL DWIM (GLOBALVARS DWIMODELST DWIMFLG ADDSPELLFLG)
RETDWIM2 RETDWIM3 WTFIXLOADEF (GLOBALVARS DWIMKEYLST DWIMWAIT LCASEFLG NOLINKMESS)
(LINKFNS . T)
(NOLINKFNS WTFIX)
CLISPTRAN
(GLOBALVARS RECORDSTATS CLISPTRANFLG CLISPARRAY #CLISPARRAY)
I.S.OPR
(GLOBALVARS I.S.OPRSLST CLISPFORWORDSPLST I.S.OPRLST FILEPKGFLG DFNFLG))
(BLOCK: NIL SPLIT89 (GLOBALVARS SKORLST3))
(BLOCK: NIL DWIMLOADFNS? (GLOBALVARS DWIMLOADFNSFLG))
(BLOCK: NIL CLISPERROR (GLOBALVARS DWIMESSGAG))
(BLOCK: NIL CLISP% (GLOBALVARS CLISPTRANFLG CLISPARRAY #CLISPARRAY))
]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA USEDFREE CLISP% NEWQUOTE)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA FIXATOM2)
)
(PUTPROPS DWIM COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2923 6418 (DWIM 2933 . 3556) (NEWQUOTE 3558 . 4131) (NEWFAULT1 4133 . 6023) (CHECKTRAN
6025 . 6416)) (6657 11043 (RETDWIM2 6667 . 7081) (RETDWIM3 7083 . 7701) (FIXATOM2 7703 . 7853) (
SPLIT89 7855 . 8821) (WTFIXLOADEF 8823 . 10571) (CLISP% 10573 . 11041)) (11044 12886 (
VARSBOUNDINEDITCHAIN 11054 . 11383) (VARSBOUNDINFORM 11385 . 12884)) (13039 13644 (DWIMLOADFNS? 13049
. 13642)) (13723 24042 (CLISPLOOKUP0 13733 . 15631) (CLISPLOOKUP1 15633 . 17731) (CLISPLOOKUP2 17733
. 17935) (CLISPERROR 17937 . 19847) (CLISPDEC 19849 . 22188) (CLISPDEC0 22190 . 22402) (CLISPDEC1
22404 . 23097) (GETLOCALDEC 23099 . 24040)) (24405 30431 (PRINTCOMSTRAN 24415 . 29918) (PRINTOUTTRAN
29920 . 30429)) (30951 35085 (FLUSHRIGHT 30961 . 31636) (PRINTPARA 31638 . 32609) (PRINTPARA1 32611 .
35083)) (35086 38294 (COMPILEUSERFN 35096 . 36336) (COMPILEUSERFN1 36338 . 37249) (USEDFREE 37251 .
37647) (CLISPTRAN 37649 . 38292)) (38295 43946 (CLISPFORERR 38305 . 39313) (CLISPFORERR1 39315 . 39793
) (I.S.OPR 39795 . 43035) (WARNUSER 43037 . 43944)))))
STOP