(FILECREATED "18-Jul-86 17:47:34" {ERIS}<LISPCORE>LIBRARY>CMLMACROS.;16 8370
changes to: (FNS CLISPEXPANSION)
previous date: " 6-Jun-86 13:55:06" {ERIS}<LISPCORE>LIBRARY>CMLMACROS.;15)
(* 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 ENV) (* lmm "18-Jul-86 16:49")
(CL:BLOCK CLISPEXPANSION
(OR (VALUES [AND (GETPROP (CAR X)
(QUOTE CLISPWORD))
(OR (GETHASH X CLISPARRAY)
(PROGN (LET ((NOSPELLFLG T)
(VARS NIL))
(DECLARE (SPECIAL NOSPELLFLG VARS))
(DWIMIFY0? X X X NIL NIL NIL (QUOTE VARSBOUND)))
(GETHASH X CLISPARRAY]
T)
(RETURN-FROM CLISPEXPANSION X])
(\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 (1040 7412 (CLISPEXPANSION 1050 . 1775) (\INTERLISP-NLAMBDA-MACRO 1777 . 2196) (
MACRO-FUNCTION 2198 . 5350) (MACROEXPAND 5352 . 6188) (MACROEXPAND-1 6190 . 7065) (SETF-MACRO-FUNCTION
7067 . 7410)))))
STOP