(FILECREATED "14-Aug-84 19:32:08" {ERIS}<LISPCORE>SOURCES>MSANALYZE.;3 32138
changes to: (FNS MSFINDP)
previous date: " 3-Jan-84 13:27:52" {ERIS}<LISPCORE>SOURCES>MSANALYZE.;1)
(* Copyright (c) 1982, 1983, 1984 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 MSVBNOTICED (LOCALVARS . T)))
(DECLARE: EVAL@COMPILE (FNS 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
NOSPELLFLG DWIMESSGAG FILEPKGFLG)
(NOLINKFNS . T))
(NIL MSINITFNDATA NLAMBDAFNP MSPRGDWIM (LOCALVARS . T)
(GLOBALVARS NLAMA NLAML MSFNDATA DWIMFLG NOSPELLFLG DWIMESSGAG FILEPKGFLG))
)
(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 23 22)
(CDR (CALLS FN USEDATABASE T])
(FREEVARS
[LAMBDA (FN USEDATABASE) (* lmm: 5-DEC-75 11 8)
(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 51)
(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 MSVBNOTICED (LOCALVARS . T))
]
(DECLARE: EVAL@COMPILE
(DEFINEQ
(MSVBNOTICED
[LAMBDA (VERB MOD) (* lmm "30-DEC-78 16:42")
(CDR (FASSOC MOD (CDR (FASSOC VERB
(QUOTE ((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])
)
)
(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 "13-DEC-82 23:46")
(* 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
[[AND DWIMFLG (SETQ TEM (GETPROP CALLED (QUOTE CLISPWORD]
(* E.G. IF, FOR, etc.)
(SETQ CLISP (MSDWIMTRAN EXPR))
(RETURN (COND
(CLISP [COND
(TEM (SELECTQ (CAR TEM)
(RECORDTRAN (OR (MSPRGRECORD EXPR EVALCONTEXT)
MSRECORDTRANFLG
(RETURN))
(* optionally also look at translation)
)
(IFWORD)
(CHANGETRAN (MSPRGE (CADR EXPR)
EXPR
(QUOTE CHANGE)))
(for X in EXPR
when [AND (LITATOM X)
(EQ (CAR TEM)
(CAR (GETPROP X (QUOTE CLISPWORD]
do (ADDTO (QUOTE CLISP)
X EXPR]
(* Analyze the CLISP translation)
(PROG ((INCLISP (INCLISP EXPR)))
(MSPRGE CLISP EXPR EVALCONTEXT)))
((OR (NULL (GETPROP (CAR EXPR)
(QUOTE CLISPWORD)))
(NEQ (CAR EXPR)
CALLED))
(RETURN (MSPRGE EXPR SUPEXPR EVALCONTEXT)))
(T (SELECTQ (CAR TEM)
(RECORDTRAN (MSPRGRECORD EXPR EVALCONTEXT))
(CHANGETRAN (MSPRGE (CADR EXPR)
EXPR
(QUOTE CHANGE))
(MSPRGLST (CDDR EXPR)
EXPR))
(PROGN
(* CLISP word wouldn't DWIMIFY)
(MSPRGCALL CALLED EXPR EVALCONTEXT)
(MSPRGERR EXPR)
(MSPRGLST (CDR EXPR)
EXPR]
((AND MSMACROPROPS (SETQ TEM (GETMACROPROP CALLED MSMACROPROPS))
(MSPRGMACRO EXPR TEM EVALCONTEXT))
(RETURN]
(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) (* DD: "28-Dec-81 10:41")
(SELECTQ (CAR (LISTP EXPR))
([LAMBDA NLAMBDA]
(MSPRGTEMPLATE EXPR (QUOTE (NIL (IF LISTP (.. BIND)
(IF (PROGN EXPR) BIND))
.. EFFECT RETURN))
TYPE))
(PROG (CLISP)
(COND
((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 " 6-DEC-80 15:39")
(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 SUBR]
(* 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 "24-DEC-78 14:36")
(AND DWIMFLG (RESETVARS ((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
NOSPELLFLG DWIMESSGAG FILEPKGFLG)
(NOLINKFNS . T))
(BLOCK: NIL MSINITFNDATA NLAMBDAFNP MSPRGDWIM (LOCALVARS . T)
(GLOBALVARS NLAMA NLAML MSFNDATA DWIMFLG NOSPELLFLG DWIMESSGAG FILEPKGFLG))
]
(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))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2703 6402 (VARS 2713 . 2848) (FREEVARS 2850 . 3003) (CALLS 3005 . 5707) (COLLECTFNDATA
5709 . 6009) (CALLS3 6011 . 6400)) (6795 8391 (MSVBNOTICED 6805 . 8389)) (8394 25630 (ALLCALLS 8404 .
8897) (MSINITFNDATA 8899 . 9181) (MSPRGE 9183 . 13554) (MSPRGMACRO 13556 . 13931) (MSPRGCALL 13933 .
14200) (MSBINDVAR 14202 . 14599) (MSPRGRECORD 14601 . 17708) (MSPRGERR 17710 . 17881) (MSPRGTEMPLATE1
17883 . 22295) (MSPRGTEMPLATE 22297 . 22715) (MSPRGLAMBDA 22717 . 23416) (MSPRGLST 23418 . 23577) (
ADDTO 23579 . 24192) (NLAMBDAFNP 24194 . 24793) (MSPRGDWIM 24795 . 25207) (MSDWIMTRAN 25209 . 25628))
(31672 31971 (MSFINDP 31682 . 31969)))))
STOP