(FILECREATED " 4-Sep-86 18:22:28" {ERIS}<LISPCORE>LIBRARY>CMLMACROS.;19 10130
changes to: (VARS CMLMACROSCOMS)
previous date: "21-Aug-86 17:44:51" {ERIS}<LISPCORE>LIBRARY>CMLMACROS.;18)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLMACROSCOMS)
(RPAQQ CMLMACROSCOMS ((FNS CLISPEXPANSION \INTERLISP-NLAMBDA-MACRO MACRO-FUNCTION MACROEXPAND
MACROEXPAND-1 SETF-MACRO-FUNCTION)
(APPENDVARS (COMPILERMACROPROPS DMACRO BYTEMACRO MACRO
SHOULD-HAVE-MACRO-FUNCTION))
(PROP MACRO *)
(INITVARS (*MACROEXPAND-HOOK* (QUOTE FUNCALL)))
(FUNCTIONS MACROLET)
(SETFS MACRO-FUNCTION)
(PROP FILETYPE CMLMACROS)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA)))))
(DEFINEQ
(CLISPEXPANSION
(LAMBDA (X ENV) (* lmm "29-Jul-86 03:34")
(CL:BLOCK CLISPEXPANSION (VALUES (OR (AND (GETPROP (CAR X)
(QUOTE CLISPWORD))
(RESETVARS ((CLISPFLG NIL))
(LET ((NOSPELLFLG T)
(VARS NIL)
(COP (COPY X)))
(DECLARE (SPECIAL NOSPELLFLG VARS))
(* make a copy so dwim doesn't muck
with it!)
(DWIMIFY0? COP COP COP NIL NIL NIL
(QUOTE VARSBOUND))
(RETURN (GETHASH COP CLISPARRAY)))))
(RETURN-FROM CLISPEXPANSION X))
T))))
(\INTERLISP-NLAMBDA-MACRO
(LAMBDA (X ENV) (* lmm " 7-May-86 17:24")
(BQUOTE (FUNCALL (FUNCTION (\, (CAR X)))
(\,@ (SELECTQ (ARGTYPE (CAR X))
(1 (MAPCAR (CDR X)
(FUNCTION KWOTE)))
(3 (LIST (KWOTE (CDR X))))
(SHOULDNT)))))))
(MACRO-FUNCTION
(LAMBDA (X ENV) (* Pavel " 6-Jun-86 12:18")
(* * "If the given symbol has a macro definition in either the given lexical environment or globally, return its expansion function, else NIL.")
(LET (MD)
(ETYPECASE ENV (ENVIRONMENT (*
"Interpreter/code-walker's environments")
(COND
((SETQ MD (ASSOC X (ENVIRONMENT-MACROS ENV)))
(DESTRUCTURING-BIND (NAME DEFMACRO-ARGS &REST DEFMACRO-BODY)
MD
(MULTIPLE-VALUE-BIND (PARSED-BODY PARSED-DECLARATIONS
PARSED-DOCSTRING)
(PARSE-DEFMACRO DEFMACRO-ARGS (QUOTE $$MACRO-FORM)
DEFMACRO-BODY NAME NIL :ENVIRONMENT
(QUOTE $$MACRO-ENVIRONMENT))
(BQUOTE (LAMBDA ($$MACRO-FORM $$MACRO-ENVIRONMENT)
(\,@ PARSED-DECLARATIONS)
(CL:BLOCK (\, NAME)
(\, PARSED-BODY)))))))
(T (MACRO-FUNCTION X (ENVIRONMENT-PARENT ENV)))))
(ENV (* "New compiler's environments.")
(MULTIPLE-VALUE-BIND (KIND EXPN-FN)
(ENV-FBOUNDP ENV X)
(CL:IF (EQ KIND :MACRO)
EXPN-FN
(MACRO-FUNCTION X NIL))))
(NULL (COND
((GET X (QUOTE MACRO-FN)))
((SPECIAL-FORM-P X)
NIL)
((AND (NOT (FMEMB (ARGTYPE X)
(QUOTE (0 2))))
(find PROP in COMPILERMACROPROPS suchthat
(AND (SETQ MD (GETPROP X PROP))
(NOT (OR (LITATOM MD)
(FMEMB (CAR MD)
(QUOTE (APPLY APPLY*))))))))
(BQUOTE (LAMBDA (FORM ENV)
(MACROEXPANSION FORM (QUOTE (\, MD))))))
((AND (NOT (GETD X))
(GETPROP X (QUOTE CLISPWORD)))
(FUNCTION CLISPEXPANSION))
((FMEMB (ARGTYPE X)
(QUOTE (1 3)))
(FUNCTION \INTERLISP-NLAMBDA-MACRO))))))))
(MACROEXPAND
(CL:LAMBDA (FORM &OPTIONAL ENV) (* "Pavel" "16-May-86 19:07")
(* * "If FORM is a macro call, then the form is expanded until the result is"
"not a macro. Returns as multiple values, the form after any expansion"
"has been done and T if expansion was done, or NIL otherwise. Env is the"
"lexical environment to expand in, which defaults to the null environment.")
(PROG (FLAG)
(MULTIPLE-VALUE-SETQ (FORM FLAG)
(MACROEXPAND-1 FORM ENV))
(CL:UNLESS FLAG (RETURN (VALUES FORM NIL)))
LOOP
(MULTIPLE-VALUE-SETQ (FORM FLAG)
(MACROEXPAND-1 FORM ENV))
(CL:IF FLAG (GO LOOP)
(RETURN (VALUES FORM T))))))
(MACROEXPAND-1
(CL:LAMBDA (FORM &OPTIONAL ENV &AUX DEF) (* "Pavel" "16-May-86 19:08")
(* * "If form is a macro, expands it once. Returns two values, the expanded"
"form and a T-or-NIL flag indicating whether the form was, in fact, a"
"macro. Env is the lexical environment to expand in, which defaults to"
"the null environment.")
(COND
((AND (CONSP FORM)
(SYMBOLP (CAR FORM)))
(LET ((DEF (MACRO-FUNCTION (CAR FORM)
ENV)))
(COND
(DEF (if (NEQ FORM (SETQ FORM (FUNCALL *MACROEXPAND-HOOK* DEF FORM ENV)))
then
(VALUES FORM T)
else
(VALUES FORM NIL)))
(T (VALUES FORM NIL)))))
(T (VALUES FORM NIL)))))
(SETF-MACRO-FUNCTION
(LAMBDA (X BODY) (* jrb: "21-Aug-86 17:42")
(PROG1 (SETF (GET X (QUOTE MACRO-FN))
BODY)
(AND (GETD X)
(FMEMB (ARGTYPE X)
(QUOTE (0 2)))
(PROGN (PRINTOUT T T "Warning: will soon do PUTD on " X " because it now is a macro")
)))))
)
(APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO SHOULD-HAVE-MACRO-FUNCTION)
(PUTPROPS * MACRO ((X . Y)
(QUOTE X)))
(RPAQ? *MACROEXPAND-HOOK* (QUOTE FUNCALL))
(DEFMACRO MACROLET (MACRODEFS &BODY BODY &ENVIRONMENT ENV) (WALK-FORM (CONS (QUOTE PROGN)
BODY)
:ENVIRONMENT
(MAKE-ENVIRONMENT :MACROS MACRODEFS
:PARENT ENV)))
(DEFSETF MACRO-FUNCTION SETF-MACRO-FUNCTION)
(PUTPROPS CMLMACROS FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PRETTYCOMPRINT CMLMACROSCOMS)
(RPAQQ CMLMACROSCOMS ((FNS CLISPEXPANSION \INTERLISP-NLAMBDA-MACRO MACRO-FUNCTION MACROEXPAND
MACROEXPAND-1 SETF-MACRO-FUNCTION)
(APPENDVARS (COMPILERMACROPROPS DMACRO BYTEMACRO MACRO
SHOULD-HAVE-MACRO-FUNCTION))
(PROP MACRO *)
(INITVARS (*MACROEXPAND-HOOK* (QUOTE FUNCALL)))
(FUNCTIONS MACROLET)
(SETFS MACRO-FUNCTION)
(PROP FILETYPE CMLMACROS)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA MACROEXPAND-1 MACROEXPAND)))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA MACROEXPAND-1 MACROEXPAND)
)
(PUTPROPS CMLMACROS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1161 8187 (CLISPEXPANSION 1171 . 2399) (\INTERLISP-NLAMBDA-MACRO 2401 . 2825) (
MACRO-FUNCTION 2827 . 5913) (MACROEXPAND 5915 . 6787) (MACROEXPAND-1 6789 . 7769) (SETF-MACRO-FUNCTION
7771 . 8185)))))
STOP