(FILECREATED " 6-Jun-86 13:55:06" {ERIS}<LISPCORE>LIBRARY>CMLMACROS.;15 8031
changes to: (FNS MACRO-FUNCTION)
previous date: "29-May-86 23:23:03" {ERIS}<LISPCORE>LIBRARY>CMLMACROS.;14)
(* 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 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)))))
(DEFINEQ
(CLISPEXPANSION
[LAMBDA (X) (* lmm " 6-Jan-86 18:08")
(AND (GETPROP (CAR X)
(QUOTE CLISPWORD))
(OR (GETHASH X CLISPARRAY)
(PROGN (RESETVARS ((NOSPELLFLG T))
(DWIMIFY0? X X X NIL NIL NIL (QUOTE VARSBOUND)))
(GETHASH X CLISPARRAY])
(\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) (* lmm "27-May-86 12:43")
(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 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 MACROEXPAND-1 MACROEXPAND)
)
(PUTPROPS CMLMACROS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1043 7073 (CLISPEXPANSION 1053 . 1436) (\INTERLISP-NLAMBDA-MACRO 1438 . 1857) (
MACRO-FUNCTION 1859 . 5011) (MACROEXPAND 5013 . 5849) (MACROEXPAND-1 5851 . 6726) (SETF-MACRO-FUNCTION
6728 . 7071)))))
STOP