(FILECREATED "19-Jun-86 15:09:01" {ERIS}<LISPCORE>SOURCES>DWIM.;7 37429
changes to: (FNS COMPILEUSERFN1)
(VARS DWIMCOMS)
previous date: "21-Jan-86 00:41:34" {ERIS}<LISPCORE>SOURCES>DWIM.;6)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(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)
(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))
(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
NOFIXFNSLST0 #CLISPARRAY))
(NIL DWIM (GLOBALVARS DWIMODELST DWIMFLG)
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))
(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) (* lmm "23-Aug-84 17:56")
(* 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 (RECORDFIELDNAMES TEM)))
(T (EQ WORD 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 "26-Sep-84 16:38")
(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 (CAR (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])
)
(DEFINEQ
(COMPILEUSERFN
[LAMBDA (X Y) (* hdj " 1-Feb-85 15:22")
(* * this is an awful patch to fix the fact that COMPILEUSERFN1 is UNIONing something with OTHERVARS, which is an
unbound specvar)
(OR (BOUNDP (QUOTE OTHERVARS))
(SETQ OTHERVARS NIL))
(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 "19-Jun-86 13:59")
(PROG [(FLG (AND (LISTP COREFLG)
(CDR (FASSOC FN COREFLG]
(LET ((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) (* bvm: "21-Jan-86 00:41")
(COND
((OR CLISPARRAY (COND
(#CLISPARRAY (SETQ CLISPARRAY (HASHARRAY #CLISPARRAY NIL NIL NIL T))
(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))
(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 NOFIXFNSLST0 #CLISPARRAY)
)
(BLOCK: NIL DWIM (GLOBALVARS DWIMODELST DWIMFLG)
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))
(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 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4216 7711 (DWIM 4226 . 4849) (NEWQUOTE 4851 . 5424) (NEWFAULT1 5426 . 7316) (CHECKTRAN
7318 . 7709)) (7964 12350 (RETDWIM2 7974 . 8388) (RETDWIM3 8390 . 9008) (FIXATOM2 9010 . 9160) (
SPLIT89 9162 . 10128) (WTFIXLOADEF 10130 . 11878) (CLISP% 11880 . 12348)) (12351 14193 (
VARSBOUNDINEDITCHAIN 12361 . 12690) (VARSBOUNDINFORM 12692 . 14191)) (14346 14951 (DWIMLOADFNS? 14356
. 14949)) (15030 25543 (CLISPLOOKUP0 15040 . 16950) (CLISPLOOKUP1 16952 . 18980) (CLISPLOOKUP2 18982
. 19184) (CLISPERROR 19186 . 21096) (CLISPDEC 21098 . 23437) (CLISPDEC0 23439 . 23651) (CLISPDEC1
23653 . 24346) (GETLOCALDEC 24348 . 25541)) (25544 29689 (COMPILEUSERFN 25554 . 27269) (COMPILEUSERFN1
27271 . 28583) (USEDFREE 28585 . 28981) (CLISPTRAN 28983 . 29687)) (29690 35341 (CLISPFORERR 29700 .
30708) (CLISPFORERR1 30710 . 31188) (I.S.OPR 31190 . 34430) (WARNUSER 34432 . 35339)))))
STOP