;;; -*- Mode:Common-Lisp; Package:System; Base:10; Patch-file:T -*- ;;; Reason: Fix encapsulation of CLOS methods with &OPTIONAL or &KEY arguments. [SPR 9617] ;;; Fix encapsulation of internal functions which are lexical closures. [SPR 9925] ;;; 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 SYSTEM version 6.9 ;;; Written 06/20/89 18:54:40 by GRAY, ;;; while running on Kelvin from band LOD2 ;;; With Inconsistent SYSTEM 6.8, 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, Inconsistent COMPILER 6.4, TV 6.10, DATALINK 6.0, CHAOSNET 6.0, ;;; GC 6.3, MEMORY-AUX 6.0, NVRAM 6.0, SYSLOG 6.0, STREAMER-TAPE 6.2, 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.8, ;;; CLEH 6.4, IP 3.46, Experimental BUG 11.10, Experimental CLX 6.1, CLUE 6.5, X11M 6.1, ;;; Experimental DOCUMENTER 619.0, microcode 429, Band Name: 6.0 SLE 6/5 + u429 6/8 ;;; BUG REPORT NUMBER: 9617 ;;; ;;; PROBLEM: Tracing a CLOS method (as opposed to a generic function) breaks ;;; when there are optional args with no default values. Gets an error in ;;; ENCAPSULATION-ARGLIST-CONSTRUCTOR which is given an argument list that is ;;; not in the expected format. ;;; ;;; SOLUTION: In macro SYS:ENCAPSULATE, for a CLOS method, where it was just ;;; calling ARGLIST, call the new function ENCAPSULATION-METHOD-LAMBDA-LIST ;;; which fixes up optional and keyword arguments to conform to what ;;; ENCAPSULATION-ARGLIST-CONSTRUCTOR needs while still preserving lambda-list ;;; congruence for CLOS:ADD-METHOD. ;;; BUG REPORT NUMBER: 9925 ;;; ;;; PROBLEM: Get an error when running a function which has had an ADVISE ;;; done on an :INTERNAL function which is a lexical closure because the ;;; lexical environment is missing. ;;; ;;; SOLUTION: Fix the special handling for lexical closures in ;;; SYS:ENCAPSULATE. The ugly kludge that was being used to access ;;; the lexical environment seems to have been broken by new ;;; compiler optimizations for release 6, so it has been re-written ;;; to use the new sub-primitive COMPILER:%LOCAL-SLOT, which is a ;;; much simpler and more reliable technique. #!C ; From file ENCAPSULATIONS.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; ENCAPSULATIONS.#" ;;DNG 6/20/89 Use new function ENCAPSULATION-METHOD-LAMBDA-LIST to fix SPR 9617. ;; Use COMPILER:%LOCAL-SLOT to fix handling of lexical closures for SPR 9925. (defmacro encapsulate (function-spec outer-function-spec type body &optional extra-debugging-info) "Encapsulate the function named FUNCTION-SPEC with an encapsulation whose body is the value of BODY and whose type is TYPE. The args are all evaluated, but BODY is evaluated inside some bindings. OUTER-FUNCTION-SPEC is the function spec the user knows about; FUNCTION-SPEC itself may be an unencapsulated version of OUTER-FUNCTION-SPEC so as to cause this encapsulation to go inside other existing ones. Inside BODY, refer to the variable ENCAPSULATED-FUNCTION to get an object which you can funcall to invoke the original definition of the function. FUNCTION-SPEC is redefined with the new encapsulation. The value returned is the symbol used to hold the original definition. Within the code which constructs the body, this symbol is the value of COPY." `(let* ((default-cons-area background-cons-area) (copy (make-symbol (if (symbolp ,function-spec) (symbol-name ,function-spec) (prin1-to-string ,function-spec)))) (defp (fdefinedp ,function-spec)) (def (and defp (fdefinition ,function-spec))) (dbi nil) (self-flavor-decl nil) (generic-function nil) encapsulated-function lambda-list arglist-constructor macro-def methodp (lexp (uses-lexical-environment-p def))) (if defp (setq dbi (get-debug-info-struct def) self-flavor-decl (get-debug-info-field dbi :self-flavor) generic-function (get-debug-info-field dbi :generic-function) macro-def (encapsulation-macro-definition def) lambda-list (encapsulation-lambda-list def)) (setq lambda-list '(&rest .arglist.))) (and (symbolp lambda-list) (ferror () "~S cannot be encapsulated due to hairy arg quoting" ,outer-function-spec)) (when (setq methodp (or (member (car-safe ,function-spec) '(ticlos:method ticlos:handler) :test #'eq) (get-debug-info-field dbi :map-slots))) (setq lambda-list (encapsulation-method-lambda-list def))) (setq arglist-constructor `(list* . ,(cdr (encapsulation-arglist-constructor lambda-list)))) (and defp (fset copy def )) (setq encapsulated-function (cond (macro-def `(encapsulation-macro-definition (function ,copy))) (lexp '.lex-closure.) (methodp `#'(named-lambda encapsulation (&rest args) (%apply-method #',copy args .map-list. (next-method-list)))) (t `(function ,copy)))) ;; Warning: if the arrangement of the DEF form below is changed, it may ;; be necessary to update the function ENCAPSULATION-BODY also. (setq def `(,(if (zetalisp-on-p) 'global:named-lambda 'named-lambda) (,,function-spec (encapsulated-definition (,copy ,,type) ,@(if self-flavor-decl (list :self-flavor self-flavor-decl) (and generic-function (list :generic-function generic-function))) ,@,extra-debugging-info)) ,lambda-list ,@(and methodp `((declare (ticlos::specializers . ,(car (last ,function-spec)))))) ;; (declare (encapsulated-definition ,copy ,,type) ;; . ,,extra-debugging-info ) ;; ,@(if self-flavor-decl ;; `((declare (:self-flavor ,self-flavor-decl)))) (let* ,(if lexp `((arglist ,arglist-constructor) (.lex-closure. (make-lexical-closure (compiler:%local-slot lex-parent-env-reg) (function ,copy)))) (if methodp `((.map-list. (compiler::list-of-maps)) (arglist ,arglist-constructor)) `((arglist ,arglist-constructor)))) (declare (special arglist values)) ,,body))) (and (member 'rename-within (cdr (member ,type encapsulation-standard-order :test #'eq)) :test #'eq) (setq def (rename-within-new-definition-maybe ,outer-function-spec def))) (when (or lexp ; must be compiled to receive lexical environment methodp ; must be compiled to receive mapping tables and next method list generic-function ; must be a FEF for #'name to be recognized as a generic function by method dispatch. ) (setq compile-encapsulations-flag t)) (and macro-def (setq def (cons 'macro def))) (fdefine ,function-spec def nil t) copy)) )) #!C ; From file ENCAPSULATIONS.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; ENCAPSULATIONS.#" ;; 6/20/89 DNG - Original. (defun encapsulation-method-lambda-list (def) ;; Called by the expansion of ENCAPSULATE. ;; Special handling for CLOS methods -- can't use ENCAPSULATION-LAMBDA-LIST ;; because it doesn't preserve argument list congruence as required by CLOS. ;; We need to keep optional arguments and preserve an indication of whether ;; keyword arguments are allowed. (let* ((a (arglist def))) (if (and (not (memq '&optional a)) (not (memq '&key a))) a (let ((a (copy-list a))) (do ((tail (rest (memq '&optional a)) (rest tail))) ((endp tail)) (let ((x (car tail))) (when (memq x lambda-list-keywords) (return)) ;; In order for ENCAPSULATION-ARGLIST-CONSTRUCTOR to work correctly, ;; all optional arguments must have supplied flags. (cond ((atom x) (setf (car tail) (list x nil (gensym)))) ((null (cddr x)) (setf (car tail) (list (first x) (second x) (gensym)))) ))) (do ((tail a (rest tail))) ((endp (rest tail))) (when (eq (second tail) '&key) ;; Must preserve the fact that keywords are accepted, but not the ;; individual keywords. Create a &REST arg to hold the keywords if there ;; isn't one already. (setf (rest tail) (if (memq '&rest a) '(&key &allow-other-keys) `(&rest .rest. &key &allow-other-keys))) (return))) a)))) )) ;;; The following functions have not been changed; they just need to be ;;; recompiled with the new version of macro ENCAPSULATE . #!C ; From file ADVISE.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; ADVISE.#" (defun advise-init (function-spec) (let ((default-cons-area background-cons-area) (spec1 (unencapsulate-function-spec function-spec 'advise))) (pushnew function-spec advised-functions :test #'equal) (cond ((neq spec1 (unencapsulate-function-spec spec1 '(advise))) (uncompile spec1 t) (let ((body (encapsulation-body (fdefinition spec1)))) ;; (car body) looks like: ;; (advised-function nil nil nil encapsulated-function) (when (eq (car (car body)) 'displaced) (setf (car body) (cadr (car body)))))) (t (encapsulate spec1 function-spec 'advise `(advised-function () () () ,encapsulated-function)))))) )) #!C ; From file BREAKON.LISP#> EH; MR-X: #10R EH#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "EH")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: EH; BREAKON.#" (defun breakon-init (function-spec) ;; Make a specifed function into an broken-on function ;; (with no conditions yet) if it isn't one already. (declare (special *breakon-functions*)) (let ((default-cons-area background-cons-area) (spec1 (si:unencapsulate-function-spec function-spec 'breakon))) (when (eq spec1 (si:unencapsulate-function-spec spec1 '(breakon))) (si:encapsulate spec1 function-spec 'breakon ;; Must cons the (OR) afresh -- it gets RPLAC'd. `(breakon-this-time ,(list 'or) ,si:encapsulated-function arglist)) (push function-spec *breakon-functions*)))) )) #!C ; From file ENCAPSULATIONS.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; ENCAPSULATIONS.#" (defun rename-within-init (function &aux spec1) ;; must get the plist instead of the field so we know if the field exists or not. (setq spec1 (unencapsulate-function-spec function 'rename-within)) (unless (and (fdefinedp spec1) (neq 'empty (get-debug-info-field (get-debug-info-struct spec1) 'renamings 'empty))) (let ((compile-encapsulations-flag compile-encapsulations-flag)) ; may be set by encapsulate (push function rename-within-functions) (encapsulate spec1 function 'rename-within `(apply ,encapsulated-function arglist) (copy-tree '(renamings nil))) (when compile-encapsulations-flag (compile-encapsulations spec1 'rename-within))) ) function) )) #!C ; From file TRACE.LISP#> KERNEL; MR-X: #10R SYSTEM#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; TRACE.#" (defun trace-1 (spec) (prog (break exitbreak entrycond exitcond wherein argpdl entry exit (arg t) (value t) step (barfp t) stepcond entryvals exitvals mumble fcn spec1 trfcn error step-compile-flag (compile-encapsulations-flag compile-encapsulations-flag) ; may be set by encapsulate (default-cons-area background-cons-area)) (cond ((atom spec) (setq fcn spec)) (t (cond ((eq (car spec) :function) (setq fcn (cadr spec) spec (cdr spec))) ((atom (car spec)) (setq fcn (car spec))) ((validate-function-spec spec) (SETQ fcn spec spec (LIST spec))) ((validate-function-spec (CAR SPEC)) (SETQ FCN (CAR SPEC))) (t (return (loop for fcn in (car spec) nconc (trace-1 `(:function ,fcn ,@(cdr spec))))))) (do ((specs (cdr spec) (cdr specs))) ((null specs) nil) (case (car specs) (:break (setq barfp specs specs (cdr specs) break (car specs))) (:exitbreak (setq barfp specs specs (cdr specs) exitbreak (car specs))) (:stepcond (setq barfp specs specs (cdr specs) stepcond (car specs) step t)) (:step (setq step t) (setq step-compile-flag t)) (:error (setq error t)) (:cond (setq barfp specs specs (cdr specs)) (setq stepcond (setq exitcond (setq entrycond (car specs))))) (:entrycond (setq barfp specs specs (cdr specs) entrycond (car specs))) (:exitcond (setq barfp specs specs (cdr specs) exitcond (car specs))) (:wherein (setq barfp specs specs (cdr specs) wherein (car specs))) (:argpdl (setq barfp specs specs (cdr specs) argpdl (car specs))) (:entry (setq barfp specs specs (cdr specs) entry (car specs))) (:exit (setq barfp specs specs (cdr specs) exit (car specs))) (:print (setq barfp specs specs (cdr specs) entry (cons (car specs) entry) exit (cons (car specs) exit))) (:entryprint (setq barfp specs specs (cdr specs) entry (cons (car specs) entry))) (:exitprint (setq barfp specs specs (cdr specs) exit (cons (car specs) exit))) ((:arg :value :both nil) (and (eq (car specs) :arg) (setq value ())) (and (eq (car specs) :value) (setq arg ())) (and (eq (car specs) ()) (setq arg () value ())) (and arg (setq entryvals (cdr specs))) (and value (setq exitvals (cdr specs))) (return ())) (otherwise (setq mumble (car specs)) (return ()))) (and (null barfp) (ferror () "Parameter missing"))))) (SETQ FCN (DWIMIFY-ARG-PACKAGE FCN 'FCN)) (untrace-1 fcn) (and mumble (return (ferror () "Meaningless TRACE keyword: ~S" mumble))) (check-arg argpdl symbolp "a symbol") (setq spec1 (unencapsulate-function-spec fcn 'trace)) (setq trfcn (encapsulate spec1 fcn 'trace `(block nil (let* (,@(and argpdl `((,argpdl (cons (list (1+ ,copy) ',fcn arglist) ,argpdl)))) values (,copy (1+ ,copy)) (trace-level (1+ trace-level))) (declare (special ,copy values)) ,(if error `(progn (let ((eh:*error-depth* (1+ eh:*error-depth*)) (eh:*condition-proceed-types* '(:no-action))) (eh:invoke-debugger (make-condition 'eh:trace-breakpoint "~S entered" ',fcn))) (return (values-list (multiple-value-list (apply ,encapsulated-function arglist))))) `(cond ((or inside-trace ,@(and wherein `((not (function-active-p ',wherein))))) (return (apply ,encapsulated-function arglist))) (t (let ((inside-trace t)) ,(trace-maybe-conditionalize entrycond `(trace-print ,copy 'enter ',fcn ',arg ',entry ',entryvals)) ,@(and break `((and ,break (let (inside-trace) (break "Entering ~S." ',fcn))))) (setq values (let ((inside-trace nil)) (multiple-value-list ,(if (and step stepcond) ;; conditionally call the stepper. `(if ,stepcond (step-apply ,encapsulated-function arglist) (apply ,encapsulated-function arglist)) `(,(if step 'step-apply 'apply) ,encapsulated-function arglist))))) ,(trace-maybe-conditionalize exitcond `(trace-print ,copy 'exit ',fcn ',value ',exit ',exitvals)) ,@(and exitbreak `((and ,exitbreak (let (inside-trace) (break "Exiting ~S." ',fcn))))) (return (values-list values)))))))) )) (set trfcn 0) (push fcn traced-functions) (if (or trace-compile-flag step-compile-flag compile-encapsulations-flag) (compile-encapsulations spec1 'trace)) (return (cons fcn ())))) ))