;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: Fixed the previous patch for (:PROPERTY METHOD SI:FUNCTION-SPEC-HANDLER) to do a COPY-TREE on the function ;;; spec that it plugs into the FEF to ensure that the spec is modifiable by (GENERIC-FUNCTION :ADD-METHOD). ;;; 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-9149 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 03/20/90 14:07:42 by FLORMAN, ;;; while running on MX29 from band REL6 ;;; With SYSTEM 6.31, GC 6.3, VIRTUAL-MEMORY 6.3, MICRONET 6.0, MICRONET-COMM 6.2, ;;; DISK-IO 6.2, DISK-LABEL 6.0, BASIC-PATHNAME 6.4, MAC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.2, ;;; BASIC-NAMESPACE 6.7, BASIC-FILE 6.8, RPC 6.2, NFS-MX 6.6, EH 6.6, MAKE-SYSTEM 6.2, ;;; MEMORY-AUX 6.0, COMPILER 6.14, TV 6.24, NVRAM 6.2, UCL 6.0, INPUT-EDITOR 6.0, ;;; MACTOOLBOX 2.14, METER 6.1, ZWEI 6.13, DEBUG-TOOLS 6.4, WINDOW-MX 6.10, PRINTER 6.3, ;;; MAC-PRINTER-TYPES 6.1, CLIPBOARD 6.1, TI-CLOS 6.41, CLEH 6.5, NETWORK-PATHNAME 6.1, ;;; NETWORK-NAMESPACE 6.1, DATALINK 6.0, CHAOSNET 6.5, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.2, ;;; DATALINK-DISPLAYS 6.0, MX-DATALINK 6.1, NAMESPACE-EDITOR 6.4, IP 3.58, NFS-MX-SERVER 6.0, ;;; MX-SERIAL 6.1, PRINTER-TYPES 6.2, IMAGEN 6.1, MAIL-DAEMON 6.5, MAIL-READER 6.7, ;;; TELNET 6.1, VT100 6.0, STREAMER-TAPE 6.5, DECNET 1.72, VISIDOC 6.7, PROFILE 6.2, ;;; Experimental CLX 6.8, CLUE 6.81, Experimental BUG 11.18, microcode 139, Band Name: microExplorer Network + SLE (11/28) #!C ; From file FUNCTION-SPEC.LISP#> CLOS; Hotel: #10R TICLOS#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TICLOS")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: CLOS; FUNCTION-SPEC.#" ;; 3/20/90 BAF - Fixed the previous patch to do a COPY-TREE on the function spec that it plugs into the FEF. ;; This ensures that the spec is modifiable by (GENERIC-FUNCTION :ADD-METHOD). (defun (:property method sys:function-spec-handler) (function function-spec &optional arg1 arg2) (let* ((gname (second function-spec)) (rest (nthcdr 2 function-spec)) (qualifiers (collect-body (loop (when (listp (car rest)) (return)) (collect (pop rest))))) (specializer-names (pop rest))) (if (eq function 'sys:validate-function-spec) ;; This checks for syntactic validity without requiring that the generic ;; function and classes be defined. Thus, this indicates whether the name ;; is acceptable to FDEFINEDP but does not necessarily mean that FDEFINE ;; would be valid. This interpretation is necessary for ;; SYS:DWIMIFY-PACKAGE-1 to work right. (and (null rest) (consp specializer-names) (or (sys:typep-structure-or-flavor gname 'generic-function) (sys:validate-function-spec gname)) (every #'(lambda (x) (or (symbolp x) (sys:classp x) (individual-typep x))) (the list specializer-names))) (let ((gfunc (if (sys:typep-structure-or-flavor gname 'generic-function) gname (let ((def (sys:fdefinition-safe gname t))) (and def (generic-function-p def) (get-generic-function-object def))))) (specializers (ignore-errors (mapcar #'canonicalize-class-spec specializer-names)))) (cond ((eq function 'sys:dwimify) (catch 'sys:dwimify-package (flet ((try-method-spec (new-spec) ;; Ask the user if this is OK; throws to 'sys:dwimify-package if yes. (sys:dwimify-package-2 new-spec nil arg1 arg2 t) )) (let* ((fname (if gfunc gname (sys:dwimify-package gname 'generic-function-p))) (class-names (mapcar #'(lambda (name) (if (or (sys:classp name) (individual-typep name)) name (sys:dwimify-package name 'find-class))) (let ((n (length (generic-function-argument-precedence-order (get-generic-function-object fname))))) (cond ((< n (length specializer-names)) (firstn n specializer-names)) ((> n (length specializer-names)) (append specializer-names (make-list (- n (length specializer-names)) :initial-element 't))) (t specializer-names)))))) (declare (list class-names)) (try-method-spec `(method ,fname ,@qualifiers ,class-names)) (when qualifiers (try-method-spec `(method ,fname ,class-names))) (let ((combination (clos:generic-function-method-combination gfunc))) (unless (equal combination '(standard)) (try-method-spec `(method ,fname ,(first combination) ,class-names)))) (try-method-spec `(method ,fname :around ,class-names)) (try-method-spec `(method ,fname :before ,class-names)) (try-method-spec `(method ,fname :after ,class-names)) (dolist (class-name class-names) (dolist (super (if (consp class-name) (and (individual-typep class-name) (class-precedence-list (class-of (second class-name)))) (cdr (class-precedence-list (class-named class-name))))) (try-method-spec `(method ,fname ,(substitute (class-name super) class-name class-names :count 1 :test #'eq))))) (multiple-value-bind (handlerp defn) (fdefinedp `(handler ,fname ,class-names)) (when handlerp (try-method-spec (function-name defn)))) nil)))) ; end of dwimify ((not (and gfunc specializers)) (cond ((eq function 'sys:fdefinedp) nil) ((eq function 'sys:compiler-fdefinedp) nil) ; BAF 2/6/90 ((eq function 'get) arg2) ((null gfunc) (ferror 'sys:invalid-function-spec "The generic function ~s is not defined." (second function-spec))) (t (when (consp specializer-names) (dolist (name specializer-names) (when (and (symbolp name) (not (class-named name t))) (ferror 'sys:invalid-function-spec "Undefined class ~S in function spec ~S." name function-spec)))) (ferror 'sys:invalid-function-spec "Invalid qualifier or specializer syntax in function spec ~S" function-spec)))) ((eq function 'sys:fdefine) (let ((ds (si:get-debug-info-struct arg1))) ; BAF 3/15/90 (unless (null ds) (setf (si:get-debug-info-field ds :name) (copy-tree function-spec)) )) ; BAF 3/20/90 (add-method gfunc (make-method qualifiers specializers arg1 ;; Note: we need the original DEFMETHOD lambda-list which ;; was stored by PARSE-METHOD in the :DESCRIPTIVE-ARGLIST ;; field of the debug info, not the real arglist of the FEF. (arglist arg1 nil))) function-spec) (t (let ((meth-spec (get-method-spec-object gfunc qualifiers specializers (and (member function '( sys:fdefinition-location putprop sys:push-property) :test #'eq) function-spec) (member function '(sys:fdefinedp get sys:function-parent) :test #'eq )))) (case function (sys:fdefinedp (and meth-spec (let ((def (method-spec-object-function meth-spec))) (and def (values t def))))) (sys:fdefinition (or (method-spec-object-function meth-spec) (ferror 'sys:invalid-function-spec "The method ~s is not defined." function-spec))) (sys:fdefinition-location (locf (method-spec-object-function meth-spec))) (get (if (null meth-spec) arg2 (getf (method-spec-object-plist meth-spec) arg1 arg2))) (putprop (let ((default-cons-area sys:background-cons-area)) (setf (getf (method-spec-object-plist meth-spec) arg2) arg1))) (sys:push-property (let ((default-cons-area sys:background-cons-area)) (push arg1 (getf (method-spec-object-plist meth-spec) arg2)))) (sys:fundefine (remove-method gfunc (method-spec-object-method meth-spec))) (otherwise (sys:function-spec-default-handler function function-spec arg1 arg2)))))))))) ))