;;; -*- Mode:Common-Lisp; Package:COMPILER; Base:10; Patch-file:T; Fonts:(CPTFONT CPTFONTB HL12BI HL12) -*- ;;; Reason: Fix SYMBOL-MACROLET for SETF on macros with DEFSETF definitions. [SPR 9627] 3;;; RESTRICTED RIGHTS LEGEND ;;; ;;; Use, duplication, or disclosure by the Government is subject to ;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;; Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 149149, M/S 2151 ;;; AUSTIN, TEXAS 78714 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Patch file for COMPILER version 6.5 ;;; Written 06/22/89 17:52:42 by GRAY, ;;; while running on Kelvin from band LOD2 ;;; With Inconsistent SYSTEM 6.9, VIRTUAL-MEMORY 6.1, EH 6.3, MAKE-SYSTEM 6.0, MICRONET 6.0, ;;; LOCAL-FILE 6.0, BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.1, ;;; NETWORK-NAMESPACE 6.0, DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0, ;;; NETWORK-PATHNAME 6.0, COMPILER 6.4, TV 6.11, DATALINK 6.0, CHAOSNET 6.0, GC 6.3, ;;; MEMORY-AUX 6.0, NVRAM 6.0, SYSLOG 6.0, STREAMER-TAPE 6.0, UCL 6.0, INPUT-EDITOR 6.0, ;;; METER 6.0, ZWEI 6.3, Inconsistent DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, ;;; DATALINK-DISPLAYS 6.0, FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.1, MAC-PRINTER-TYPES 6.1, ;;; PRINTER-TYPES 6.0, IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, ;;; TELNET 6.0, VT100 6.0, NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, Inconsistent TI-CLOS 6.9, ;;; CLEH 6.4, IP 3.46, Experimental BUG 11.10, Experimental CLX 6.1, CLUE 6.5, X11M 6.1, ;;; Experimental DOCUMENTER 619.0, Experimental GENASYS 3.0, microcode 429, Band Name: 6.0 SLE 6/5 + u429 6/8 ;;; BUG REPORT NUMBER: 9627 ;;; ;;; PROBLEM: When a form such as *(SETF (FOO BAR) NEWVAL)3 appears within the ;;;* 3body of a *SYMBOL-MACROLET3 and *FOO3 has a *SETF3 method defined by *DEFSETF3, ;;;* 3but will macroexpand into something else, then incorrect code is ;;;* 3generated. The call to *FOO3 is macroexpanded before processing the *SETF3, ;;;* 3hence the *DEFSETF3 is effectively ignored. ;;; ;;; SOLUTION: The ultimate solution is to re-implement *SYMBOL-MACROLET3 as a ;;;* 3special form, using *MACROEXPAND3 to replace the symbols with their ;;;* 3expansions, in accordance with the latest ANSI Common Lisp ;;;* 3specifications. However, that is too big a change to do now, so this ;;;* 3patch takes the approach of doing a localized fix for just those cases ;;;* 3that are clearly being handled wrong now. When a *SETF3 form is seen in ;;;* 3which the destination is a macro which also has a *DEFSETF3, then let the ;;;* SETF3 be macroexpanded normally instead of macroexpanding its arguments ;;;* 3first. ;;; ;;;* 3This patch also corrects another problem in the code walker that was ;;;* 3discovered while investigating the *SYMBOL-MACROLET3 problem: there was a ;;;* 3simple oversight in *CW-EXPRESSION3 whereby the second of the two places ;;;* 3that macroexpand environments are constructed was not including the ;;;* CW-EXTRA-ENVIRONMENT3. This could cause incorrect results for macros that ;;;* 3pass their environment argument to functions such as *FIND-CLASS3 or *GETDECL3.* #!C ; From file WALKER.LISP#> COMPILER; MR-X: #10R COMPILER#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; WALKER.#" (defmacro ticlos:symbol-macrolet (bindings &body body &environment env) "Syntax: SYMBOL-MACROLET ({(symbol expansion)}*) &BODY body Replaces each occurrence of SYMBOL as a free variable in BODY with its corresponding EXPANSION. Also changes SETQ to SETF when necessary. Declarations are permitted at the front of the body." (declare (arglist bindings &body body)) ;; 4/26/88 DNG - Original version. ;; 9/14/88 DNG - Add support for declarations. ;; 11/23/88 DNG - Fix for (SETF (VALUES ...) ...). ;; 4/18/89 DNG - Extend to support MULTIPLE-VALUE-SETQ. (this feature ;; adopted by X3J13, March 1989) 1 ;; 6/22/89 DNG - Don't macroexpand the destination form of a SETF if it ;;* 1there is a DEFSETF defined for it. [SPR 9627] (declare (:expr-sxhash 3117273))* (if (null bindings) `(locally . ,body) ;; First find and process any type declarations that refer to the ;; variables being declared. (multiple-value-bind (body decls) (parse-body body env nil) (let ((other-decls '())) (flet ((record-type (type vars) (dolist (v vars) (let ((tem (assoc v bindings :test #'eq))) (if tem (push (list v `(the ,type ,(second tem))) bindings) (push `(type ,type ,v) other-decls)))))) (dolist (declare decls) (debug-assert (eq (first declare) 'declare)) (dolist (decl (cdr declare)) (if (eq (first decl) 'type) (record-type (second decl) (cddr decl)) (if (standard-type-name-P (first decl) t) (record-type (first decl) (rest decl)) (progn (when (eq (first decl) 'special) (dolist (v (rest decl)) (when (assoc v bindings :test #'eq) (error "(DECLARE (SPECIAL ~S)) is not permitted in ~S." v 'ticlos:symbol-macrolet)))) (push decl other-decls))))))) ;; Now scan the body, making substitutions where needed. (code-walk (cond (other-decls `(locally (declare . ,(nreverse other-decls)) . ,body)) ((cdr body) `(progn . ,body)) (t (first body))) #'(lambda (form) (case (car form) (SETQ (do ((tail (cdr form) (cddr tail))) ((null tail) form) (let ((tem (assoc (car tail) bindings :test #'eq))) (when (and tem (not (symbolp (second tem)))) ;; Need to change SETQ to SETF. Can't just return ;; `(SETF .,(CDR FORM)) because SETF would expand ;; back into a SETQ and we would hang in a loop. (return (values `(setf . ,(mapcar #'cw-expression (cdr form))) t)) )))) ;; Avoid macro-expanding SETF so that it doesn't change ;; back into a SETQ or MULTIPLE-VALUE-SETQ. (SETF1 (let ((dest (second form)))* 1 (if (and (consp dest)* 1 (or (getdecl (first dest) 'si:setf-method)* 1 (getdecl (first dest) 'si:setf-expand))* 1 ;; Note: not using the local environment for macroexpand-1* 1 ;; because DEFSETF only applies to the global definition.* 1 (not (eq dest (macroexpand-1 dest *compile-file-environment*))))* 1 ;; There is a DEFSETF that needs to be used instead of the macro * 1 ;; expansion, so let the SETF form be macro-expanded. [SPR 9627]* 1 form* (values `(setf . ,(mapcar #'cw-expression (cdr form))) t)1))*) (MULTIPLE-VALUE-SETQ (dolist (a (second form) form) (when (assoc a bindings :test #'eq) (return `(setf (values . ,(mapcar #'cw-expression (second form))) . ,(cddr form)))))) (t form))) #'(lambda (var) (let ((tem (assoc var bindings :test #'eq))) (if tem (values (second tem) t) var))) t env))))) )) #!C ; From file WALKER.LISP#> COMPILER; MR-X: #10R COMPILER#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; WALKER.#" (defun cw-expression (exp &optional skip-handler &aux tem stop) ;; 10/18/86 DNG - Use si:args-desc instead of arglist to check for "e args. ;; 1/28/87 DNG - Don't bind cw-function-environment to nil when expanding a local macro. [SPR 3088] ;; 12/11/87 DNG - Allow ALL-FUNCTIONS-TO-CHECK-FOR to be T to cause all to be returned. ;; Modify update of ALL-FUNCTIONS to check for (SYMBOLP (CAR EXP)) ;; and use :TEST #'EQ for efficiency. ;; Add :TEST #'EQ to the second PUSHNEW call for efficiency. ;; 4/26/88 DNG - Updated to support new interface function CODE-WALK. ;; 3/15/89 DNG - Use GET-FROM-FRAME-LIST. ;; 4/11/89 DNG - Add use of CW-EXTRA-ENVIRONMENT . ;; 4/18/89 DNG - Add use of WARN-ON-ERRORS; this is needed within SYMBOL-MACROLET. 1 ;; 6/22/89 DNG - Fix to include CW-EXTRA-ENVIRONMENT in the environment ;;* 1passed to MACROEXPAND-1. Also use WITH-INTERPRETER-ENVIRONMENT instead ;;* 1of WITH-STACK-LIST*.* (typecase exp (symbol (unless (or (null exp) skip-handler (member exp *local-variables* :test #'eq)) (multiple-value-setq (exp stop) (funcall *cw-var-handler* exp)))) (cons (unless (or skip-handler (not (symbolp (car exp))) (member (car exp) *local-functions* :test #'eq)) (case (car exp) ( quote ) ( function (multiple-value-setq (exp stop) (funcall *cw-function-handler* exp))) ( t (unless (eq *cw-form-handler* #'identity) (multiple-value-setq (exp stop) (funcall *cw-form-handler* exp))))) ))) (cond ((or (atom exp) stop) exp) ((consp (car exp)) ;; Explicit lambda-expression (if cw-return-expansion-flag (cons (cw-lambda-expression (car exp)) (mapcar #'cw-expression (cdr exp))) (progn (cw-lambda-expression (car exp)) (mapc #'cw-expression (cdr exp))))) ((nsymbolp (car exp)) (cw-eval-args exp)) ((setq tem (get-from-frame-list (locf (symbol-function (car exp))) cw-function-environment nil)) (if (eq (car-safe tem) 'macro) ;; Local definition is a macro. Call its expander. (1sys:with-interpreter-environment* (si:*macroexpand-environment* nil cw-function-environment cw-extra-environment) (cw-expression (funcall (cdr tem) exp si:*macroexpand-environment*))) ;; Local definition is not a macro. Assume it evals its args. (cw-eval-args exp))) ((setq tem (get (car exp) 'cw-handler)) ;; special form with its own way of doing this. (funcall tem exp)) ;;kludge to deal with "e. Blech ((and (fboundp (car exp)) (nth-value 3 (si:args-desc (car exp)))) (let ((quoted nil) (tem (arglist (car exp) t))) (flet ((frob (arg) (do ((x (pop tem) (pop tem))) ((not (member x lambda-list-keywords :test #'eq)) (if quoted arg (cw-expression arg))) (cond ((eq x '"e) (setq quoted t)) ((eq x '&eval) (setq quoted nil)))))) (if cw-return-expansion-flag (cons (car exp) (mapcar #'frob (cdr exp))) (mapc #'frob (cdr exp)))))) ((multiple-value-bind (v1 v2) (1sys:with-interpreter-environment* (env nil cw-function-environment 1cw-extra-environment*) (if (eq (second (first eh:*condition-handlers*)) 'warn-on-errors-condition-handler) ;; If already within the WARN-ON-ERRORS in PRE-OPTIMIZE, need to handle ;; errors here so they get reported accurately instead of having ;; PRE-OPTIMIZE report a problem with the top-level macro. (block warn (WARN-ON-ERRORS ('MACRO-EXPANSION-ERROR "Error expanding macro ~S:" (car exp)) (return-from warn (macroexpand-1 exp env))) ;; here if there was an error. (return-from cw-expression `(ERROR-MACRO-EXPANDING ',exp))) (macroexpand-1 exp env))) (setq tem v1) v2) ;; Macro call. (cw-expression tem)) (t (cw-eval-args exp)))) ))