(FILECREATED "19-Jun-86 15:10:34" {ERIS}<LISPCORE>SOURCES>MSANALYZE.;4 33622
changes to: (FNS ALLCALLS MSPRGDWIM)
(VARS MSANALYZECOMS)
previous date: "27-May-86 05:17:35" {ERIS}<LISPCORE>SOURCES>MSANALYZE.;3)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved. The following
program was created in 1982 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 MSANALYZECOMS)
(RPAQQ MSANALYZECOMS
[(COMS (FNS VARS FREEVARS CALLS COLLECTFNDATA CALLS3)
(VARS MSMACROPROPS (NOPACKCALLSFLG))
(BLOCKS (CALLS CALLS COLLECTFNDATA CALLS3 (LOCALFREEVARS CALLSDATA)
(NOLINKFNS . T)
(GLOBALVARS INVISIBLEVARS COMPILEUSERFN NOPACKCALLSFLG LAMBDASPLST
MSRECORDTRANFLG))
(NIL VARS FREEVARS (LOCALVARS . T)))
(DECLARE: EVAL@COMPILE (VARS MS.VERB.TO.NOTICED)
DONTCOPY
(MACROS MSVBNOTICED)))
[COMS (FNS ALLCALLS MSINITFNDATA MSPRGE MSPRGMACRO MSPRGCALL MSBINDVAR MSPRGRECORD MSPRGERR
MSPRGTEMPLATE1 MSPRGTEMPLATE MSPRGLAMBDA MSPRGLST ADDTO NLAMBDAFNP MSPRGDWIM
MSDWIMTRAN)
(E (MAPC MSFNDATA (FUNCTION RPLACD)))
(VARS MSFNDATA MSERRORFN (MSRECORDTRANFLG))
(ADDVARS (INVISIBLEVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14
$$15 $$16 $$17))
(DECLARE: DONTCOPY (MACROS INCLISP LTEMPLATE))
(BLOCKS (ALLCALLS ALLCALLS ADDTO MSBINDVAR MSDWIMTRAN MSPRGCALL MSPRGDWIM MSPRGE
MSPRGMACRO MSPRGERR MSPRGLAMBDA MSPRGLST MSPRGRECORD MSPRGTEMPLATE
MSPRGTEMPLATE1 NLAMBDAFNP (NOLINKFNS . T)
(LOCALFREEVARS FNNAME ERRORS FNDEF INCLISP ONLYRELS PARENTCONTEXT
TOPVARS PARENT EACHTIME VARS)
(GLOBALVARS CLISPARRAY MSERRORFN MSRECORDTRANFLG MSFNDATA INVISIBLEVARS
CLISPARRAY MSTEMPLATES USERTEMPLATES MSRECORDTRANFLG NLAMA NLAML
DWIMFLG CLISPTRANFLG DWIMESSGAG)
(NOLINKFNS . T))
(NIL MSINITFNDATA NLAMBDAFNP MSPRGDWIM (LOCALVARS . T)
(GLOBALVARS NLAMA NLAML MSFNDATA DWIMFLG DWIMESSGAG)))
(P (PUTDQ? MSWORDNAME (LAMBDA (X)
X]
(COMS (VARS (MSTEMPLATES (HASHARRAY 160))
(USERTEMPLATES (HASHARRAY 10)))
(FILEVARS INITIALTEMPLATES)
(* * INITIALTEMPLATES is not needed after loading up)
[P (MAPC INITIALTEMPLATES (FUNCTION (LAMBDA (X)
(MAPC (CDR X)
(FUNCTION (LAMBDA (Y)
(PUTHASH Y
(CAR X)
MSTEMPLATES]
(DECLARE: EVAL@COMPILE DONTCOPY (PROP MACRO LTEMPLATE)))
(COMS (FNS MSFINDP)
(BLOCKS (MSFINDP MSFINDP])
(DEFINEQ
(VARS
(LAMBDA (FN USEDATABASE) (* lmm: 29-DEC-75 27Q 26Q) (CDR (CALLS FN USEDATABASE T))))
(FREEVARS
(LAMBDA (FN USEDATABASE) (* lmm: 5-DEC-75 13Q 10Q) (CADDR (CALLS FN USEDATABASE (QUOTE FREEVARS)))))
(CALLS
(LAMBDA (EXPR USEDATABASE VARSFLG) (* rmk: " 1-AUG-79 09:55") (PROG (FREES FNDEF FLG) (COND ((AND
USEDATABASE (LITATOM EXPR) (GETD (QUOTE UPDATEFN))) (UPDATEFN EXPR NIL (QUOTE ERROR)) (RETURN (LIST (
AND (NOT VARSFLG) (GETRELATION EXPR (QUOTE (CALL NOTERROR)))) (AND (NEQ VARSFLG (QUOTE FREEVARS)) (
GETRELATION EXPR (QUOTE BIND))) (GETRELATION EXPR (QUOTE (USE FREELY))))))) GETDLP (SETQ FNDEF (COND (
(LITATOM EXPR) (OR (GETD (OR (GETP EXPR (QUOTE BROKEN)) EXPR)) (GETP EXPR (QUOTE EXPR)) (AND (NEQ EXPR
(SETQ EXPR (FNCHECK EXPR NIL NIL T))) (GO GETDLP)))) (T EXPR))) (RETURN (COND ((NULL FNDEF) NIL) ((
SUBRP FNDEF) NIL) ((CCODEP FNDEF) (SETQ FNDEF (CALLSCCODE FNDEF)) (OR NOPACKCALLSFLG (for X on (CAR
FNDEF) do (FRPLACA X (PACK* (QUOTE ;) (CAR X) (QUOTE ;))))) (FRPLACA (CDR FNDEF) (NCONC (CADR FNDEF) (
CAR FNDEF))) (SETQ FLG) (CALLS3 (CDDR FNDEF)) (CALLS3 (CDDDR FNDEF)) (CDR FNDEF)) ((EXPRP FNDEF) (*
Note that EXPR can be a piece of a function definition, and calls will still work.) (RESETVARS ((
MSRECORDTRANFLG T)) (RETURN (PROG (CALLSDATA LAMFLG) (COND ((FMEMB (CAR FNDEF) LAMBDASPLST) (SETQ
LAMFLG T) (COND ((OR (AND (EQ (CAR (CADDR FNDEF)) (QUOTE *)) (EQ (CADR (CADDR FNDEF)) (QUOTE
DECLARATIONS:))) (EQ (CAR (CADDR FNDEF)) (QUOTE CLISP:))) (MSPRGDWIM FNDEF EXPR FNDEF))) (SELECTQ (CAR
FNDEF) ((LAMBDA NLAMBDA) NIL) (SETQ FNDEF (OR (AND COMPILEUSERFN (APPLY* COMPILEUSERFN NIL FNDEF))
FNDEF))))) (SETQ CALLSDATA (ALLCALLS FNDEF LAMFLG (UNION (CONSTANT (MSVBNOTICED (QUOTE USE) (QUOTE
FREELY))) (AND (NEQ VARSFLG (QUOTE FREEVARS)) (UNION (CONSTANT (MSVBNOTICED (QUOTE BIND))) (AND (NULL
VARSFLG) (CONSTANT (MSVBNOTICED (QUOTE CALL) (QUOTE NOTERROR))))))) EXPR T)) (SETQ FREES (NCONC FREES
(COLLECTFNDATA (CONSTANT (MSVBNOTICED (QUOTE USE) (QUOTE FREELY)))))) (RETURN (LIST (COLLECTFNDATA (
CONSTANT (MSVBNOTICED (QUOTE CALL) (QUOTE NOTERROR)))) (COLLECTFNDATA (CONSTANT (MSVBNOTICED (QUOTE
BIND)))) FREES)))))) (T (QUOTE ?)))))))
(COLLECTFNDATA
(LAMBDA (LST) (* lmm "21-DEC-78 22:56") (COND ((NLISTP LST) (CDR (FASSOC LST CALLSDATA))) (T (PROG (
VAL) (for X in LST do (SETQ VAL (UNION (COLLECTFNDATA X) VAL))) (RETURN VAL))))))
(CALLS3
(LAMBDA (LST) (* lmm " 6-JUL-78 00:23") (* lmm: 13-DEC-75 4 63Q) (PROG (FLG) (for X on (CAR LST) do (
OR (NOT (FMEMB (CAR X) INVISIBLEVARS)) (SETQ FLG (FRPLACA X)))) (COND (FLG (FRPLACA LST (DREMOVE NIL (
CAR LST))))))))
)
(RPAQQ MSMACROPROPS (DMACRO ALTOMACRO BYTEMACRO MACRO))
(RPAQQ NOPACKCALLSFLG NIL)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: CALLS CALLS COLLECTFNDATA CALLS3 (LOCALFREEVARS CALLSDATA)
(NOLINKFNS . T)
(GLOBALVARS INVISIBLEVARS COMPILEUSERFN NOPACKCALLSFLG LAMBDASPLST MSRECORDTRANFLG))
(BLOCK: NIL VARS FREEVARS (LOCALVARS . T))
]
(DECLARE: EVAL@COMPILE
(RPAQQ MS.VERB.TO.NOTICED ((BIND (NIL BIND ARG))
[CALL (DIRECTLY CALL EFFECT PREDICATE NLAMBDA)
(EFFECT EFFECT)
(INDIRECTLY APPLY STACK)
(NIL CALL ERROR APPLY EFFECT PREDICATE NLAMBDA STACK)
(NOTERROR APPLY CALL EFFECT PREDICATE NLAMBDA STACK)
(PREDICATE PREDICATE)
(TESTING PREDICATE)
(VALUE CALL)
(NLAMBDA NLAMBDA]
(CREATE (NIL CREATE))
(DECLARE (LOCALVARS LOCALVARS)
(NIL LOCALVARS SPECVARS)
(SPECVARS SPECVARS))
(FETCH (NIL FETCH))
(REFERENCE (FIELDS FETCH)
(FREELY REFFREE)
(LOCALLY REF)
(NIL REFFREE REF))
(REPLACE (NIL REPLACE))
(SET (FIELDS FETCH REPLACE)
(FREELY SETFREE)
(LOCALLY SET)
(NIL SETFREE SET))
(SMASH (FIELDS FETCH REPLACE)
(FREELY SMASHFREE)
(LOCALLY SMASH)
(NIL SMASHFREE SMASH))
(TEST (FREELY TESTFREE)
(LOCALLY TEST)
(NIL TESTFREE TEST))
(USE (FIELDS FETCH REPLACE)
(FREELY SETFREE SMASHFREE REFFREE TESTFREE)
(I.S.OPRS CLISP)
(INDIRECTLY LOCALFREEVARS)
(LOCALLY SET SMASH REF TEST)
(NIL SETFREE SET SMASHFREE SMASH REFFREE REF TESTFREE TEST)
(PREDICATE TEST TESTFREE)
(PROPNAMES PROP)
(RECORDS RECORD CREATE)
(TESTING TEST TESTFREE)
(VALUE SMASH SMASHFREE REF REFFREE)
(TYPE TYPE))))
DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS MSVBNOTICED MACRO (OPENLAMBDA (VERB MOD)
(CDR (ASSOC MOD (CDR (ASSOC VERB MS.VERB.TO.NOTICED]
)
)
(DEFINEQ
(ALLCALLS
[LAMBDA (FNDEF LAMFLG ONLYRELS FNNAME INTERNALFLG EACHTIME)(* lmm "22-DEC-78 13:02")
(PROG (VARS TOPVARS INCLISP ERRORS (PARENT FNDEF))
(MSINITFNDATA)
[COND
(LAMFLG (MSPRGLAMBDA FNDEF (QUOTE ARG)))
(T (MSPRGE FNDEF NIL (QUOTE RETURN]
(RETURN (COND
(INTERNALFLG MSFNDATA)
(T (for X in MSFNDATA when (CDR X) collect (CONS (CAR X)
(CDR X])
(MSINITFNDATA
(LAMBDA NIL (* MSFNDATA is an association list of the "noticed" types, e.g. CALL, BIND, etc. -- the
FRPLACD resets the pointer) (for Y in MSFNDATA do (FRPLACD Y NIL))))
(MSPRGE
[LAMBDA (EXPR SUPEXPR EVALCONTEXT) (* lmm "27-May-86 04:44")
(* analyzes EXPR; SUPEXPR is the parent expression and is used in the SHOWUSE
case where we are printing occurrances of various things rather than updating
data base; EVALCONTEXT is a type of reference for this expression from the
template: SMASH etc)
(PROG (TEM CALLED CLISP)
[COND
((NLISTP EXPR)
(RETURN (COND
((AND (LITATOM EXPR)
EXPR
(NEQ EXPR T)
(NOT (FMEMB EXPR INVISIBLEVARS)))
(* A variable reference)
(COND
([OR (FMEMB EXPR VARS)
(SOME TOPVARS (FUNCTION (LAMBDA (Z)
(* bound higher up in the function but
but used in a functional argument)
(COND
((FMEMB EXPR Z)
(ADDTO (QUOTE LOCALFREEVARS)
EXPR SUPEXPR)
T]
(* Things were added to VARS only if
they were "noticeable")
(SELECTQ EVALCONTEXT
((SMASH TEST SET)
(ADDTO EVALCONTEXT EXPR SUPEXPR))
(CHANGE (ADDTO (QUOTE SET)
EXPR SUPEXPR))
(ADDTO (QUOTE REF)
EXPR SUPEXPR)))
(T (SELECTQ EVALCONTEXT
(SMASH (ADDTO (QUOTE SMASHFREE)
EXPR SUPEXPR))
(TEST (ADDTO (QUOTE TESTFREE)
EXPR SUPEXPR))
((SET CHANGE)
(ADDTO (QUOTE SETFREE)
EXPR SUPEXPR))
(ADDTO (QUOTE REFFREE)
EXPR SUPEXPR]
(COND
((EQ EVALCONTEXT (QUOTE SET)) (* in a "SET" context, but not a
variable)
(MSPRGERR PARENT)))
(COND
((LISTP (SETQ CALLED (CAR EXPR)))
(MSPRGLAMBDA CALLED NIL (SELECTQ EVALCONTEXT
((TEST EFFECT SMASH)
EVALCONTEXT)
NIL))
(SELECTQ (CAR CALLED)
(LAMBDA (MSPRGLST (CDR EXPR)
EXPR))
NIL)
(RETURN)))
[COND
((SETQ TEM (LTEMPLATE CALLED))
(RETURN (MSPRGTEMPLATE EXPR TEM EVALCONTEXT]
[COND
((NOT (FGETD (OR (GETP CALLED (QUOTE BROKEN))
CALLED)))
(COND
((SETQ TEM (MACRO-FUNCTION CALLED))
(LET ((ME (MACROEXPAND EXPR)))
(COND
((AND (NOT (EQUAL ME EXPR))
(NOT (EQUAL ME INCLISP)))
(MSPRGCALL (CAR EXPR)
EXPR EVALCONTEXT)
(PROG ((INCLISP (INCLISP EXPR))
(EXPR EXPR))
(MSPRGE ME EXPR (QUOTE EVAL)))
(RETURN T]
(COND
((NLAMBDAFNP CALLED)
(ADDTO (QUOTE NLAMBDA)
CALLED EXPR)
(COND
((AND MSMACROPROPS (SETQ TEM (GETMACROPROP CALLED MSMACROPROPS))
(MSPRGMACRO EXPR TEM EVALCONTEXT))
(RETURN)))
(MSPRGCALL CALLED EXPR EVALCONTEXT))
(T (* normal lambda function call)
(MSPRGCALL CALLED EXPR EVALCONTEXT)
(MSPRGLST (CDR EXPR)
EXPR
(QUOTE EVAL])
(MSPRGMACRO
(LAMBDA (FORM MACDEF CONTEXT) (* lmm "13-DEC-82 23:45") (PROG ((ME (MACROEXPANSION FORM MACDEF))) (
COND ((AND (NOT (EQUAL ME FORM)) (NOT (EQUAL ME INCLISP))) (MSPRGCALL (CAR FORM) FORM CONTEXT) (PROG (
(INCLISP (INCLISP FORM)) (EXPR FORM)) (MSPRGE ME FORM (QUOTE EVAL))) (RETURN T))))))
(MSPRGCALL
(LAMBDA (FN PRNT CONTEXT) (* lmm "22-DEC-78 12:57") (ADDTO (COND (TOPVARS (QUOTE APPLY)) (T (SELECTQ
CONTEXT (TEST (QUOTE PREDICATE)) (EFFECT (QUOTE EFFECT)) (QUOTE CALL)))) FN PRNT)))
(MSBINDVAR
(LAMBDA (VAR TYPE EXPR) (* lmm " 6-JUL-78 00:23") (COND ((AND VAR (LITATOM VAR) (NEQ VAR T)) (COND ((
NOT (FMEMB VAR INVISIBLEVARS)) (ADDTO (OR TYPE (QUOTE BIND)) VAR (OR EXPR PARENT)))) (SETQ VARS (CONS
VAR VARS))) (T (MSPRGERR (COND ((LITATOM VAR) (OR EXPR PARENT)) (T VAR)))))))
(MSPRGRECORD
(LAMBDA (PRNT CNTXT) (* lmm "25-FEB-82 11:24") (* ANALYZE RECORD EXPRESSION PRNT - RETURN NIL IF
ANALYZED SUCCESSFULLY) (PROG (Z) (MSPRGTEMPLATE PRNT (SELECTQ (CAR PRNT) ((create CREATE) (ADDTO (
QUOTE CREATE) (CADR PRNT) PRNT) (SETQ Z (CDDR PRNT)) (while Z do (COND ((EQ (QUOTE RECORDTRAN) (CAR (
GETPROP (CAR Z) (QUOTE CLISPWORD)))) (* e.g. USING or COPYING) (MSPRGE (CADR Z) PRNT (SELECTQ (CAR Z)
((smashing SMASHING) (QUOTE SMASH)) NIL)) (SETQ Z (CDDR Z))) ((EQ (CADR Z) (QUOTE ←)) (* If dwimified
correctly, the fields should be separated by ←'s) (ADDTO (QUOTE REPLACE) (CAR Z) PRNT) (MSPRGE (CADDR
Z) PRNT) (SETQ Z (CDDDR Z))) ((EQ (CAAR Z) (QUOTE SETQ)) (* partially dwimified) (ADDTO (QUOTE REPLACE
) (CADAR Z) PRNT) (MSPRGE (CADDAR Z) PRNT) (SETQ Z (CDR Z))) (T (* shouldn't happen, but) (MSPRGE (CAR
Z) PRNT) (SETQ Z (CDR Z))))) (RETURN)) ((fetch FETCH ffetch FFETCH) (COND ((EQ CNTXT (QUOTE CHANGE))
(QUOTE (NIL (IF LISTP (BOTH (NIL .. FETCH (BOTH FETCH REPLACE)) (.. RECORD NIL)) (BOTH FETCH REPLACE))
NIL EVAL))) (T (QUOTE (NIL (IF LISTP (BOTH (NIL .. FETCH) (.. RECORD NIL)) FETCH) NIL EVAL))))) ((
REPLACE /REPLACE replace /replace freplace FREPLACE) (QUOTE (NIL (IF LISTP (BOTH (NIL .. FETCH REPLACE
) (.. RECORD NIL)) REPLACE) NIL SMASH NIL EVAL))) ((type? TYPE?) (QUOTE (CLISP RECORD EVAL . PPE))) ((
initrecord INITRECORD) (QUOTE (CLISP RECORD . PPE))) ((WITH with) (COND ((SETQ Z (RECORDFIELDNAMES (
CADR PRNT))) (ADDTO (QUOTE RECORD) (CADR PRNT) PRNT) (MSPRGE (CADDR PRNT) PRNT) (for X in (PROG1 (for
X on MSFNDATA when (FMEMB (CAAR X) (QUOTE (SETFREE TESTFREE REFFREE))) collect (LIST (CAR X) (RPLACA X
(LIST (CAAR X))))) (PROG (ONLYRELS (EACHTIME (AND EACHTIME (for X inside (PROGN EACHTIME) when (NOT (
FMEMB X (QUOTE (SETFREE TESTFREE REFFREE)))) collect X)))) (MSPRGLST (CDDDR PRNT) PRNT))) do (for Y in
(PROG1 (CDR (CAADR X)) (RPLACA (CADR X) (CAR X))) do (ADDTO (COND ((FMEMB Y Z) (SELECTQ (CAAR X) (
SETFREE (QUOTE REPLACE)) (QUOTE FETCH))) (T (CAAR X))) Y PRNT))) (RETURN)) (T (QUOTE (RECORD .. EVAL))
))) (RETURN T))))))
(MSPRGERR
(LAMBDA (EXPR) (* lmm "21-DEC-78 22:44") (SETQ ERRORS T) (ADDTO (QUOTE ERROR) MSERRORFN EXPR)))
(MSPRGTEMPLATE1
(LAMBDA (X TEMPLATE) (* lmm " 6-APR-82 21:35") (COND ((NLISTP TEMPLATE) (SELECTQ TEMPLATE ((EVAL SMASH
TEST EFFECT SET) (MSPRGE X PARENT TEMPLATE)) ((FUNCTION FUNCTIONAL) (* This is a functional arg to
something - the marker FUNCTIONAL means that it will be a separate function while FUNCTION is reserved
for those things which compile open - e.g. MAPC is marked (EVAL FUNCTION FUNCTION . PPE) while SORT
is marked (EVAL FUNCTIONAL . PPE)) (OR (COND ((AND (LISTP X) (NULL (CDDR X))) (COND ((EQ (CAR X) (
QUOTE F/L)) (MSPRGDWIM X FNNAME FNDEF))) (SELECTQ (CAR X) ((FUNCTION QUOTE) (MSPRGTEMPLATE (CADR X) (
COND ((LISTP (CADR X)) (SELECTQ TEMPLATE (FUNCTIONAL (QUOTE (REMOTE LAMBDA))) (QUOTE LAMBDA))) ((OR (
NEQ (CAR X) (QUOTE FUNCTION)) (EQ TEMPLATE (QUOTE FUNCTIONAL))) (QUOTE (REMOTE CALL))) (T (QUOTE CALL)
)) X) T) NIL))) (EQ X T) (NULL X) (PROGN (* arbitrary expression as functional argument) (ADDTO (QUOTE
ERROR) (QUOTE apply) PARENT) (MSPRGE X PARENT (QUOTE FUNCTIONAL))))) (STACK (* arg to stack fn, e.g.
RETFROM) (OR (AND (LISTP X) (SELECTQ (CAR X) ((FUNCTION QUOTE) (ADDTO (QUOTE STACK) (CADR X) PARENT) T
) NIL)) (PROGN (ADDTO (QUOTE ERROR) (QUOTE stackfn) PARENT) (MSPRGE X PARENT (QUOTE EVAL))))) (PROP (
COND ((AND (LISTP X) (EQ (CAR X) (QUOTE QUOTE))) (for Y inside (CADR X) do (ADDTO (QUOTE PROP) Y
PARENT))) (T (MSPRGE X PARENT TEMPLATE)))) (NIL (* not used) NIL) (RETURN (* this is sometimes the
value of PARENT expression) (MSPRGTEMPLATE1 X (SELECTQ PARENTCONTEXT ((TEST EFFECT) PARENTCONTEXT) (
QUOTE EVAL)))) (TESTRETURN (* if PARENT is tested, then so is this) (MSPRGTEMPLATE1 X (SELECTQ
PARENTCONTEXT (TEST PARENTCONTEXT) (QUOTE EVAL)))) (BIND (MSBINDVAR X)) (LAMBDA (MSPRGLAMBDA X)) (PPE
(* paren error if not NIL) (COND (X (MSPRGERR PARENT) (MSPRGLST X PARENT)))) (CALL (MSPRGCALL X PARENT
PARENTCONTEXT)) (EVALQT (COND ((EQ (CAR X) (QUOTE QUOTE)) (MSPRGTEMPLATE (CADR X) (QUOTE (REMOTE EVAL
)) PARENT)) (T (MSPRGE X PARENT (QUOTE EVAL))))) (ADDTO TEMPLATE X PARENT T))) (T (SELECTQ (CAR
TEMPLATE) (IF (PROG ((EXPR X)) (DECLARE (SPECVARS EXPR)) (MSPRGTEMPLATE1 X (COND ((COND ((LISTP (CADR
TEMPLATE)) (* ASSERT: ((REMOTE EVAL) EXPR)) (EVAL (CADR TEMPLATE))) (T (APPLY* (CADR TEMPLATE) X))) (
CADDR TEMPLATE)) (T (CADDDR TEMPLATE)))))) (.. (COND ((AND (CADR TEMPLATE) (NULL (CDDR TEMPLATE))) (*
Special case to handle most common cases) (MAPC X (FUNCTION (LAMBDA (X) (MSPRGTEMPLATE1 X (CADR
TEMPLATE)))))) (T (FRPTQ (IDIFFERENCE (LENGTH X) (LENGTH (CDDR TEMPLATE))) (MSPRGTEMPLATE1 (CAR X) (
CADR TEMPLATE)) (SETQ X (CDR X))) (MSPRGTEMPLATE1 X (CDDR TEMPLATE))))) (MACRO (ADDTO (QUOTE CALL) (
CAR X) PARENT) (MSPRGMACRO X (CDR TEMPLATE))) (BOTH (MSPRGTEMPLATE1 X (CADR TEMPLATE)) (MSPRGTEMPLATE1
X (CADDR TEMPLATE))) (@ (PROG ((EXPR X)) (DECLARE (SPECVARS EXPR)) (MSPRGTEMPLATE1 (EVAL (CADR
TEMPLATE)) (EVAL (CADDR TEMPLATE))))) (REMOTE (PROG (VARS (TOPVARS (CONS VARS TOPVARS))) (
MSPRGTEMPLATE1 X (CADR TEMPLATE)))) (COND ((LISTP X) (MSPRGTEMPLATE1 (CAR X) (CAR TEMPLATE)) (
MSPRGTEMPLATE1 (CDR X) (CDR TEMPLATE)))))))))
(MSPRGTEMPLATE
(LAMBDA (PARENT TEMPLATE PARENTCONTEXT) (* lmm "21-MAY-82 23:39") (PROG ((VARS VARS) TEM) (COND ((EQ
TEMPLATE (QUOTE MACRO)) (COND ((SETQ TEM (GETMACROPROP (CAR PARENT) MSMACROPROPS)) (MSPRGMACRO PARENT
TEM)) (T (MSPRGTEMPLATE1 PARENT (QUOTE (CALL .. EVAL)))))) (T (MSPRGTEMPLATE1 PARENT TEMPLATE))))))
(MSPRGLAMBDA
[LAMBDA (EXPR FLG TYPE) (* lmm "27-May-86 05:03")
(SELECTQ (CAR (LISTP EXPR))
([LAMBDA NLAMBDA OPENLAMBDA]
(MSPRGTEMPLATE EXPR (QUOTE (NIL (IF LISTP (.. BIND)
(IF (PROGN EXPR)
BIND))
.. EFFECT RETURN))
TYPE))
(PROG (CLISP TEM)
(COND
((AND (SETQ TEM (ASSOC (CAR EXPR)
LAMBDATRANFNS))
(SETQ CLISP (FUNCALL (CADR TEM)
EXPR)))
(PROG ((INCLISP (INCLISP EXPR)))
(MSPRGLAMBDA CLISP FLG T)))
((AND DWIMFLG (SETQ CLISP (MSDWIMTRAN EXPR)))
(* has a CLISP translation
(e.g. DLAMBDA))
(PROG ((INCLISP (INCLISP EXPR))) (* rebind INCLISP, and try again on
the translation)
(MSPRGLAMBDA CLISP FLG TYPE)))
(T (MSPRGERR EXPR)
(MSPRGE EXPR])
(MSPRGLST
(LAMBDA (L PARNT CNTX) (* lmm "27-JUN-78 01:57") (for X in L do (MSPRGE X PARNT CNTX))))
(ADDTO
(LAMBDA (RELATION WHAT PRNT FLG) (* lmm "24-DEC-78 11:51") (PROG ((PTR (FASSOC RELATION MSFNDATA))) (
OR PTR (COND (FLG (RETURN)) (T (SHOULDNT)))) (OR (NULL ONLYRELS) (FMEMB RELATION ONLYRELS) (RETURN)) (
AND EACHTIME (EQMEMB RELATION (CAR EACHTIME)) (APPLY* (CADR EACHTIME) WHAT (CADDR EACHTIME) (CADDDR
EACHTIME) PRNT INCLISP)) LP (COND ((NULL (CDR PTR)) (FRPLACD PTR (LIST WHAT))) ((EQ (CAR (SETQ PTR (
CDR PTR))) WHAT) (RETURN)) (T (GO LP))))))
(NLAMBDAFNP
(LAMBDA (FN) (* lmm "26-Mar-85 12:37") (AND (NOT (EQMEMB (QUOTE EVAL) (GETPROP FN (QUOTE INFO)))) (
COND ((OR (FGETD (SETQ FN (OR (GETPROP FN (QUOTE BROKEN)) FN))) (SETQ FN (GETLIS FN (QUOTE (EXPR CODE)
)))) (* if the function is defined, check its argtype to tell you whether it is NLAMBDA or LAMBDA) (
SELECTQ (ARGTYPE FN) ((1 3) T) NIL)) (T (* otherwise, rely on NLAMA or NLAML) (OR (FMEMB FN NLAMA) (
FMEMB FN NLAML)))))))
(MSPRGDWIM
[LAMBDA (X FN DEF) (* lmm "19-Jun-86 13:58")
(AND DWIMFLG (LET ((NOSPELLFLG T)
(DWIMESSGAG T)
FILEPKGFLG)
(PROG (LISPXHIST) (* ASSERT: ((REMOTE EVAL) DWIMESSGAG FILEPKGFLG
NOSPELLFLG))
(DWIMIFY0 X (OR (AND (LITATOM FN)
FN)
(QUOTE ?))
VARS DEF])
(MSDWIMTRAN
(LAMBDA (EXPR) (* DD: "28-DEC-81 13:46") (AND DWIMFLG (COND ((AND CLISPARRAY (GETHASH EXPR CLISPARRAY)
)) ((AND CLISPTRANFLG (EQ (CAR (LISTP EXPR)) CLISPTRANFLG)) (CADR EXPR)) (T (MSPRGDWIM EXPR FNNAME
FNDEF) (OR (AND CLISPARRAY (GETHASH EXPR CLISPARRAY)) (AND CLISPTRANFLG (EQ (CAR (LISTP EXPR))
CLISPTRANFLG) (CADR EXPR))))))))
)
(RPAQQ MSFNDATA ((BIND)
(CALL)
(EFFECT)
(PREDICATE)
(CLISP)
(PROP)
(SETFREE)
(SET)
(SMASHFREE)
(SMASH)
(REFFREE)
(REF)
(FETCH)
(REPLACE)
(RECORD)
(ERROR)
(ARG)
(CREATE)
(LOCALVARS)
(SPECVARS)
(APPLY)
(TESTFREE)
(TEST)
(LOCALFREEVARS)
[NLAMBDA]
(TYPE)
(STACK)))
(RPAQQ MSERRORFN ppe)
(RPAQQ MSRECORDTRANFLG NIL)
(ADDTOVAR INVISIBLEVARS
$$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS INCLISP MACRO ((.X.)
(COND ((AND INCLISP EACHTIME (NOT (MSFINDP INCLISP .X.)))
INCLISP)
(T .X.]
[PUTPROPS LTEMPLATE MACRO (LAMBDA (Y)
(DECLARE (LOCALVARS Y))
(AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
(GETHASH Y MSTEMPLATES]
Y]
)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: ALLCALLS ALLCALLS ADDTO MSBINDVAR MSDWIMTRAN MSPRGCALL MSPRGDWIM MSPRGE MSPRGMACRO MSPRGERR
MSPRGLAMBDA MSPRGLST MSPRGRECORD MSPRGTEMPLATE MSPRGTEMPLATE1 NLAMBDAFNP (NOLINKFNS . T)
(LOCALFREEVARS FNNAME ERRORS FNDEF INCLISP ONLYRELS PARENTCONTEXT TOPVARS PARENT EACHTIME VARS
)
(GLOBALVARS CLISPARRAY MSERRORFN MSRECORDTRANFLG MSFNDATA INVISIBLEVARS CLISPARRAY MSTEMPLATES
USERTEMPLATES MSRECORDTRANFLG NLAMA NLAML DWIMFLG CLISPTRANFLG DWIMESSGAG)
(NOLINKFNS . T))
(BLOCK: NIL MSINITFNDATA NLAMBDAFNP MSPRGDWIM (LOCALVARS . T)
(GLOBALVARS NLAMA NLAML MSFNDATA DWIMFLG DWIMESSGAG))
]
[PUTDQ? MSWORDNAME (LAMBDA (X)
X]
(RPAQ MSTEMPLATES (HASHARRAY 160))
(RPAQ USERTEMPLATES (HASHARRAY 10))
(RPAQQ INITIALTEMPLATES
(((CALL (REMOTE (IF LITATOM CALL LAMBDA))
(IF LITATOM EVAL NIL))
FUNCTION)
([IF (EQ (CADR EXPR)
(QUOTE ASSERT:))
(NIL NIL .. (IF LISTP (@ (CDR EXPR)
(LIST (QUOTE ..)
(MSWORDNAME (CAR EXPR]
*)
((NIL (BOTH (.. (IF LISTP (NIL EVAL .. EFFECT)
NIL))
(.. (IF LISTP (BIND)
BIND)))
..
(IF LISTP EFFECT))
PROG)
(MACRO RESETVARS)
((CALL EVAL)
XNLSETQ NLSETQ ERSETQ)
((CALL .. EVAL)
RESETFORM FRPTQ)
((CALL EVAL EVAL FUNCTIONAL FUNCTIONAL . PPE)
MAP2C)
((CALL EVAL EVAL SMASH . PPE)
/DSUBST DSUBST)
((CALL EVAL FUNCTION FUNCTION . PPE)
MAPCAR MAPCON MAPCONC MAPLIST SUBSET EVERY NOTEVERY ANY NOTANY SOME MAPC MAP)
((CALL EVAL FUNCTIONAL . PPE)
MAPHASH)
((CALL EVAL PROP . PPE)
GETP GETLIS GET GETPROP LISTGET LISTGET1 REMPROP /REMPROP)
((CALL EVAL PROP EVAL . PPE)
PUT /PUT PUTPROP /PUTPROP LISTPUT LISTPUT1)
((CALL EVAL SMASH . PPE)
/ATTACH ATTACH)
((CALL FUNCTIONAL . PPE)
MAPATOMS)
((CALL FUNCTIONAL .. EVAL)
APPLY* BLKAPPLY* APPLY BLKAPPLY)
((CALL NIL .. (@ EXPR (SELECTQ (CAR (LISTP EXPR))
((CQ CQ2 CV CV2)
(QUOTE (NIL .. EVAL)))
[VAR (QUOTE (NIL (.. NIL EVAL]
(SETQ (QUOTE (NIL SET)))
NIL)))
ASSEMBLE)
((CALL EVAL SMASH . PPE)
DREMOVE /DREMOVE)
((CALL SET EVAL EVAL . PPE)
RESETVAR)
((CALL SET EVAL . PPE)
SETN)
((CALL SMASH . PPE)
DREVERSE)
((CALL SMASH EVAL . PPE)
RPLACD /RPLACD RPLACA /RPLACA RPLNODE2 /RPLNODE2 FRPLACD FRPLNODE2 TCONC /TCONC LCONC /LCONC
NCONC1 /NCONC1 FRPLACA)
((CALL SMASH EVAL EVAL . PPE)
RPLNODE FRPLNODE /RPLNODE)
((CALL SMASH FUNCTIONAL . PPE)
SORT)
((CALL (BOTH SET EVAL) . PPE)
ADD1VAR SUB1VAR)
((CALL (IF NULL NIL (IF ATOM SET EVAL))
EVAL . PPE)
RESETSAVE)
((CALL (IF (EQ (CAR (LISTP EXPR))
(QUOTE QUOTE))
(NIL SET)
EVAL)
EVAL . PPE)
SET /SET SETTOPVAL /SETTOPVAL SETATOMVAL /SETATOMVAL)
((CALL (IF (EQ (CAR (LISTP EXPR))
(QUOTE QUOTE))
(NIL SET)
EVAL)
EVAL EVAL EVAL . PPE)
SAVESET)
((CALL (IF (EQ (CAR (LISTP EXPR))
(QUOTE QUOTE))
(NIL EVAL)
EVAL)
.. EVAL)
GETATOMVAL EVAL EVALV)
((NIL .. TESTRETURN RETURN)
OR)
((NIL .. TEST RETURN)
AND)
((NIL .. EFFECT RETURN)
PROGN)
((NIL .. (IF CDR (TEST .. EFFECT RETURN)
(TESTRETURN . PPE)))
COND)
([CALL .. (@ EXPR (CONS NIL (SELECTQ (CAR (LISTP EXPR))
(LOCALVARS (QUOTE (IF LISTP (.. LOCALVARS)
LOCALVARS)))
(SPECVARS (QUOTE (IF LISTP (.. SPECVARS)
SPECVARS)))
NIL]
DECLARE)
((NIL RETURN)
CLISP% )
((NIL EVAL . PPE)
LISTP NLISTP RETURN)
((NIL TEST . PPE)
NOT NULL)
((CALL EVAL .. (NIL .. EFFECT RETURN)
RETURN)
SELECTQ SELCHARQ)
((CALL EVAL .. (EVAL .. EFFECT RETURN)
RETURN)
SELECTC)
((CALL EVAL .. ((IF LISTP (.. EVAL)
EVAL)
.. EFFECT RETURN)
RETURN)
SELECT)
((NIL EVAL EVAL . PPE)
EQ NEQ)
((NIL NIL . PPE)
QUOTE GO)
((NIL EVAL . PPE)
CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR CADDR CDADR CDDAR CDDDR CAAAAR CAAADR
CAADAR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR
CDDDDR)
((NIL RETURN .. EFFECT)
PROG1)
((NIL SET NIL . PPE)
SETQQ)
((NIL SET EVAL . PPE)
SETQ ADV-SETQ SAVESETQ)
((CALL EVAL (BOTH (@ (QUOTE RPTN)
(QUOTE BIND))
RETURN) . PPE)
RPTQ)
((CALL EVALQT .. EVAL)
EVAL ERRORSET)
((BOTH [IF (EQ (CAR (LISTP (CADDR EXPR)))
(QUOTE QUOTE))
(NIL NIL (NIL (.. (BIND]
(CALL EVALQT EVAL . PPE))
EVALA)
((CALL EVALQT STACK STACK EVAL EVAL . PPE)
ENVEVAL)
((CALL FUNCTIONAL EVALQT STACK STACK EVAL EVAL . PPE)
ENVAPPLY)
((CALL STACK EVAL EVAL EVAL . PPE)
STKAPPLY)
((CALL STACK EVALQT EVAL EVAL . PPE)
RETEVAL STKEVAL)
((CALL STACK EVAL EVAL . PPE)
RETFROM RETTO)))
(* * INITIALTEMPLATES is not needed after loading up)
[MAPC INITIALTEMPLATES (FUNCTION (LAMBDA (X)
(MAPC (CDR X)
(FUNCTION (LAMBDA (Y)
(PUTHASH Y (CAR X)
MSTEMPLATES]
(DECLARE: EVAL@COMPILE DONTCOPY
(PUTPROPS LTEMPLATE MACRO [LAMBDA (Y)
(DECLARE (LOCALVARS Y))
(AND [NEQ T (SETQ Y (OR (GETHASH Y USERTEMPLATES)
(GETHASH Y MSTEMPLATES]
Y])
)
(DEFINEQ
(MSFINDP
(LAMBDA (STRUC SUB) (* lmm "14-Aug-84 16:38") (PROG NIL LP (RETURN (OR (EQ SUB STRUC) (AND (LISTP
STRUC) (OR (MSFINDP (CAR STRUC) SUB) (PROGN (SETQ STRUC (CDR STRUC)) (GO LP)))))))))
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: MSFINDP MSFINDP)
]
(PUTPROPS MSANALYZE COPYRIGHT ("Xerox Corporation" T 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3626 6253 (VARS 3636 . 3730) (FREEVARS 3732 . 3846) (CALLS 3848 . 5814) (COLLECTFNDATA
5816 . 6017) (CALLS3 6019 . 6251)) (9258 24762 (ALLCALLS 9268 . 9832) (MSINITFNDATA 9834 . 10021) (
MSPRGE 10023 . 14984) (MSPRGMACRO 14986 . 15289) (MSPRGCALL 15291 . 15491) (MSBINDVAR 15493 . 15790) (
MSPRGRECORD 15792 . 17870) (MSPRGERR 17872 . 17981) (MSPRGTEMPLATE1 17983 . 21068) (MSPRGTEMPLATE
21070 . 21393) (MSPRGLAMBDA 21395 . 22789) (MSPRGLST 22791 . 22893) (ADDTO 22895 . 23355) (NLAMBDAFNP
23357 . 23799) (MSPRGDWIM 23801 . 24411) (MSDWIMTRAN 24413 . 24760)) (33237 33445 (MSFINDP 33247 .
33443)))))
STOP