;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 121.13 ;;; Reason: ;;; Fix SI::DEFSTRUCT-EXPAND-{SIZE,CONS,ALTER,REF}-MACRO to take an ;;; (ignored) ENV argument so that it will be a real Common Lisp ;;; macro-expander function. ;;; Make Common Lisp versions of MACROEXPAND(-1) that respect the 22 special ;;; forms and use alternate macro definitions. ;;; Add SI:IMPLEMENTATION-SPECIAL-FORM-P, SI:COMMON-LISP-SPECIAL-FORM-P. ;;; Written 24-Jan-87 16:44:18 by RpK (Robert P. Krajewski) at site LMI Cambridge ;;; while running on Cthulhu from band 3 ;;; with Experimental System 121.12, Experimental Lambda-Diag 15.0, Experimental ZMail 70.1, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, Experimental K Bridge Support 1.0, microcode 1730, SDU Boot Tape 3.12, SDU ROM 102, the old ones. (si::make-incompatible-cl-symbols '("MACROEXPAND" "MACROEXPAND-1")) ; From modified file DJ: L.SYS2; STRUCT.LISP#333 at 24-Jan-87 16:58:52 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; STRUCT  " (defun defstruct-expand-size-macro (x #+Common env) #+Common (declare (ignore env)) (let ((description (get-defstruct-description (getdecl (car x) 'defstruct-name)))) (let ((type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type))))) (+ (defstruct-description-size) (defstruct-type-description-overhead))))) )) ; From modified file DJ: L.SYS2; STRUCT.LISP#333 at 24-Jan-87 16:58:58 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; STRUCT  " (defun defstruct-expand-ref-macro (x #+Common env) #+Common (declare (ignore env)) (let* ((pair (getdecl (car x) 'defstruct-slot)) (description (get-defstruct-description (car pair))) (type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type)))) (code (defstruct-type-description-ref-expander)) (n (defstruct-type-description-ref-no-args)) (args (reverse (cdr x))) (nargs (length args)) (default (defstruct-description-default-pointer)) (but-first (defstruct-description-but-first))) (cond ((= n nargs) (and but-first (rplaca args `(,but-first ,(car args))))) ((and (= n (1+ nargs)) default) (setq args (cons (if but-first `(,but-first ,default) default) args))) (t (defstruct-error "Wrong number of args to an accessor macro" x))) (let* ((slot-description (cdr (or (assq (cdr pair) (defstruct-description-slot-alist)) (defstruct-error "This slot no longer exists in this structure" (cdr pair) 'in (car pair))))) (ref (APPLY code (defstruct-slot-description-number) description (nreverse args))) (ppss (defstruct-slot-description-ppss))) (if (null ppss) ref `(ldb ,ppss ,ref))))) )) ; From modified file DJ: L.SYS2; STRUCT.LISP#333 at 24-Jan-87 16:59:05 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; STRUCT  " (defun defstruct-expand-ref-macro (x #+Common env) #+Common (declare (ignore env)) (let* ((pair (getdecl (car x) 'defstruct-slot)) (description (get-defstruct-description (car pair))) (type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type)))) (code (defstruct-type-description-ref-expander)) (n (defstruct-type-description-ref-no-args)) (args (reverse (cdr x))) (nargs (length args)) (default (defstruct-description-default-pointer)) (but-first (defstruct-description-but-first))) (cond ((= n nargs) (and but-first (rplaca args `(,but-first ,(car args))))) ((and (= n (1+ nargs)) default) (setq args (cons (if but-first `(,but-first ,default) default) args))) (t (defstruct-error "Wrong number of args to an accessor macro" x))) (let* ((slot-description (cdr (or (assq (cdr pair) (defstruct-description-slot-alist)) (defstruct-error "This slot no longer exists in this structure" (cdr pair) 'in (car pair))))) (ref (APPLY code (defstruct-slot-description-number) description (nreverse args))) (ppss (defstruct-slot-description-ppss))) (if (null ppss) ref `(ldb ,ppss ,ref))))) )) ; From modified file DJ: L.SYS2; STRUCT.LISP#333 at 24-Jan-87 16:59:09 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; STRUCT  " (defun defstruct-expand-cons-macro (x #+Common env) #+Common (declare (ignore env)) (LET* ((DEFSTRUCT-NAME (getdecl (car x) 'defstruct-name)) (description (get-defstruct-description defstruct-name)) (constructor-description (cdr (or (assq (car x) (defstruct-description-constructors)) (defstruct-error "This constructor is no longer defined for this structure" (car x) 'in (defstruct-description-name)))))) (DEFSTRUCT-EXPAND-CONS-MACRO-1 (CAR X) DEFSTRUCT-NAME CONSTRUCTOR-DESCRIPTION (CDR X)))) )) ; From modified file DJ: L.SYS2; STRUCT.LISP#333 at 24-Jan-87 16:59:14 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; STRUCT  " (defun defstruct-expand-alter-macro (x #+Common env) #+Common (declare (ignore env)) (let* ((description (get-defstruct-description (getdecl (car x) 'defstruct-name))) (type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type)))) (ref-code (defstruct-type-description-ref-expander)) (ref-nargs (defstruct-type-description-ref-no-args))) (do ((l (car (defstruct-parse-setq-style-slots (nthcdr (1+ ref-nargs) x) (defstruct-description-slot-alist) nil x)) (cdr l)) (but-first (defstruct-description-but-first)) (body nil) (avars (do ((i 0 (1+ i)) (l nil (cons (gensym) l))) ((= i ref-nargs) l))) (vars nil) (vals nil)) ((null l) `((lambda ,avars ,@(if (null vars) body `(((lambda ,vars ,@body) ,.vals)))) ,@(do ((i (1- ref-nargs) (1- i)) (l `(,(if but-first `(,but-first ,(nth ref-nargs x)) (nth ref-nargs x))) (cons (nth i x) l))) ((= i 0) l)))) (let ((ref (APPLY ref-code (caar l) description avars))) (and (defstruct-emptyp (car (cddr (car l)))) (setf (car (cddr (car l))) ref)) (let ((code (defstruct-code-from-dsc (car l)))) (if (null (cdr l)) (push `(setf ,ref ,code) body) (let ((sym (gensym))) (push `(setf ,ref ,sym) body) (push sym vars) (push code vals)))))))) )) ; From modified file DJ: L.SYS; QFCTNS.LISP#832 at 24-Jan-87 16:44:18 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  " (defun common-lisp-special-form-p (symbol) (and (memq symbol *common-lisp-one-true-and-only-official-special-forms*) t)) (defun implementation-special-form-p (symbol) (and (interpreter-special-form symbol) t)) (defun special-form-p (symbol &optional environment) "T if SYMBOL has a function definition taking unevaluated arguments. This does not include macros. To test for them, use MACRO-FUNCTION." (if (fsymeval-in-environment symbol environment nil) nil ;we don't allow (flet ((foo (... "e ...) (or (common-lisp-special-form-p symbol) (implementation-special-form-p symbol)))) )) ; From modified file DJ: L.SYS; QFCTNS.LISP#832 at 24-Jan-87 16:45:56 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  " (defun record-macro-expanded (name) (and record-macros-expanded (pushnew name macros-expanded :test #'eq))) )) ; From modified file DJ: L.SYS; QFCTNS.LISP#832 at 24-Jan-87 16:46:20 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  " (defun call-macro-expander (expander macro-call environment) (let ((*macroexpand-environment* environment) (ainf (args-info expander))) (if (or (symbolp expander) ;; No check for explicit macro expanders (> (ldb %%arg-desc-max-args ainf) 1)) (funcall *macroexpand-hook* expander macro-call environment) (funcall *macroexpand-hook* expander macro-call) t))) ;;; Macroexpand MACRO-CALL once, if possible. ;;; If there is nothing to expand, return it unchanged. ;;; Macros, open-coded functions and CURRY-BEFORE and CURRY-AFTER are expanded. (defun expand-macro-call (macro-call environment expand-substs &key inhibitor macro-function-finder) (declare (values expansion expanded-flag)) (if (atom macro-call) macro-call (let ((name (car macro-call))) (cond ((not (atom name)) (cond ((eq (caar macro-call) 'curry-after) (values `(,(cadar macro-call) ,@(cdr macro-call) . ,(cddar macro-call)) t)) ((eq (caar macro-call) 'curry-before) (values `(,(cadar macro-call) ,@(cddar macro-call) . ,(cdr macro-call)) t)) ;; Have to ignore EXPAND-SUBSTS here since compiler can't deal with ((SUBST ...) ...) ((memq (caar macro-call) '(subst cli:subst named-subst)) (values (funcall *macroexpand-hook* 'subst-expand-1 macro-call environment) t)) (t macro-call))) ((not (symbolp name)) macro-call) (t (let ((tm (fsymeval-in-environment name environment nil))) (cond (tm ; local definition (if (eq (car-safe tm) 'macro) (call-macro-expander (cdr tm) macro-call environment) macro-call)) ;; Possibly inhibit macro expansion. ((and inhibitor (funcall inhibitor name)) macro-call) ((and macro-function-finder (setq tm (funcall macro-function-finder name))) (record-macro-expanded name) (values (call-macro-expander tm macro-call environment) t)) (t (cond ((typep (setq tm (declared-definition name)) 'compiled-function) ; Possible compiler-defined subst (if expand-substs (progn ;; If function is compiled, see if its interpreted defn is recorded. (setq tm (assq 'interpreted-definition (debugging-info tm))) (if (and tm (memq (caadr tm) '(subst cli:subst named-subst))) (progn (record-macro-expanded name) (values (funcall *macroexpand-hook* 'subst-expand-1 macro-call environment) t)) macro-call)) macro-call)) ((atom tm) macro-call) ; ordinary function ((eq (car tm) 'macro) (record-macro-expanded name) (values (call-macro-expander (cdr tm) macro-call environment) t)) ((memq (car tm) '(subst cli:subst named-subst)) ; interpreter-defined SUBST (if expand-substs (progn (record-macro-expanded name) (values (funcall *macroexpand-hook* 'subst-expand-1 macro-call environment) t)) macro-call)) (t macro-call))) (t macro-call)))))))) )) ; From modified file DJ: L.SYS; QFCTNS.LISP#832 at 24-Jan-87 16:55:32 #8R SYSTEM-INTERNALS#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS"))) (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  " (defun macroexpand-1 (macro-call &optional environment) "Expand MACRO-CALL once and return the result. Macro calls, uses of SUBSTs, uses of CURRY-BEFORE and CURRY-AFTER, and uses of functions for which OPEN-CODE-P is true, are all expanded. Uses of some Common Lisp special forms will be expanded; use LISP:MACROEXPAND-1 to avoid this. The second value is T if there was something to expand. If SYS:RECORD-MACROS-EXPANDED is non-NIL, all macro names are pushed on SYS:MACROS-EXPANDED. The value of *MACROEXPAND-HOOK* (which should behave like FUNCALL) is used to invoke the expander function." (declare (values expansion expanded-flag)) (expand-macro-call macro-call environment t)) ;;; Expand any macros in top level of a form. (defun macroexpand (macro-call &optional environment) "Expand MACRO-CALL repeatedly until the result is not a macrocall. Uses of some Common Lisp special forms will be expanded; use LISP:MACROEXPAND to avoid this." (do ((tm macro-call (macroexpand-1 tm environment)) (otm nil tm)) ((or (eq tm otm) (atom tm)) tm))) (defun cli:macroexpand-1 (macro-call &optional environment) "Expand MACRO-CALL once and return the result. Macro calls, uses of SUBSTs, uses of CURRY-BEFORE and CURRY-AFTER, and uses of functions for which OPEN-CODE-P is true, are all expanded. Common Lisp special forms are not expanded even if they are implemented as macros; use ZL:MACROEXPAND-1 to get the expansion in terms of Zetalisp. The second value is T if there was something to expand. If SYS:RECORD-MACROS-EXPANDED is non-NIL, all macro names are pushed on SYS:MACROS-EXPANDED. The value of *MACROEXPAND-HOOK* (which should behave like FUNCALL) is used to invoke the expander function." (declare (values expansion expanded-flag)) (expand-macro-call macro-call environment t :inhibitor #'common-lisp-special-form-p :macro-function-finder #'macro-function)) (defun cli:macroexpand (macro-call &optional environment) "Expand MACRO-CALL repeatedly until the result is not a macrocall. Common Lisp special forms are not expanded even if they are implemented as macros; use ZL:MACROEXPAND to get the expansion in terms of Zetalisp." (do ((tm macro-call (cli:macroexpand-1 tm environment)) (otm nil tm)) ((or (eq tm otm) (atom tm)) tm))) ))