add merge in Ron's 11/21/2020 lispcore
This commit is contained in:
Larry Masinter
253
CLTL2/CMLMACROS
Normal file
253
CLTL2/CMLMACROS
Normal file
@@ -0,0 +1,253 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "18-Oct-93 14:19:04" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMACROS.;2" 12700
|
||||
|
||||
previous date%: "12-Jan-92 12:41:41" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMACROS.;1")
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CMLMACROSCOMS)
|
||||
|
||||
(RPAQQ CMLMACROSCOMS
|
||||
[(FNS CLISPEXPANSION GLOBAL-MACRO-FUNCTION LOCAL-MACRO-FUNCTION LOCAL-SYMBOL-FUNCTION
|
||||
\INTERLISP-NLAMBDA-MACRO LISP:MACRO-FUNCTION LISP:MACROEXPAND LISP:MACROEXPAND-1
|
||||
SETF-MACRO-FUNCTION)
|
||||
(APPENDVARS (COMPILERMACROPROPS DMACRO BYTEMACRO MACRO))
|
||||
(ADDVARS (GLOBALVARS COMPILERMACROPROPS))
|
||||
(PROP MACRO *)
|
||||
(FUNCTIONS LISP:MACROLET)
|
||||
(SETFS LISP:MACRO-FUNCTION)
|
||||
(PROP FILETYPE CMLMACROS)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
(LAMA LISP:MACROEXPAND-1
|
||||
LISP:MACROEXPAND
|
||||
LISP:MACRO-FUNCTION
|
||||
])
|
||||
(DEFINEQ
|
||||
|
||||
(CLISPEXPANSION
|
||||
[LAMBDA (X ENV) (* ; "Edited 4-Dec-86 01:19 by lmm")
|
||||
|
||||
(* ;; "the macro function for all CLISP words. Expand X as a clisp macro.")
|
||||
|
||||
(LISP:VALUES (do (LET ((NOSPELLFLG T)
|
||||
(LISPXHIST NIL)
|
||||
(VARS NIL)
|
||||
(COP (COPY X)))
|
||||
(DECLARE (LISP:SPECIAL NOSPELLFLG VARS LISPXHIST))
|
||||
(* ;
|
||||
"make a copy so dwim doesn't muck with it!")
|
||||
[COND
|
||||
((GETPROP (CAR X)
|
||||
'CLISPWORD)
|
||||
(DWIMIFY0? COP COP COP NIL NIL NIL 'VARSBOUND)
|
||||
(COND
|
||||
((NOT (LISP:EQUAL COP X))
|
||||
(* ; "made a change")
|
||||
(RETURN COP))
|
||||
((SETQ COP (GETHASH COP CLISPARRAY))
|
||||
(RETURN COP]
|
||||
(LISP:CERROR "Try expanding again." "Can't CLISP expand expression ~S."
|
||||
X)))
|
||||
T])
|
||||
|
||||
(GLOBAL-MACRO-FUNCTION
|
||||
[LAMBDA (X ENV) (* ; "Edited 22-Apr-87 19:07 by Pavel")
|
||||
(LET (MD)
|
||||
(COND
|
||||
[(AND (TYPEP ENV 'COMPILER:ENV)
|
||||
(LISP:MULTIPLE-VALUE-BIND (KIND EXPN-FN)
|
||||
(COMPILER:ENV-FBOUNDP ENV X)
|
||||
(AND (EQ KIND :MACRO)
|
||||
EXPN-FN]
|
||||
((GET X 'MACRO-FN))
|
||||
((LISP:SPECIAL-FORM-P X)
|
||||
NIL)
|
||||
[[AND [NOT (FMEMB (ARGTYPE X)
|
||||
'(0 2]
|
||||
(FIND PROP IN COMPILERMACROPROPS
|
||||
SUCHTHAT (AND (SETQ MD (GETPROP X PROP))
|
||||
(NOT (OR (LITATOM MD)
|
||||
(FMEMB (CAR MD)
|
||||
'(APPLY APPLY*]
|
||||
`(LAMBDA (FORM ENV)
|
||||
(MACROEXPANSION FORM ',MD]
|
||||
((AND (NOT (GETD X))
|
||||
(GETPROP X 'CLISPWORD))
|
||||
(FUNCTION CLISPEXPANSION))
|
||||
((FMEMB (ARGTYPE X)
|
||||
'(1 3))
|
||||
(FUNCTION \INTERLISP-NLAMBDA-MACRO])
|
||||
|
||||
(LOCAL-MACRO-FUNCTION
|
||||
[LAMBDA (X ENV) (* ; "Edited 13-Apr-87 11:16 by Pavel")
|
||||
(AND ENV (LISP:TYPECASE ENV
|
||||
(ENVIRONMENT (* ; "Interpreter's environments")
|
||||
(LET ((FN-DEFN (LISP:GETF (ENVIRONMENT-FUNCTIONS ENV)
|
||||
X)))
|
||||
(AND FN-DEFN (EQ (CAR FN-DEFN)
|
||||
:MACRO)
|
||||
(CDR FN-DEFN))))
|
||||
(COMPILER:ENV (* ; "Compiler's environments.")
|
||||
(LISP:MULTIPLE-VALUE-BIND (KIND EXPN-FN)
|
||||
(COMPILER:ENV-FBOUNDP ENV X :LEXICAL-ONLY T)
|
||||
(AND (EQ KIND :MACRO)
|
||||
EXPN-FN))))])
|
||||
|
||||
(LOCAL-SYMBOL-FUNCTION
|
||||
[LAMBDA (X ENV) (* ; "Edited 31-Jul-87 18:06 by amd")
|
||||
(AND ENV (LISP:TYPECASE ENV
|
||||
(ENVIRONMENT (* ; "Interpreter's environments")
|
||||
(LET ((FN-DEFN (LISP:GETF (ENVIRONMENT-FUNCTIONS ENV)
|
||||
X)))
|
||||
(AND FN-DEFN (EQ (CAR FN-DEFN)
|
||||
:FUNCTION)
|
||||
(CDR FN-DEFN))))
|
||||
(COMPILER:ENV (* ; "Compiler's environments.")
|
||||
(LISP:MULTIPLE-VALUE-BIND (KIND FN)
|
||||
(COMPILER:ENV-FBOUNDP ENV X :LEXICAL-ONLY T)
|
||||
(AND (EQ KIND :FUNCTION)
|
||||
FN))))])
|
||||
|
||||
(\INTERLISP-NLAMBDA-MACRO
|
||||
[LAMBDA (X ENV) (* lmm " 7-May-86 17:24")
|
||||
`(LISP:FUNCALL (FUNCTION ,(CAR X))
|
||||
,@(SELECTQ (ARGTYPE (CAR X))
|
||||
(1 (MAPCAR (CDR X)
|
||||
(FUNCTION KWOTE)))
|
||||
(3 (LIST (KWOTE (CDR X))))
|
||||
(SHOULDNT])
|
||||
|
||||
(LISP:MACRO-FUNCTION
|
||||
[LISP:LAMBDA (LISP::X LISP::ENV) (* ; "Edited 12-Jan-92 11:45 by bane")
|
||||
(AND (LISP:SYMBOLP LISP::X)
|
||||
(NOT (LOCAL-SYMBOL-FUNCTION LISP::X LISP::ENV))
|
||||
(OR (LOCAL-MACRO-FUNCTION LISP::X LISP::ENV)
|
||||
(GLOBAL-MACRO-FUNCTION LISP::X LISP::ENV])
|
||||
|
||||
(LISP:MACROEXPAND
|
||||
[LISP:LAMBDA (LISP::FORM &OPTIONAL LISP::ENV) (* ; "Edited 13-Feb-87 23:47 by Pavel")
|
||||
|
||||
(* ;;; "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 (LISP::FLAG)
|
||||
(LISP:MULTIPLE-VALUE-SETQ (LISP::FORM LISP::FLAG)
|
||||
(LISP:MACROEXPAND-1 LISP::FORM LISP::ENV))
|
||||
(LISP:UNLESS LISP::FLAG
|
||||
(RETURN (LISP:VALUES LISP::FORM NIL)))
|
||||
LISP:LOOP
|
||||
(LISP:MULTIPLE-VALUE-SETQ (LISP::FORM LISP::FLAG)
|
||||
(LISP:MACROEXPAND-1 LISP::FORM LISP::ENV))
|
||||
(LISP:IF LISP::FLAG
|
||||
(GO LISP:LOOP)
|
||||
(RETURN (LISP:VALUES LISP::FORM T)))])
|
||||
|
||||
(LISP:MACROEXPAND-1
|
||||
[LISP:LAMBDA (LISP::FORM &OPTIONAL LISP::ENV) (* ; "Edited 13-Feb-87 23:49 by Pavel")
|
||||
|
||||
(* ;;; "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 (LISP:CONSP LISP::FORM)
|
||||
(LISP:SYMBOLP (CAR LISP::FORM)))
|
||||
(LET ((LISP::DEF (LISP:MACRO-FUNCTION (CAR LISP::FORM)
|
||||
LISP::ENV)))
|
||||
(COND
|
||||
(LISP::DEF (LISP:IF [NOT (EQ LISP::FORM (LISP:SETQ LISP::FORM
|
||||
(LISP:FUNCALL *MACROEXPAND-HOOK*
|
||||
LISP::DEF LISP::FORM
|
||||
LISP::ENV]
|
||||
(LISP:VALUES LISP::FORM T)
|
||||
(LISP:VALUES LISP::FORM NIL)))
|
||||
(T (LISP:VALUES LISP::FORM NIL]
|
||||
(T (LISP:VALUES LISP::FORM NIL])
|
||||
|
||||
(SETF-MACRO-FUNCTION
|
||||
[LAMBDA (X BODY) (* ; "Edited 13-Feb-87 13:26 by Pavel")
|
||||
|
||||
(* ;; "the SETF function for MACRO-FUNCTION ")
|
||||
|
||||
(* ;; "NOTE: If you change this, be sure to change the undoable version on CMLUNDO!")
|
||||
|
||||
(PROG1 (LISP:SETF (GET X 'MACRO-FN)
|
||||
BODY)
|
||||
(AND (GETD X)
|
||||
(SELECTQ (ARGTYPE X)
|
||||
((1 3) (* ;
|
||||
"Leave Interlisp nlambda definition alone")
|
||||
)
|
||||
(PUTD X NIL))))])
|
||||
)
|
||||
|
||||
(APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO)
|
||||
|
||||
(ADDTOVAR GLOBALVARS COMPILERMACROPROPS)
|
||||
|
||||
(PUTPROPS * MACRO ((X . Y)
|
||||
'X))
|
||||
|
||||
(DEFMACRO LISP:MACROLET (LISP::MACRODEFS &BODY LISP::BODY &ENVIRONMENT LISP::ENV)
|
||||
(DECLARE (SPECVARS *BYTECOMPILER-IS-EXPANDING*))
|
||||
|
||||
(* ;; "This macro for the old interpreter and compiler only. The new interpreter has a special-form definition. When the new compiler is expanding, we simply return a disguised version of the form.")
|
||||
|
||||
[IF (AND *BYTECOMPILER-IS-EXPANDING* *BYTECOMPILER-OPTIMIZE-MACROLET*)
|
||||
THEN (LET ((LISP::NEW-ENV (COMPILER::MAKE-CHILD-ENV LISP::ENV)))
|
||||
(DECLARE (LISP:SPECIAL *BC-MACRO-ENVIRONMENT*))
|
||||
[FOR LISP::FN IN LISP::MACRODEFS
|
||||
DO (COMPILER::ENV-BIND-FUNCTION LISP::NEW-ENV (CAR LISP::FN)
|
||||
:MACRO
|
||||
(COMPILER::CRACK-DEFMACRO (CONS 'DEFMACRO LISP::FN]
|
||||
(LISP:SETQ *BC-MACRO-ENVIRONMENT* LISP::NEW-ENV)
|
||||
(CONS 'LISP:LOCALLY LISP::BODY))
|
||||
ELSEIF (TYPEP LISP::ENV 'COMPILER:ENV)
|
||||
THEN `(SI::%%MACROLET ,LISP::MACRODEFS ,@LISP::BODY)
|
||||
ELSE
|
||||
(LET (LISP::NEW-ENV LISP::FUNCTIONS)
|
||||
|
||||
(* ;;
|
||||
"We parse and handle the declarations here, so they'll take effect in the new child environment")
|
||||
|
||||
(LISP:MULTIPLE-VALUE-BIND
|
||||
(LISP::BODY LISP::SPECIALS)
|
||||
(\REMOVE-DECLS LISP::BODY (LISP:SETQ LISP::NEW-ENV (\MAKE-CHILD-ENVIRONMENT LISP::ENV)))
|
||||
(LISP:SETQ LISP::FUNCTIONS (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV))
|
||||
(FOR LISP::FN IN LISP::MACRODEFS
|
||||
DO (LISP:SETQ LISP::FUNCTIONS
|
||||
(LIST* (CAR LISP::FN)
|
||||
[CONS :MACRO `(LISP:LAMBDA (SI::$$MACRO-FORM
|
||||
SI::$$MACRO-ENVIRONMENT)
|
||||
(LISP:BLOCK ,(CAR LISP::FN)
|
||||
,(PARSE-DEFMACRO (CADR LISP::FN)
|
||||
'SI::$$MACRO-FORM
|
||||
(CDDR LISP::FN)
|
||||
(CAR LISP::FN)
|
||||
NIL :ENVIRONMENT
|
||||
'SI::$$MACRO-ENVIRONMENT))]
|
||||
LISP::FUNCTIONS)))
|
||||
(LISP:SETF (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV)
|
||||
LISP::FUNCTIONS)
|
||||
(WALK-FORM (CONS 'LISP:LOCALLY LISP::BODY)
|
||||
:ENVIRONMENT LISP::NEW-ENV])
|
||||
|
||||
(LISP:DEFSETF LISP:MACRO-FUNCTION SETF-MACRO-FUNCTION)
|
||||
|
||||
(PUTPROPS CMLMACROS FILETYPE LISP:COMPILE-FILE)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
|
||||
|
||||
(ADDTOVAR NLAMA )
|
||||
|
||||
(ADDTOVAR NLAML )
|
||||
|
||||
(ADDTOVAR LAMA LISP:MACROEXPAND-1 LISP:MACROEXPAND LISP:MACRO-FUNCTION)
|
||||
)
|
||||
(PUTPROPS CMLMACROS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1992 1993))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1472 9378 (CLISPEXPANSION 1482 . 2890) (GLOBAL-MACRO-FUNCTION 2892 . 4085) (
|
||||
LOCAL-MACRO-FUNCTION 4087 . 4949) (LOCAL-SYMBOL-FUNCTION 4951 . 5808) (\INTERLISP-NLAMBDA-MACRO 5810
|
||||
. 6169) (LISP:MACRO-FUNCTION 6171 . 6530) (LISP:MACROEXPAND 6532 . 7504) (LISP:MACROEXPAND-1 7506 .
|
||||
8736) (SETF-MACRO-FUNCTION 8738 . 9376)))))
|
||||
STOP
|
||||
Reference in New Issue
Block a user