; Tasteful Flavors -*- cold-load:t; Mode: common-Lisp; Package: SI; Base:8-*- ;;; 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 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved. ;;Change history: ;; 07/01/88 clm for BJ - Allow integers for subtypes in FLAVOR-METHOD-ENTRY. ;; 12/13/88 clm - Fixed PERFORM-FLAVOR-REDEFINITION so that the flavor's flavor-depended-on-by ;; information would not be lost. (spr 8982) ;; 3/16/89 DNG - Included changes to COMPILATION-FLAVOR and ;; COMPILATION-DEFINE-FLAVOR for CLOS. Removed code for #-Elroy. ;; 3/18/89 DNG - Integrated patches from "CLOS;FLAVOR-METACLASS". ;; 4/10/89 JLM - modified delete mle to setf the magic-list-entry. This is safer. ;; 4/11/89 JLM - changed usage of (PUTPROP ... to (SETF (GET ... ; A flavor-name is a symbol which names a type of objects defined ; by the combination of several flavors. The SI:FLAVOR ; property is a data-structure (of type FLAVOR) defining the ; nature of the flavor, as defined below. ; Flavors come in essentially three kinds. The first kind defines a class ; of flavors, and provides the basic instance variables and methods for ; that class. This kind typically includes only VANILLA-FLAVOR as a ; component, and uses the :REQUIRED-INSTANCE-VARIABLES and ; :REQUIRED-METHODS options. The second kind of flavor represents a ; particular option that may be combined in (a "mix-in"). The third ; kind of flavor is the kind that can usefully be instantiated; it is ; a combination of one of the first kind and several of the second kind, ; to achieve the behavior desired for a particular application. ; The following symbols are interesting to outsiders: ; DEFFLAVOR - macro for defining a flavor ; DEFMETHOD - macro for defining a method ; DEFWRAPPER - macro for defining a flavor-wrapper ; INSTANTIATE-FLAVOR - create an object of a specified flavor ; MAKE-INSTANCE - easier to call version of INSTANTIATE-FLAVOR ; COMPILE-FLAVOR-METHODS - macro which does the right thing in the compiler ; RECOMPILE-FLAVOR - function to recompile a flavor and maybe any flavors ; that depend on it. Usually this happens automatically. ; DECLARE-FLAVOR-INSTANCE-VARIABLES - macro to put around a function ; that will be called by methods and wants to access instance ; variables. ; FUNCALL-SELF - a macro which, assuming you are a flavor instance, will ; call yourself without bothering about rebinding the ; variables. Will do something totally random if SELF ; isn't a flavor instance. ; LEXPR-FUNCALL-SELF - LEXPR-FUNCALL version of above ; *ALL-FLAVOR-NAMES* - list of all symbols which have been used as the name of a flavor ; *ALL-FLAVOR-NAMES-AARRAY* - completion aarray of flavor names to flavors. ; Each flavor is included twice, once with and once without its package prefix. ; *FLAVOR-COMPILATIONS* - list of all methods which had to be compiled ; this is useful for finding flavors which weren't compiled in qfasl files ; or which need to be recompiled to bring them up to date. ; *FLAVOR-COMPILE-TRACE* - if non-NIL, a FORMAT destination for messages about ; recompilation of combined methods ; *USE-OLD-FLAVOR-INFO* - if NIL, re-DEFFLAVORing a flavor always makes a new one. ; For debugging weird screws. ; Also makes it possible to redefine a flavor and leave old ; instances with the old methods, even if the flavor instance variables ; are not being changed. ; FLAVOR-ALLOWS-INIT-KEYWORD-P - determine whether a certain flavor allows ; a certain keyword in its init-plist. ; FLAVOR-ALLOWED-INIT-KEYWORDS - returns all the init keywords a flavor handles. ; Roads not taken: ; o Changing the size of all extant instances of a flavor. ; o Nothing to stop you from instantiating a flavor of the first or ; second kind. In practice you will usually get an error if you try it. ; Philosophy with respect to multiple processes ; Interrupts are inhibited such that multiple processes munging unrelated ; flavors should work. Multiple processes instantiating related flavors ; will work, however multiple processes defining methods for the same ; flavor at the same time, and things like that, will not. (setf (documentation 'self 'variable) "When a message is sent to a flavor instance, this special variable is automatically bound to that object.") (defvar *integrate-combined-methods* () "When compiling a combined method, should the component methods be expanded inline?") ;;; Phd 10/4/85 add this new flag to allow more that 120 settable instance variables. (defvar *flavor-enable-case-set-methods* t "Enable generation of :case :set methods on settable instance variables") ; This macro is used to define a flavor. Use DEFMETHOD to define ; methods (responses to messages sent to an instance of a flavor. (defmacro defflavor (name instance-variables component-flavors &rest options) "INSTANCE-VARIABLES can be symbols, or lists of symbol and initialization. COMPONENT-FLAVORS are searched from left to right for methods, and contribute their instance variables. OPTIONS are: (:GETTABLE-INSTANCE-VARIABLES v1 v2...) (:SETTABLE-INSTANCE-VARIABLES v1 v2...) (:REQUIRED-INSTANCE-VARIABLES v1 v2...) (:REQUIRED-METHODS m1 m2...) (:REQUIRED-FLAVORS f1 f2...) (:INITTABLE-INSTANCE-VARIABLES v1 v2...) (:INIT-KEYWORDS k1 k2...) (:DEFAULT-INIT-PLIST k1 v1 k2 v2...) (:DEFAULT-HANDLER function) (:INCLUDED-FLAVORS f1 f2...) :NO-VANILLA-FLAVOR (:ORDERED-INSTANCE-VARIABLES v1 v2...) (:OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES v1 v2...) (:ACCESSOR-PREFIX sym) (:METHOD-ORDER m1 m2...) (:METHOD-COMBINATION (type order operation1 operation2...)...) (:DOCUMENTATION ...) (:SPECIAL-INSTANCE-VARIABLES ) :ABSTRACT-FLAVOR :ALIAS-FLAVOR" ;There may be more. (let ((copied-options (copy-list options))) `(progn (eval-when (load eval) (defflavor2 ',name ',instance-variables ',component-flavors ',copied-options)) (eval-when (compile) (if (just-compiling) (let ((*just-compiling* t)) (defflavor2 ',name ',instance-variables ',component-flavors ',copied-options) (compose-automatic-methods (compilation-flavor ',name))) (compose-automatic-methods (get ',name 'flavor)))) (eval-when (eval) (compose-automatic-methods (get ',name 'flavor))) (eval-when (load eval) ,@(do ((vs (do ((opts options (cdr opts))) ((null opts) nil) (and (consp (car opts)) (eq (caar opts) :outside-accessible-instance-variables) (return (cdar opts))) (and (eq (car opts) :outside-accessible-instance-variables) (return (mapcar #'(lambda (x) (if (atom x) x (car x))) instance-variables)))) (cdr vs)) (prefix (or (cadr (assq-careful :accessor-prefix options)) (string-append name "-"))) (ords (do ((opts options (cdr opts))) ((null opts) nil) (and (consp (car opts)) (eq (caar opts) :ordered-instance-variables) (return (cdar opts))) (and (eq (car opts) :ordered-instance-variables) (return (mapcar #'(lambda (x) (if (atom x) x (car x))) instance-variables))))) (res nil (cons `(defsubst ,(intern1 (string-append prefix (car vs))) (,name) (declare (function-parent ,name)) ,(if (member (car vs) ords :test #'eq) `(%instance-ref ,name ,(1+ (position (car vs) (the list ords) :test #'eq))) `(symeval-in-instance ,name ',(car vs)))) res))) ((null vs) res))) ,@(make-run-time-alternative-defflavors name (or (cdr (assq-careful :run-time-alternatives options)) (cdr (assq-careful :mixture options)))) ',name))) (defprop defflavor2 t qfasl-dont-record) (defun defflavor2 (name instance-variables component-flavors copied-options) (cond ((and (variable-boundp file-warnings-datum) file-warnings-datum) (object-operation-with-warnings (name) (compiler:warn-on-errors ('flavor-definition-error "Error in flavor definition") (defflavor1 name instance-variables component-flavors copied-options)))) (t (defflavor1 name instance-variables component-flavors copied-options)))) (defun undefflavor (flavor-name &aux fl) "Make the flavor named FLAVOR-NAME cease to be defined." (check-arg flavor-name (typep (setq fl (if (symbolp flavor-name) (get flavor-name 'flavor) flavor-name)) 'flavor) "a flavor or the name of one") (dolist (dependent (flavor-depended-on-by fl)) (push (cons (flavor-name fl) dependent) *flavor-pending-depends*)) (perform-flavor-redefinition (flavor-name fl) t) (remprop (flavor-name fl) 'flavor)) ; This wraps a local-declare special of the instance variables around its body. ; It's good for things like defining functions that deal with a flavor but ; are not methods (generally they are called by methods.) (defmacro zlc:declare-flavor-instance-variables ((flavor-name map-set-by-caller) &body body) "Enable the BODY to access instance variables of SELF, being an instance of FLAVOR-NAME. The instance variables of SELF are made accessible under the assumption that, when this code is executed, SELF's flavor will include FLAVOR-NAME as a component flavor. This macro may go around expressions in a function, or around entire function definitions. In the latter case, it is equivalent to writing (DECLARE (:SELF-FLAVOR flavor-name)) inside the functions." (let ((flavor-declaration (if (eq flavor-name 'vanilla-flavor) '(:self-flavor vanilla-flavor nil) (let ((*just-compiling* (just-compiling))) (flavor-declaration flavor-name)))) decls) (or map-set-by-caller (setq body (list `(with-self-accessible ,flavor-name ,@body)))) (if flavor-declaration (push flavor-declaration decls)) `(local-declare ,decls (compiler-let ((self-flavor-declaration ',(cdr flavor-declaration))) ,@body)))) ;Interpreted definition. Only works compiled. (defun with-self-variables-bound (&rest body) "Execute the body with all instance variables of SELF bound as specials. This means that the body can use SYMEVAL, BOUNDP, etc. on them." (with-self-variables-bound (apply 'progn body))) ;This produces a list suitable for %USING-BINDING-INSTANCES. ;It provides run-time support for the compiled code for WITH-SELF-VARIABLES-BOUND. (defun self-binding-instances () (and (typep self 'instance) (do ((index 1 (1+ index)) (ivars (flavor-all-instance-variables (instance-flavor self)) (cdr ivars)) (bindings) (normal-bindings-left (flavor-bindings (instance-flavor self))) (next-normal-binding)) ((null ivars) bindings) ;; Figure out whether the next ivar is bound as special by message sending. (or (and (numberp next-normal-binding) (plusp next-normal-binding)) (setq next-normal-binding (pop normal-bindings-left))) (if (numberp next-normal-binding) (decf next-normal-binding)) ;; If it isn't, we must put it on our binding list to be bound now. (or (locativep next-normal-binding) (setq bindings (list* (locf (symbol-value (car ivars))) (%instance-loc self index) bindings)))))) ;Interpreted definition, which binds all instance variables as specials. (defun with-self-accessible ("e flavor-name &rest body) flavor-name (with-self-variables-bound (apply 'progn body))) ;; These two for compatibility with the new Symbolics system. (defmacro defun-method (fspec flavor-name arglist &body body) `(defun ,fspec ,arglist (declare (:self-flavor ,flavor-name)) ,@body)) (defmacro instance-variable-boundp (x) `(boundp ',x)) (defmacro defwhopper ((flavor-name operation) arglist &body body) "sugar coating of : `(defmethod (,flavor-name :around ,operation) (.continuation. .mapping-table. .around-args. ,@arglist) ,@body), used for other LISP MACHINES compatibility" `(defmethod (,flavor-name :around ,operation) (.continuation. .mapping-table. .around-args. ,@arglist) ,@body)) (defmacro continue-whopper (&rest arguments) `(funcall-with-mapping-table .continuation. .mapping-table. (car .around-args.) ,@arguments)) (defmacro lexpr-continue-whopper (&rest arguments) `(lexpr-funcall-with-mapping-table .continuation. .mapping-table. (car .around-args.) ,@arguments)) (defvar *all-flavor-names* ()) ;List of names of all flavors (mostly for editor) (defvar *all-flavor-names-aarray*;For editor's completing reader (make-array 2400;736 flavors in system 75 :type 'art-q-list :leader-list '(0 nil))) (defun sort-aarray (aarray) (cond ((not (array-leader aarray 1)) ;If not sorted right now (sort aarray #'string-lessp :key #'car) (setf (array-leader aarray 1) t)))) ;(add-initialization "Condense Flavor Name Tables" ; '(progn ; (sort-aarray *all-flavor-names-aarray*) ; (if (= (%p-cdr-code *all-flavor-names*) cdr-normal) ; (setq *all-flavor-names* (copylist *all-flavor-names*)))) ; '(:before-cold)) ;Don't let these get left bound losingly after a warm boot. (add-initialization "Reinit possibly bound flavor globals" '(setq *use-old-combined-methods* t *just-compiling* ()) '(:warm)) (defvar *use-old-flavor-info* t) ;T means DEFFLAVOR1 only "unhooks" if the flavor ;has changed incompatibly, NIL means always unhook ;if flavor already existed. (defvar *use-old-combined-methods* t) ;T means recycle old, NIL means generate new. ; This is an implicit argument to certain routines. (defvar *flavor-pending-depends* ()) ;Used by DEFFLAVOR1 (defvar *flavor-compilations* ()) ;List of methods compiled (defvar *flavor-compile-trace* ()) (defvar *just-compiling* ()) ;T means putting combined methods into qfasl file, ; not updating the current flavor data-structure ;T if we are inside a compilation going to a binary file. ;We do not simply call this function wherever we want to check, ;but instead bind *JUST-COMPILING* at various points ;and check that. The reason is that those points are all ;inside (EVAL-WHEN (COMPILE) ..)'s; as a result, any flavor ;hacking done randomly inside the compiler's execution ;finds *JUST-COMPILING* is NIL, as it should. (defun just-compiling () (and (boundp 'compiler::qc-file-in-progress) compiler::qc-file-in-progress (not compiler::qc-file-load-flag))) ;This is an area in which to cons data internal to the flavor system. It is used ;rather than default-cons-area as a hedge against temporary area lossage which can ;happen if you do things from an error in a compilation, or if you make instances ;in a temporary area and that requires composing flavors or methods. ; These two functions are used when sending a message to yourself, for extra efficiency. (defmacro zlc:funcall-self (&rest args) "Like FUNCALL of SELF, but a little faster," `(funcall self ,@args)) (defmacro zlc:lexpr-funcall-self (&rest args) "Like LEXPR-FUNCALL of SELF, but a little faster." `(apply self ,@args)) (defsubst instance-flavor (instance) "Returns the flavor-object of a given flavor instance." (%make-pointer dtp-array-pointer (%p-contents-as-locative-offset instance 0))) (defsubst instance-function (instance) "Returns the handler-function of the flavor of INSTANCE." (%p-contents-offset (%p-contents-as-locative-offset instance 0) %instance-descriptor-function)) ;When compiling files, we make a new flavor object for each flavor ;defined in the file. That way we win if the definition in the file ;does not match the one loaded. These flavors live in a FILE-LOCAL-DECLARATION ;element which looks like (FLAVORS name flavor name flavor ...) ;This function, given a flavor name or flavor object, ;gives the right flavor object to use. If compiling a file, ;it uses the compilation flavor if any; otherwise, it uses the installed flavor. (defun compilation-flavor (flavor-or-name &optional (use-compilation-flavors *just-compiling*)) "Returns the appropriate flavor object for the specified flavor. If compiling, it returns the compilation-time flavor object corresponding to the specified flavor or flavor name. If not compiling, returns the actual installed flavor object. USE-COMPILATION-FLAVORS specifies whether to assume we are compiling or not; it defaults to the truth." ;; 11/11/88 DNG - use GET-FROM-ENVIRONMENT instead of FILE-LOCAL-DECLARATIONS. ;; 11/23/88 DNG - modified to avoid calling GET twice; use GET-FLAVOR. (if (and use-compilation-flavors compiler:*compile-file-environment*) (or (get-flavor (if (symbolp flavor-or-name) flavor-or-name (flavor-name flavor-or-name)) compiler:*compile-file-environment*) (and (not (symbolp flavor-or-name)) flavor-or-name)) (if (symbolp flavor-or-name) (get flavor-or-name 'flavor) flavor-or-name))) ;These properties are not discarded by redoing a DEFFLAVOR. (defparameter defflavor1-preserved-properties '(additional-instance-variables all-instance-variables-special compile-flavor-methods unmapped-instance-variables mapped-component-flavors instance-variable-initializations all-special-instance-variables all-inittable-instance-variables remaining-default-plist remaining-init-keywords required-init-keywords instance-area-function :obsolete-flavor ;; the following added 2/28/89 by DNG ticlos::mapped-slot-names ticlos::class-mapped-supers ticlos::class-mapping-tables )) ;A little slower, but eliminates compile-time dependency on details of flavor defstruct. (defun flavor-all-instance-variables-slow (flavor) (flavor-all-instance-variables flavor)) (defsubst flavor-gettable-instance-variables (flavor) (getf (flavor-plist flavor) :gettable-instance-variables)) (defsubst flavor-settable-instance-variables (flavor) (getf (flavor-plist flavor) :settable-instance-variables)) (defsubst flavor-special-instance-variables (flavor) (getf (flavor-plist flavor) :special-instance-variables)) (defsubst flavor-all-instance-variables-special (flavor) "T if all instance variables of FLAVOR must be special due to old compiled methods." (getf (flavor-plist flavor) 'all-instance-variables-special)) (defsubst flavor-all-special-instance-variables (flavor) "Return a list of all the special instance variables of FLAVOR (a flavor object)." (getf (flavor-plist flavor) 'all-special-instance-variables)) ;These are instance variables that don't belong to this flavor or its components ;but can be accessed by methods of this flavor. (defsubst flavor-additional-instance-variables (flavor) (getf (flavor-plist flavor) 'additional-instance-variables)) ;The next four are distillations of info taken from this flavor and its components, ;used for instantiating this flavor. See COMPOSE-FLAVOR-INITIALIZATIONS. (defsubst flavor-instance-variable-initializations (flavor) (getf (flavor-plist flavor) 'instance-variable-initializations)) (defsubst flavor-remaining-default-plist (flavor) (getf (flavor-plist flavor) 'remaining-default-plist)) (defsubst flavor-remaining-init-keywords (flavor) (getf (flavor-plist flavor) 'remaining-init-keywords)) (defsubst flavor-all-inittable-instance-variables (flavor) (getf (flavor-plist flavor) 'all-inittable-instance-variables)) ;This is a vector in which the mapping table locations in the alist point. (defsubst flavor-component-mapping-table-vector (flavor) (getf (flavor-plist flavor) 'component-mapping-table-vector)) ;This is a list of flavors we depend on whose methods are referred ;to by our combined methods. (defsubst flavor-mapped-component-flavors (flavor) (getf (flavor-plist flavor) 'mapped-component-flavors)) ;This is a list of instance variables which are ordered ;because of an :ORDERED-INSTANCE-VARIABLES declaration in some flavor we depend on. ;They do not need to be mapped in mapping tables. (defsubst flavor-unmapped-instance-variables (flavor) (getf (flavor-plist flavor) 'unmapped-instance-variables)) (defsubst flavor-unhandled-init-keywords (flavor) (getf (flavor-plist flavor) 'unhandled-init-keywords)) ;Called by open-compiled TYPEP if second arg is a flavor name. (defun typep-flavor (x type &aux fl) (cond ((and (= (%data-type x) dtp-instance) (= (%p-data-type (setq fl (%p-contents-as-locative-offset x 0))) dtp-array-header) (eq (aref (setq fl (%make-pointer dtp-array-pointer fl)) 0) 'flavor)) (not (null (member type (flavor-depends-on-all fl) :test #'eq)))) ((get type 'flavor) nil) (t (typep x type)))) ;Optimization turned out to be wrong (defun linearize-flavor-plists () "Recopy all flavor plists (and other things) so that they are linear and compact." (dolist (name *all-flavor-names*) (let ((fl (get name 'flavor))) (unless (symbolp (flavor-method-hash-table fl)) ;; Cause rehash now if necessary. (gethash () (flavor-method-hash-table fl))) (let ((default-cons-area flavor-data-area)) (unless (= (%area-number (flavor-bindings fl)) flavor-data-area) (setf (flavor-bindings fl) (copy-list (flavor-bindings fl)))) (unless (= (%area-number (flavor-component-mapping-table-alist fl)) flavor-data-area) (setf (flavor-component-mapping-table-alist fl) (copy-alist (flavor-component-mapping-table-alist fl)))) (unless (= (%area-number (flavor-all-instance-variables fl)) flavor-data-area) (setf (flavor-all-instance-variables fl) (copy-list (flavor-all-instance-variables fl)))) (unless (= (%area-number (flavor-mapped-instance-variables fl)) flavor-data-area) (setf (flavor-mapped-instance-variables fl) (copy-list (flavor-mapped-instance-variables fl)))) (unless (= (%area-number (flavor-plist fl)) flavor-data-area) (setf (flavor-plist fl) (copy-tree (flavor-plist fl))))) ;; In any case force transport of all these lists to newspace now. (nsubst '(nil) '(nil) (flavor-bindings fl)) (nsubst '(nil) '(nil) (flavor-component-mapping-table-alist fl)) (nsubst '(nil) '(nil) (flavor-all-instance-variables fl)) (nsubst '(nil) '(nil) (flavor-mapped-instance-variables fl)) (nsubst '(nil) '(nil) (flavor-plist fl))))) ;;;(add-initialization "Linearize flavor plists" '(linearize-flavor-plists) '(:after-full-gc)) ;Format of flavor-method-table: ; New format of a flavor-method-table entry is: ; (message combination-type combination-order meth...) ; A meth is: ; (function-spec definition plist) ; Thus the second element of a meth is actually a function-cell. ; The meth's are stored in permanent-storage-area so that they will be compact. ; [That might not be the best area, the select-methods, and component ; lists, and instanc-variable lists, and which-operations's, are also there.] ; A magic-list entry is: ; (message combination-type combination-order (method-type function-spec...)...) ; In the magic-list, there can be more than one method listed under a method-type, ; the base flavor always comes first. The :COMBINED methods are elided from ; the magic-list. ; ; Special method-types: ; NIL - no type specified ; :DEFAULT - like NIL but only taken if there are no type-NIL methods ; :WRAPPER - wrappers are remembered this way ; :COMBINED - a combined method; it has a debug info entry ; (COMBINED-METHOD-DERIVATION derivation) or else the function spec ; has a property COMBINED-METHOD-DERIVATION whose value is the derivation. ; The derivation is the magic list entry used to make the combined method. ; The CDDDR is canonicalized; each contained list of method symbols is ; of course ordered by the order in which flavors are combined (base ; flavor first). Canonical order is alphabetical by method-type. ; Non-special method-types: ; :BEFORE, :AFTER - these are used by the default combination-type, :DAEMON ; ; Special hair for wrappers: changing a wrapper can invalidate the combined method ; without changing anything in the flavor-method-table entry. Rather than having ; it automatically recompile, which turns out to be a pain when the wrapper was ; just reloaded or changed trivially, it will fail to recompile and you must use ; RECOMPILE-FLAVOR with a 3rd argument of NIL. ; ; A combination-type of NIL means it has not been explicitly specified. ; Method-combination functions. Found on the SI:METHOD-COMBINATION property ; of the combination-type. These are passed the flavor structure, and the ; magic-list entry, and must return the function spec to use as the handler. ; It should also define or compile thew definition for that function spec if nec. ; This function interprets combination-type-arg, ; which for many combination-types is either :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST. ;This is an a-list from method type to function to write the code to go ;in the combined method. Users can add to this. ;These types of method are added to the combined method ;in the order they are listed here. ;So if one flavor defines a wrapper and an :around method, ;the wrapper goes outside. (defparameter *specially-combined-method-types* '((:around put-around-method-into-combined-method) (:wrapper put-wrapper-into-combined-method))) ;These specially combined method types go in with base flavor outermost. (defparameter *inverse-specially-combined-method-types* '((:inverse-around put-around-method-into-combined-method) (:inverse-wrapper put-wrapper-into-combined-method))) ;Definitions of a meth (the datum which stands for a method) (defstruct (meth (:type :list) (:constructor nil) (:alterant nil) (:conc-name "METH-") (:callable-constructors nil) (:predicate nil) (:copier nil));No constructor because defstruct doesn't let me specify the area function-spec definition (plist ())) ; If there is no definition, it contains DTP-NULL and a pointer to the meth ; Extract the method-type of a meth (defsubst meth-method-type (meth) (and (cdddr (meth-function-spec meth)) (third (meth-function-spec meth)))) (defsubst meth-method-subtype (meth) (fifth (meth-function-spec meth))) ; Return a meth of specified type from a list of meth's. (defun meth-lookup (meth-list method-type &optional method-subtype) (loop for meth in meth-list when (and (eq (meth-method-type meth) method-type) (or (not method-subtype) (eq (meth-method-subtype meth) method-subtype))) return meth)) (defun nullify-method-definition (meth) (let ((p (locf (meth-definition meth)))) (without-interrupts ;; TGC (%p-store-pointer p meth) (%p-store-data-type p dtp-null) (%p-store-data-type-and-pointer p dtp-null meth)))) (defun meth-definedp (meth) (and (location-boundp (locf (meth-definition meth))) (neq (meth-definition meth) 'undefinition-in-progress))) (defun method-plist (function-spec);For debugging ease only (meth-plist (flavor-method-entry function-spec t))) ;; Obsolete flavor feature, will warn user during compilation if he includes (in any way) ;; a flavor marked as obsolete. (DEFVAR ENABLE-OBSOLETE-FLAVOR-CHECK T "Used to turn off the obsolete flavor checking when one doesn't care to see it.") (defun check-obsolete-flavors (flavor-list option-category &aux fl) "Check the list to see if there are any flavors there which are designated as being obsolete. FLAVOR-LIST is a list of flavors to check. OPTION-CATEGORY is a string that indicates what kind of option is being checked." ;; Check only when we compile, not at load time or runtime. (when (and compiler::qc-file-in-progress compiler::qcompile-temporary-area enable-obsolete-flavor-check) (dolist (flavor flavor-list) (when (and (setf fl (compilation-flavor flavor)) (getf (flavor-plist fl) :obsolete-flavor)) (flavor-warn flavor () :obsolete "the ~A flavor ~:S is obsolete, ~A." option-category flavor (getf (flavor-plist fl) :obsolete-flavor)))))) (defun compiler::make-obsolete-flavor (flavor reason) "Mark a flavor as being obsolete." (setf (getf (flavor-plist (compilation-flavor flavor)) :obsolete-flavor) reason)) (defprop defflavor "Flavor" definition-type-name) ;Function to define or redefine a flavor (used by DEFFLAVOR macro). ;Note that to ease initialization problems, the flavors depended upon need ;not be defined yet. You will get an error the first time you try to create ;an instance of this flavor if a flavor it depends on is still undefined. ;When redefining a flavor, we reuse the same FLAVOR defstruct so that ;old instances continue to get the latest methods, unless you change ;something incompatibly, in which case you will get a warning. (defprop defflavor1 t qfasl-dont-record) ;; 3/18/89 DNG - Updated for integration with CLOS. Use new function FLAVOR-DEFINITION-PACKAGE. ;; 3/23/89 DNG - Fix to not try to make a FLAVOR-CLASS instance too soon in the build. (defun defflavor1 (flavor-name instance-variables component-flavors options &aux ffl already-exists instv identical-components gettable settable inittable special-ivs old-special-ivs old-default-handler old-default-init-plist old-local-ivs old-inittable-ivs old-init-kwds old-instance-area-function old-required-init-keywords init-keywords includes meth-comb new-plist (pl (locf new-plist)) (default-cons-area (if *just-compiling* default-cons-area *flavor-area*))) (unless (or *just-compiling* (record-source-file-name flavor-name 'defflavor)) (return-from defflavor1 nil)) (without-interrupts (cond ((and (not *just-compiling*) (not (member flavor-name *all-flavor-names* :test #'eq))) (push flavor-name *all-flavor-names*) ;; Push on the name without the package prefix. (vector-push-extend (cons (symbol-name flavor-name) flavor-name) *all-flavor-names-aarray*) ;; Push on the name with the package prefix. (vector-push-extend (cons (string-append (package-name *package*) ":" (symbol-name flavor-name)) flavor-name) *all-flavor-names-aarray*) ;; Array is no longer sorted. (store-array-leader () *all-flavor-names-aarray* 1)))) ;; Analyze and error check the instance-variable and component-flavor lists (setq instv (mapcar #'(lambda (x) (if (atom x) x (car x))) instance-variables)) (dolist (iv instv) (if (or (null iv) (not (symbolp iv))) (ferror () "~:S, which is not a symbol, was specified as an instance variable" iv))) (dolist (cf component-flavors) (if (or (null cf) (not (symbolp cf))) (ferror () "~:S, which is not a symbol, was specified as a component flavor" cf))) ;;Check for obsolete component flavors here (check-obsolete-flavors component-flavors "component") ;; Certain properties are inherited from the old property list, while ;; others are generated afresh each time from the defflavor-options. (cond ((and (setq already-exists (compilation-flavor flavor-name)) *use-old-flavor-info*) (dolist (prop defflavor1-preserved-properties) (setf (get pl prop) (getf (flavor-plist already-exists) prop))))) ;; First, parse all the defflavor options into local variables so we can see ;; whether the flavor is being redefined incompatibly. (do ((l options (cdr l)) (option) (args)) ((null l)) (if (atom (car l)) (setq option (car l) args ()) (setq option (caar l) args (cdar l))) (case option (:gettable-instance-variables (validate-instance-variables-spec args instv flavor-name option) (setq gettable (union gettable (or args instv) :test #'eq))) (:settable-instance-variables (validate-instance-variables-spec args instv flavor-name option) (setq settable (union settable (or args instv) :test #'eq))) ((:inittable-instance-variables :initable-instance-variables) (validate-instance-variables-spec args instv flavor-name option) (setq inittable (union inittable (or args instv) :test #'eq))) (:special-instance-variables (validate-instance-variables-spec args instv flavor-name option) (setq special-ivs (union special-ivs (or args instv) :test #'eq))) (:init-keywords (setq init-keywords (union init-keywords args :test #'eq))) (:included-flavors (setq includes (union includes args :test #'eq)) (check-obsolete-flavors args "included")) (:no-vanilla-flavor (setf (get pl option) t)) (:ordered-instance-variables ;;Don't validate. User may reasonably want to specify non-local instance ;;variables, and any bogus names here will get detected by COMPOSE-FLAVOR-COMBINATION ;;(VALIDATE-INSTANCE-VARIABLES-SPEC ARGS INSTV FLAVOR-NAME OPTION) (setf (get pl :ordered-instance-variables) (or args instv))) (:outside-accessible-instance-variables (validate-instance-variables-spec args instv flavor-name option) (setf (get pl :outside-accessible-instance-variables) (union (get pl :outside-accessible-instance-variables) (or args instv) :test #'eq))) (:method-combination (setq meth-comb (nunion meth-comb args :test #'equal) )) (:default-handler (setf (get pl option) (car args))) ((:required-instance-variables :required-methods :required-flavors :required-init-keywords) (setf (get pl option) (union args (get pl option) :test #'eq)) (when (eq option :required-flavors) (check-obsolete-flavors (get pl ':required-flavors) "required"))) ((:documentation :default-init-plist :select-method-order :accessor-prefix) (setf (get pl option) args)) (:alias-flavor (setf (get pl :alias-flavor) t)) (:abstract-flavor (setf (get pl :abstract-flavor) t)) (:instance-area-function (setf (get pl :instance-area-function) (car args))) (:instantiation-flavor-function (setf (get pl :instantiation-flavor-function) (car args))) ((:run-time-alternatives :mixture) (setf (get pl :run-time-alternatives) args) (setf (get pl :instantiation-flavor-function) 'choose-run-time-alternative) (setf (get pl 'run-time-alternative-alist) (make-run-time-alternative-alist flavor-name args))) (otherwise (ferror () "~S is not a known DEFFLAVOR option." option)))) ;; All settable instance variables should also be gettable and inittable. (dolist (v settable) (or (member v gettable :test #'eq) (push v gettable)) (or (member v inittable :test #'eq) (push v inittable))) ;; See whether there are any changes in component flavor structure from last time (setq identical-components (and already-exists *use-old-flavor-info* (equal component-flavors (flavor-depends-on already-exists)) (equal includes (flavor-includes already-exists)) (equal (get pl :required-flavors) (getf (flavor-plist already-exists) :required-flavors)))) (and already-exists (setq old-special-ivs (flavor-special-instance-variables already-exists) old-default-handler (getf (flavor-plist already-exists) :default-handler) old-default-init-plist (getf (flavor-plist already-exists) :default-init-plist) old-local-ivs (flavor-local-instance-variables already-exists) old-inittable-ivs (flavor-inittable-instance-variables already-exists) old-instance-area-function (flavor-get already-exists :instance-area-function) old-required-init-keywords (flavor-get already-exists :required-init-keywords) old-init-kwds (flavor-init-keywords already-exists))) ;; If the flavor is being redefined, and the number or order of instance$variables ;; is being changed, and this flavor or any that depends on it ;; has a select-method table (i.e. has probably been instantiated), give a warning ;; and disconnect from the old FLAVOR defstruct so that old instances will ;; retain the old information. The instance variables can get changed either ;; locally or by rearrangement of the component flavors. (and already-exists (if (and *use-old-flavor-info* (equal (get pl :ordered-instance-variables) (getf (flavor-plist already-exists) :ordered-instance-variables)) (or (equal (flavor-local-instance-variables already-exists) instance-variables) (equal (mapcar #'(lambda (x) (if (atom x) x (car x))) (flavor-local-instance-variables already-exists)) instv)) (eq (get pl :alias-flavor) (flavor-get already-exists :alias-flavor)) (or identical-components (equal (flavor-relevant-components already-exists component-flavors includes) (flavor-relevant-components already-exists (flavor-depends-on already-exists) (flavor-includes already-exists))))) (if *just-compiling* (setq already-exists (flavor-redefinition-for-compilation already-exists ()))) (if *just-compiling* (setq already-exists (flavor-redefinition-for-compilation already-exists t)) (setq already-exists (perform-flavor-redefinition flavor-name))))) (when (get pl :alias-flavor) (if (cdr component-flavors) (flavor-warn flavor-name 'alias-flavor-multiple-components :impossible "This alias flavor has more than one component.")) (unless component-flavors (flavor-warn flavor-name 'alias-flavor-multiple-components :impossible "This alias flavor has no component to be the alias of.")) (if instance-variables (flavor-warn flavor-name 'alias-flavor-multiple-components :impossible "This alias flavor has instance variables; they will be ignored."))) ;; Make the information structure unless the flavor already exists. (let ((fl (or already-exists (and (not *just-compiling*) (get flavor-name 'undefined-flavor)) (make-flavor flavor-name flavor-name)))) (setf (flavor-local-instance-variables fl) instance-variables) (setf (flavor-depends-on fl) component-flavors) (let ((ovec (flavor-component-mapping-table-vector fl))) (setf (flavor-plist fl) new-plist) (if ovec (setf (flavor-component-mapping-table-vector fl) ovec))) (setf (flavor-definition-package fl) *package*) (let* ((env (and *just-compiling* compiler:*compile-file-environment*)) (old (ticlos:class-named flavor-name t env))) (unless (or (and old (eq fl (ticlos:class-description old))) (not (get-flavor 'ticlos:flavor-class))) ;; clm 03/31/89 make sure it's defined (if (and old (typep-structure-or-flavor old 'ticlos:hybrid-class)) ;; These classes have separate class-description and flavor description objects. (setf (flavor-class-object fl) old) (progn (unless (or (null old) (typep-structure-or-flavor old 'ticlos:flavor-class)) (cerror "Discard the old class ~S and proceed with installation of the flavor." "Class ~S was defined as a ~S, but is being redefined as a flavor." flavor-name (type-of old))) (set-class-named flavor-name env (setf (flavor-class-object fl) (sys:make-flavor-instance 'ticlos:flavor-class :class-description fl))) )) (unless (null env) (setf (ticlos:class-description-environment fl) env)) ) ) (if gettable (setf (flavor-gettable-instance-variables fl) gettable)) (if settable (setf (flavor-settable-instance-variables fl) settable)) (if special-ivs (setf (flavor-special-instance-variables fl) special-ivs)) (setf (flavor-inittable-instance-variables fl) (loop for v in inittable collect (cons (corresponding-keyword v) v))) (setf (flavor-init-keywords fl) init-keywords) (setf (flavor-includes fl) includes) ;; This can't be computed for real until flavor composition, ;; but this at least contains some of the right ones. (setf (flavor-unmapped-instance-variables fl) (flavor-known-unmapped-instance-variables fl)) ;; First remove old method-combination declarations, then add new ones (dolist (mte (flavor-method-table fl)) (cond ((loop for decl in meth-comb never (member (car mte) (cddr decl) :test #'eq)) (setf (second mte) ()) (setf (third mte) ())))) (dolist (decl meth-comb) (let ((type (car decl)) (order (cadr decl)) elem) ;; Don't error-check TYPE now, its definition might not be loaded yet (dolist (msg (cddr decl)) (or (setq elem (assoc msg (flavor-method-table fl) :test #'eq)) (push (setq elem (list* msg () () ())) (flavor-method-table fl))) (setf (second elem) type) (setf (third elem) order)))) (if *just-compiling* (compilation-define-flavor flavor-name fl) ;; Make this a depended-on-by of its depends-on, or remember to do it later in ;; the case of depends-on's not yet defined. (progn (dolist (component-flavor component-flavors) (without-interrupts (cond ((setq ffl (get component-flavor 'flavor)) (or (member flavor-name (flavor-depended-on-by ffl) :test #'eq) (push flavor-name (flavor-depended-on-by ffl)))) (t (push (cons component-flavor flavor-name) *flavor-pending-depends*))))) (dolist (included-flavor (flavor-includes fl)) (without-interrupts (cond ((setq ffl (get included-flavor 'flavor)) (or (member flavor-name (flavor-depended-on-by ffl) :test #'eq) (push flavor-name (flavor-depended-on-by ffl)))) (t (push (cons included-flavor flavor-name) *flavor-pending-depends*))))) (without-interrupts (dolist (x *flavor-pending-depends*) (cond ((eq (car x) flavor-name) (or (member (cdr x) (flavor-depended-on-by fl) :test #'eq) (push (cdr x) (flavor-depended-on-by fl))) (setq *flavor-pending-depends* (delete x (the list *flavor-pending-depends*) :test #'eq)))))) (setf (get flavor-name 'flavor) fl) (remprop flavor-name 'undefined-flavor) (if (and already-exists (not identical-components)) (perform-flavor-method-only-redefinition flavor-name) ;; If the methods and instances are ok but other things have changed, notice that too. (or (and (equal old-special-ivs (flavor-special-instance-variables fl)) (equal old-default-init-plist (getf (flavor-plist fl) :default-init-plist)) (equal old-local-ivs (flavor-local-instance-variables fl)) ;; Get a warning every time, if there is a variable ;; that is globally special but not in a :SPECIAL-INSTANCE-VARIABLES (not (dolist (iv (flavor-local-instance-variables fl)) ;; Elements can be lists (var init) (if (consp iv) (setq iv (car iv))) (and (get iv 'special) (not (member iv (flavor-special-instance-variables fl) :test #'eq)) (return t)))) (equal old-inittable-ivs (flavor-inittable-instance-variables fl)) (equal old-default-handler (getf (flavor-plist fl) :default-handler)) (equal old-instance-area-function (flavor-get fl :instance-area-function)) (equal old-required-init-keywords (flavor-get fl :required-init-keywords)) (equal old-init-kwds (flavor-init-keywords fl))) (perform-flavor-bindings-redefinition flavor-name))) (flavor-hack-documentation flavor-name)) ;; Now, if the flavor was redefined in a way that changes the methods but doesn't ;; invalidate old instances, we have to propagate some changes. ;; If someone depends on this flavor, which wasn't defined until now, link them up. ;; If that flavor was flavor-composed, recompose it now. ;; Likewise for its includes ) flavor-name)) ;; Determine as many as we can of FL's ordered instance variables ;; at a time when FL's components need not all be defined. ;; This is used to init FL's unmapped instance variables list at defflavor time. ;; That list's final value will be computed when FL is composed. ;; This is so that methods of FL loaded before FL is composed ;; will not need to make mapping table entries for these ivars. (defun flavor-known-unmapped-instance-variables (fl) (let ((fls (append (flavor-depends-on fl) (flavor-get fl :required-flavors))) (ords (flavor-get fl :ordered-instance-variables))) (dolist (f fls) (setq f (compilation-flavor f )) (when f (let ((ord (flavor-unmapped-instance-variables f))) ;; Merge into existing order requirement. Shorter of the two must be ;; a prefix of the longer, and we take the longer. (do ((l1 ord (cdr l1)) (l2 ords (cdr l2))) (nil) (cond ((null l1) (return ())) ((null l2) (return (setq ords ord))) ((neq (car l1) (car l2)) (ferror () ":ORDERED-INSTANCE-VARIABLES conflict, ~S vs ~S." (car l1) (car l2)))))))) ords)) ;Check for typos in user-specified lists of instance variables. ;This assumes that only locally-specified (not inherited) instance variables ;may be mentioned in DEFFLAVOR declaration clauses. (defun validate-instance-variables-spec (vars-specd vars-allowed flavor-name option) (dolist (var vars-specd) (or (member var vars-allowed :test #'eq) (flavor-warn flavor-name 'nonexistent-instance-variable :impossible "~S includes instance variable ~S, which this flavor lacks." option var)))) (defun flavor-warn (flavor-name type severity format-string &rest format-args) (if object-warnings-object-name (apply 'compiler::warn type severity format-string format-args) (progn (format *error-output* "~&In the definition of flavor ~S,~%" flavor-name) (apply 'format *error-output* format-string format-args)))) ;List of those components which affect the names, number, and ordering of the ;instance variables. Don't worry about undefined components, by definition ;they must be different from the already-existing flavor, so the right ;thing will happen. (I wonder what that comment means? Undefined components ;will not even appear in the list.) (defun flavor-relevant-components (fl component-flavors included-flavors) (bind (locf (flavor-depends-on fl)) component-flavors) (bind (locf (flavor-includes fl)) included-flavors) (delete-if-not #'(lambda (flavor);Splice out the uninteresting ones (let ((tem (compilation-flavor flavor))) (or (null tem) (flavor-local-instance-variables tem)))) (compose-flavor-inclusion (flavor-name fl) ()))) (defun flavor-redefinition-for-compilation (old-flavor new-components-p) "Prepare for compile-time redefinition of a flavor. Copies the flavor, but installs the copy only for the current compilation." new-components-p (let ((new-flavor (make-flavor flavor-name (flavor-name old-flavor)))) (copy-array-contents old-flavor new-flavor) ;; Do copy any combined methods. If we have dependents also in this file ;; and they have COMPILE-FLAVOR-METHODS in this file, ;; they will want to see our combined methods in case they can use them. (copy-method-table old-flavor new-flavor ()) (setf (flavor-instance-size new-flavor) ());Defuse error check (setf (flavor-depends-on-all new-flavor) ());Will need to be flavor-composed again ;; Cause an error if these are looked at before they are valid. (setf (flavor-all-instance-variables new-flavor) 'not-computed) (setf (flavor-depended-on-by new-flavor) 'compilation) (setf (flavor-method-hash-table new-flavor) ());Will need to be method-composed again (setf (flavor-which-operations new-flavor) ()) new-flavor)) (defun copy-method-table (old-flavor new-flavor discard-combined-methods) (let ((l (copy-list (flavor-method-table old-flavor))) (meth-area (if *just-compiling* default-cons-area permanent-storage-area))) (do ((tail l (cdr tail))) ((null tail)) ;; Copy the method-table element, including the list of METH's. (setf (car tail) (copy-list (car tail))) (if discard-combined-methods ;; Flush from the copy all combined methods. (do ((tail2 (cdddr (car tail)) (cdr tail2))) ((null tail2)) (and (eq (meth-method-type (car tail2)) :combined) (setf (cdddar tail) (delete (car tail2) (the list (cdddar tail)) :test #'eq))))) ;; Now copy each METH that we didn't delete. ;; Copying a METH is not trivial because it can contain a DTP-NULL. (do ((tail2 (cdddr (car tail)) (cdr tail2))) ((null tail2)) (let ((new-meth (list-in-area meth-area (first (car tail2)) () (copy-list (third (car tail2)))))) (if (meth-definedp (car tail2)) (setf (meth-definition new-meth) (meth-definition (car tail2))) (nullify-method-definition new-meth)) (setf (car tail2) new-meth)))) (setf (flavor-method-table new-flavor) l))) ;Record a flavor definition, during compiling a file. ;Instead of setting the name's FLAVOR property, we put an entry on the ;FLAVORS element in the FILE-LOCAL-DECLARATIONS, where COMPILATION-FLAVOR looks. (defun compilation-define-flavor (flavor-name fl) ;; 11/11/88 DNG - use GET-FROM-ENVIRONMENT instead of FILE-LOCAL-DECLARATIONS. ;; 11/23/88 DNG - Use new function GET-FLAVOR (unless (null compiler:*compile-file-environment*) (setf (get-flavor flavor-name compiler:*compile-file-environment*) fl)) ) ;Call here when a flavor has been changed in a way that is not compatible ;with old instances of this flavor or its dependents. ;Arranges for those old instances to keep the old flavor structures and methods. ;Return new copy of the FLAVOR defstruct, and propagate to those that depend on it. ;Note that we tell copy-method-table to discard our combined methods. ;This is because they point to METHs in our method table, ;so we must make new combined methods that point at our new method table. ;; 12/03/87 P.H.D. and D.N.G. - modified to fix SPR 6931. ;; 11/16/88 clm for D.N.G - wrapped FOR-UNDEFFLAVOR-P around the flet so that the ;; flavor-depended-on-by field for flavor-name would not be lost. (spr 8982) ;; 11/29/88 D.N.G. - Add updating of class object when flavor changed incompatibly. ;; 4/11/89 DNG - Use FLAVOR-CLASS-OBJECT instead of TICLOS:CLASS-DESCRIPTION-CLASS-OBJECT. (defun perform-flavor-redefinition (flavor-name &optional for-undefflavor-p &aux fl nfl) (setq fl (get flavor-name 'flavor)) (cond ((flavor-method-hash-table fl) (setq nfl (make-flavor)) (copy-array-contents fl nfl) (copy-method-table fl nfl t);Copy, but discard combined methods (setq fl nfl) (setf (flavor-plist fl) (copy-list (flavor-plist fl) property-list-area)) (setf (flavor-mapped-instance-variables fl) (copy-list (flavor-mapped-instance-variables fl))) (remprop (locf (flavor-plist fl)) 'mapped-component-flavors);They are used only by the combined ;methods, which we just flushed. (setf (flavor-component-mapping-table-alist fl) ()) (setf (flavor-component-mapping-table-vector fl) ()) (setf (get flavor-name 'flavor) fl) (let* ((class (flavor-class-object fl))) (when (instancep class) (send class :set-flavor fl))) (format *error-output* (if for-undefflavor-p "~&Flavor ~S no longer instantiable; old instances are not affected.~%" "~&Flavor ~S changed incompatibly; old instances will not get the new version.~%") flavor-name)) ;; Even if this flavor wasn't instantiated, ;; probably some of its dependents were, ;; and their hash tables and combined methods point to our method table. (t (copy-method-table fl fl t))) (setf (flavor-instance-size fl) ());Defuse error check (WHEN FOR-UNDEFFLAVOR-P (flet ((update-depended-on-by (flavor-name list) (dolist (f list (values)) (let ((fs (compilation-flavor f))) (when (and fs (member flavor-name (flavor-depended-on-by fs) :test #'eq)) (setf (flavor-depended-on-by fs) (delete flavor-name (the list (flavor-depended-on-by fs)) :test #'eq))))))) (update-depended-on-by flavor-name (or (flavor-depends-on-all fl) (flavor-depends-on fl))) (update-depended-on-by flavor-name (flavor-includes fl)) )) (setf (flavor-depends-on-all fl) ());Will need to be flavor-composed again (setf (flavor-method-hash-table fl) ());Will need to be method-composed again (setf (flavor-which-operations fl) ()) (dolist (fn (flavor-depended-on-by fl)) (perform-flavor-redefinition fn for-undefflavor-p)) fl) ;This one is when the old instances don't have to be discarded, but recomposition ;does have to occur because something was changed in the order of flavor combination (defun perform-flavor-method-only-redefinition (flavor-name) ;; If we define any combined methods, they don't "belong" to any file ;; that happens to be being loaded when this is called. (let ((fdefine-file-pathname nil) (inhibit-fdefine-warnings t));Don't give warnings for combined methods ;; Reverse the list so that this flavor comes first, followed by directest descendents. (dolist (fn (reverse (flavor-depended-on-by-all (get flavor-name 'flavor) (list flavor-name)))) (let ((fl (get fn 'flavor))) (if (flavor-depends-on-all fl) (compose-flavor-combination fl)) (if (flavor-method-hash-table fl) (compose-method-combination fl)))))) ;This one is when the old instances don't have to be discarded, ;and methods have not changed, just to check whether specialness ;of instance variables has changed. (defun perform-flavor-bindings-redefinition (flavor-name) (dolist (fl1 (flavor-depended-on-by-all (get flavor-name 'flavor) (list flavor-name))) (setq fl1 (get fl1 'flavor)) (cond ((flavor-method-hash-table fl1) (compose-flavor-bindings fl1) (compose-flavor-initializations fl1))))) (defun make-flavor-all-special (flavor) (if (symbolp flavor) (setq flavor (get flavor 'flavor))) (cond ((not (flavor-all-instance-variables-special flavor)) (or (fquery format:y-or-n-p-options "~&Loading old compiled methods for flavor ~S. Make that flavor all-special? " (flavor-name flavor)) (ferror () "Loading old compiled methods which require all instance variables to be special, for flavor ~S" (flavor-name flavor))) (setf (flavor-all-instance-variables-special flavor) (or fdefine-file-pathname t)) (perform-flavor-bindings-redefinition (flavor-name flavor))))) ;; 3/18/89 DNG - Updated to get the package from the p-list. (defun describe-flavor (flavor-name &aux fl) (check-arg flavor-name (typep (setq fl (if (symbolp flavor-name) (get flavor-name 'flavor) flavor-name)) 'flavor) "a flavor or the name of one") (format t "~&Flavor ~S directly depends on flavors: ~:[none~;~:*~{~<~% ~3:;~S~>~^, ~}~]~%" flavor-name (flavor-depends-on fl)) (and (flavor-includes fl) (format t " and directly includes ~{~<~% ~3:;~S~>~^, ~}~%" (flavor-includes fl))) (and (flavor-depended-on-by fl) (format t " and is directly depended on by ~{~<~% ~3:;~S~>~^, ~}~%" (flavor-depended-on-by fl))) (and (flavor-depends-on-all fl);If this has been computed, show it (format t " and directly or indirectly depends on ~{~<~% ~3:;~S~>~^, ~}~%" (flavor-depends-on-all fl))) (cond ((not (null (flavor-method-table fl))) (format t "Not counting inherited methods, the methods for ~S are:~%" flavor-name) (dolist (m (flavor-method-table fl)) (let ((methods (remove-if-not 'meth-definedp (cdddr m)))) (format t " ") (do ((tpl methods (cdr tpl))) ((null tpl)) (if (meth-method-type (car tpl)) (format t ":~A " (meth-method-type (car tpl)))) (format t ":~A" (car m)) (let ((subop (fifth (meth-function-spec (car tpl))))) (when subop (format t " :~A" subop))) (if (cdr tpl) (princ ", "))) ;; Print the method combination type if there is any. (and (cadr m) (format t " :~A~@[ :~A~]" (cadr m) (caddr m))) (terpri))))) (and (flavor-instance-size fl);If has been composed (format t "Flavor ~S has instance size ~D, " flavor-name (flavor-instance-size fl))) (when (flavor-all-instance-variables fl) (or (flavor-instance-size fl) (format t "Flavor ~s has " flavor-name)) (format t "Instance variables: ~{~<~% ~3:;~S~>~^, ~}~%" (flavor-all-instance-variables fl))) (and (flavor-gettable-instance-variables fl) (format t "Automatically-generated methods to get instance variables: ~{~<~% ~3:;~S~>~^, ~}~%" (flavor-gettable-instance-variables fl))) (and (flavor-settable-instance-variables fl) (format t "Automatically-generated methods to set instance variables: ~{~<~% ~3:;~S~>~^, ~}~%" (flavor-settable-instance-variables fl))) (and (flavor-inittable-instance-variables fl) (format t "Instance variables that may be set by initialization: ~{~<~% ~3:;~S~>~^, ~}~%" (mapcar #'cdr (flavor-inittable-instance-variables fl)))) (and (flavor-init-keywords fl) (format t "Keywords in the :INIT message handled by this flavor: ~{~<~% ~3:;~S~>~^, ~}~%" (flavor-init-keywords fl))) (format t "Defined in package ~A~%" (flavor-definition-package fl)) (cond ((flavor-plist fl) (format t "Properties:~%") (do ((l (flavor-plist fl) (cddr l))) ((null l) nil) (format t " ~S: ~S~%" (car l) (cadr l))))) (cond ((null (flavor-method-hash-table fl)) (format t "Flavor ~S does not yet have a method hash table~%" flavor-name)) ((eq t (flavor-method-hash-table fl)) (format t "Flavor ~S has been method-composed but has no hash table since it is an :ABSTRACT-FLAVOR.~%" flavor-name)) (t (format t "Flavor ~S has method hash table:~%" flavor-name) (describe (flavor-method-hash-table fl))))) (defun flavor-hack-documentation (flavor-name) (let* ((doc (getf (flavor-plist (get flavor-name 'flavor)) :documentation)) (strings nil) foo) (if doc (progn (dolist (tem doc) (and (stringp tem) (setq strings (nconc strings (cons tem ()))))) (dolist (tem doc) (unless (stringp tem) (setq strings (nconc strings (list* (if (and strings (not foo)) #\Newline "") (if foo "" (setq foo "A ")) tem #\Space ()))))) (if foo (nconc strings (list "Flavor."))) (setf (documentation flavor-name 'defflavor) (apply 'string-append strings))) (if (documentation flavor-name 'defflavor) (setf (documentation flavor-name 'defflavor) ()))))) ;; This is the standard way of defining a method of a class, ;; so that the code will be compiled. Note that DEFMETHOD works for ;; both Class methods and Flavor methods. ;; If in place of the lambda-list you have a symbol, and the body ;; is null, that symbol is a function which stands in for the method. ;; 12/19/88 DNG - Separated new function DEFMETHOD1 from the DEFMETHOD macro ;; so that it can be used by both the Flavors and CLOS versions of DEFMETHOD. ;; 03/16/89 clm - Integrated CLOS changes into Kernel. (defun defmethod1 (spec lambda-list body) (let ((flavor-name (car spec)) (function-spec (cons :method spec)) fl) `(progn ,(and (just-compiling) (compilation-flavor flavor-name t) (neq flavor-name 'vanilla-flavor);This kludge avoids bootstrapping problems! `(eval-when (compile) (let ((*just-compiling* t)) (flavor-notice-method ',function-spec)))) ,(cond ((and (symbolp lambda-list) (not (null lambda-list)) (null body)) `(fdefine-for-defmethod ',function-spec ',lambda-list t)) ((setq fl (compilation-flavor flavor-name t)) (if (flavor-get fl :alias-flavor) (ferror () "Attempt to define ~S; the flavor is an alias flavor." (cons :method spec))) `(defun ,function-spec ,(method-argument-list lambda-list function-spec) (declare (:self-flavor ,flavor-name)) ,@body)) (t (ferror () "~S is not a flavor." (car spec))))))) ;; 03/16/89 clm - Integrated CLOS changes into Kernel. (COMPILER-LET ((local-declarations '((:expr-sxhash 3542393.)))) (defmacro defmethod (spec lambda-list . body) "(DEFMETHOD (flavor-name [daemon-type] operation [:case-sub-operation]) lambda-list . body) Defines the method for flavor: flavor-name for the message operation, Daemon-type can be one of: :BEFORE :AFTER :AROUND :INVERSE-AROUND :CASE :DEFAULT :OR :AND :OVERRIDE :PROGN :LIST :INVERSE-LIST :PASS-ON :APPEND :NCONC. :case-sub-operation must be provided for :CASE deamon-type,it is illegal otherwise." (defmethod1 spec lambda-list body))) (defprop .operation. t compiler:ignorable-variable) (defprop .suboperation. t compiler:ignorable-variable) (defprop .daemon-caller-args. t compiler:ignorable-variable) (defprop .daemon-mapping-table. t compiler:ignorable-variable) (deff fdefine-for-defmethod #'fdefine) (defprop fdefine-for-defmethod t qfasl-dont-record) (defun method-argument-list (specified-lambda-list function-spec) "Given an arglist specified in DEFMETHOD, return an arglist for the actual method. This involves adding OPERATION to the front, and sometimes other things depending on the method type" (cons '.operation. (append (if (cdddr function-spec) (get (caddr function-spec) 'implicit-method-arguments)) specified-lambda-list))) (defprop :case (.suboperation.) implicit-method-arguments) ; This lets you specify code to be wrapped around the invocation of the ; various methods for an operation. For example, ; (DEFWRAPPER (FOO-FLAVOR :OPERATION) ((ARG1 ARG2) . BODY) ; `(WITH-FOO-LOCKED (SELF) ; (PRE-FROBULATE SELF ARG1 ARG2) ; ,@BODY ; (POST-FROBULATE SELF ARG2 ARG1))) ;Note that the wrapper needs to be defined at both compile and run times ;so that compiling combined methods as part of the qfasl file works. (defmacro defwrapper ((flavor-name operation) (defmacro-lambda . guts) &body body) (let ((function-spec `(:method ,flavor-name :wrapper ,operation))) `(progn ,(and (compilation-flavor flavor-name t) (just-compiling) `(eval-when (compile) (let ((*just-compiling* t)) (flavor-notice-method ',function-spec)))) ,(if (and (symbolp defmacro-lambda) (string-equal defmacro-lambda 'ignore)) `(defmacro ,function-spec (ignore . ,guts) ,@body) `(defmacro ,function-spec (arglistname . ,guts) `(destructuring-bind ,',defmacro-lambda (cdr ,arglistname) ,,@body)))))) ;This just exists to be called at compile-time from the DEFMETHOD macro, ;so that any combined methods generated by COMPILE-FLAVOR-METHODS will ;know that this method will be around at run time and should be called. ;Returns non-NIL if the method is really defined (not just noticed). (defun flavor-notice-method (function-spec) (if (fboundp 'compiler:compilation-define) (compiler:compilation-define function-spec)) (condition-case () (let ((meth (flavor-method-entry function-spec () t))) (if (meth-definedp meth) (meth-definition meth) (progn (setf (meth-definition meth) ()) ()))) (invalid-function-spec nil))) ;Find or create a method-table entry for the specified method. ;DONT-CREATE is NIL if method is to be created if necessary. ; The flavor is "created" too, as an UNDEFINED-FLAVOR property ; of the flavor name, just to record any properties of methods. ;COPY-FLAVOR-IF-UNDEFINED-METH says we are going to alter the METH ;for compilation if it is not defined, so the flavor should be copied in that case. (defun flavor-method-entry (function-spec dont-create &optional copy-flavor-if-undefined-meth) (let ((default-cons-area background-cons-area) (flavor-name (second function-spec)) (type (third function-spec)) (subtype (fifth function-spec)) (message (fourth function-spec))) (if (null message) (setq message type type ()));If no type (if (or (null message) (neq (first function-spec) :method) (> (length function-spec) 5) (not (symbolp flavor-name)) (not (symbolp type)) (not (symbolp message)) ;; Allow integers for subtypes. clm for *BJ* 7/1/88 #| (not (symbolp subtype)) |#) (ferror 'invalid-function-spec "~S is not a valid :METHOD function spec." function-spec)) (let* ((fl (or (compilation-flavor flavor-name) (unless *just-compiling* (get flavor-name 'undefined-flavor)) (and (not dont-create) (if *just-compiling* (compilation-define-flavor flavor-name (make-flavor flavor-name flavor-name)) (setf (get flavor-name 'undefined-flavor) (make-flavor flavor-name flavor-name)))))) (mte (and fl (assoc message (flavor-method-table fl) :test #'eq))) (meth (meth-lookup (cdddr mte) type subtype))) ;; If we are compiling a file, don't modify an installed flavor. ;; Make a new flavor object just for compilation and modify it instead. (and (or (and (not dont-create) (null meth)) (and meth copy-flavor-if-undefined-meth (not (meth-definedp meth)))) *just-compiling* fl (eq fl (get flavor-name 'flavor)) (compilation-define-flavor flavor-name (setq fl (flavor-redefinition-for-compilation fl ())))) (and (null mte) (not dont-create) ;; Message not previously known about, put into table fl (push (setq mte (list* message () () ())) (flavor-method-table fl))) ;; Message known, search for the type entry (cond (meth);Known by flavor (dont-create nil);Not to be created ((null fl) nil);Create, but no flavor defined (t ;; Type not known, create a new meth with an unbound definition cell (let ((meth (list-in-area (if *just-compiling* default-cons-area permanent-storage-area) ;; Copy the function spec for paging efficiency. (if *just-compiling* function-spec (copy-list function-spec permanent-storage-area)) () ()))) (nullify-method-definition meth) (push meth (cdddr mte)) meth)))))) (defun flavor-method-function-specs (flavor &aux methods) "Return a list of function specs for all the methods (except combined) of FLAVOR." (if (symbolp flavor) (setq flavor (compilation-flavor flavor))) (dolist (mte (flavor-method-table flavor)) (dolist (meth (cdddr mte)) (or (eq (meth-method-type meth) :combined) (not (meth-definedp meth)) (push (meth-function-spec meth) methods)))) methods) (defun delete-flavor-method-table-entry (flavor method) "Delete the specified METHOD entry in the FLAVOR's flavor-method-table" (let ((tempvar (get flavor 'flavor))) (and tempvar (setf (flavor-method-table tempvar) (delete (assoc method (flavor-method-table tempvar) :test #'eq) (the list (flavor-method-table tempvar)) :test #'eq))) t)) ;; 9/02/88 DNG - Extended to handle CLOS methods. ;; 11/02/88 DNG - Use new function FLAVOR-METHOD-SPEC-P to ensure consistency with DEFMETHOD. ;; 03/16/89 clm - Integrated CLOS changes into Kernel. (defmacro undefmethod (method-spec &rest things &environment env) (declare (arglist spec &optional lambda-list &rest ignore)) "Forcibly remove a method definition from a class or flavor's method table. Syntax is identical to the beginning of a DEFMETHOD for the same method. For CLOS: (UNDEFMETHOD function-spec [method-qualifier] specialized-lambda-list) For Flavors: (UNDEFMETHOD (flavor-name [daemon-type] operation))" (if (ticlos::flavor-method-spec-p method-spec) ;; Flavors method `(progn (fundefine '(:method . ,method-spec)) (delete-flavor-method-table-entry ',(first method-spec) ',(second method-spec))) ;; else CLOS method (multiple-value-bind ( method-combination-identifiers specializers function lambda-list fspec) (ticlos::parse-method things method-spec env) (declare (ignore method-combination-identifiers specializers function)) (if (null lambda-list) (error "Lambda-list missing for UNDEFMETHOD") `(fundefine ',fspec) )))) ;;; Interface to function-spec system ;; (:METHOD class-name operation) refers to the method in that class for ;; that operation; this works for Flavor methods. ;; The specification may also be of the form ;; (:METHOD flavor-name method-type operation). (defvar last-fasload-combined-method-spec ()) (defvar last-fasload-combined-method-def) (defprop :method method-function-spec-handler function-spec-handler) (defun method-function-spec-handler (function function-spec &optional arg1 arg2 &aux fl) ;; 10/03/85 DNG - For FDEFINE of a :FASLOAD-COMBINED method, go ahead and replace ;; the previous definition if the new one is not FEF-EQUAL to it. ;; 6/16/86 PHD Removed support for classes. ;; 3/17/89 DNG - Update to support a default value for the GET operation. ;; 3/18/89 DNG - Fix DWIMIFY operation. [part of fix for SPR 9184] (let ((flavor (second function-spec)) (method-type (third function-spec)) (message (fourth function-spec)) (default-cons-area background-cons-area)) (if (null (cdddr function-spec)) (setq message (third function-spec) method-type ())) (cond ((not (and (symbolp flavor) (symbolp method-type) (symbolp message) (<= 3 (length function-spec) 5))) (unless (eq function 'validate-function-spec) (ferror 'invalid-function-spec "The function spec ~S is invalid." function-spec))) ((eq t (setq fl (compilation-flavor flavor))) ;; Silly pseudo-flavor for cold-load stream (if (eq function 'validate-function-spec) t ;;The property-list operations need to work for the editor (function-spec-default-handler function function-spec arg1 arg2))) (t (if (eq function 'validate-function-spec) t ;; Ignore FASLOAD-COMBINED methods if flavor methods composed already. (if (and fl (flavor-method-hash-table fl) (eq (third function-spec) 'fasload-combined) (if (eq function 'fdefine) (fef-equal arg1 (fdefinition-safe function-spec)) (equal function-spec last-fasload-combined-method-spec))) ;; This hair makes defining (INTERNAL (:METHOD FOO FASLOAD-COMBINED ...) ...) ;; get ignored properly and not get an error. (case function (fdefinition last-fasload-combined-method-def) (fdefinedp t) (fdefine (setq last-fasload-combined-method-spec function-spec) (setq last-fasload-combined-method-def arg1)) (fdefinition-location (locf last-fasload-combined-method-def)) (t nil)) ;; Otherwise refer to or define the :COMBINED method. (progn (if (eq method-type 'fasload-combined) (setq function-spec (list* (first function-spec) flavor :combined (cdddr function-spec)) method-type :combined)) (let ((meth (flavor-method-entry function-spec (case function ((putprop push-property fdefinition-location fdefine) nil) ;Create. (otherwise t))))) ;Don't create (or (and meth (meth-definedp meth)) (member function '(fdefinedp compiler-fdefinedp putprop push-property fdefinition-location fdefine get function-parent dwimify) :test #'eq) (if fl (ferror () "~S is not a defined method; it is not possible to ~S it" function-spec function) (ferror () "~S is neither the name of a flavor nor the name ~ of a class;~% it is not possible to ~S ~S." flavor function function-spec))) (case function (fdefine (or fl (ferror () "~S is neither the name of a flavor nor the name ~ of a class;~% it is not possible to ~S ~S." flavor function function-spec)) (let ((definition-new (not (meth-definedp meth))) (old-definition (and (meth-definedp meth) (meth-definition meth)))) (setf (meth-definition meth) arg1) ;; If we load a method compiled before system 83, ;; that expects instance variables to be bound, ;; make it work by forcing this flavor to bind all variables. ; (if (and (typep arg1 :compiled-function) ; (zerop (%p-ldb %%fefh-get-self-mapping-table arg1)) ; (not (assoc 'encapsulated-definition (debugging-info arg1) :test #'eq))) ; (make-flavor-all-special fl)) ;; Incrementally recompile the flavor if this is a new method, unless ;; it is a :COMBINED method, which is the result of compilation, ;; not a client of it. (cond ((member method-type '(:wrapper :inverse-wrapper) :test #'eq) (or (and (consp old-definition) (fef-equal (cdr arg1) (cdr old-definition))) ;; Wrapper is really changed; must recompile flavors. ;; Arrange that if we abort, the definition is set ;; to the symbol ABORTED-DEFINITION. This is a no-op, ;; and redefining or undefining the wrapper will recompile. (let (success) (unwind-protect (progn (recompile-flavor flavor message ()) (setq success t)) (or success (setf (meth-definition meth) 'aborted-definition)))))) ((eq method-type :combined) ;;;phd 3/6/84 update the macro-expanded-into debug info field ;;; of the daemons, so when a daemon is gettting redefined, we can recompose ;;; this combined method. (let ((remove (set-difference (and old-definition (get-debug-info-field (get-debug-info-struct old-definition t) :macros-expanded)) (get-debug-info-field (get-debug-info-struct (meth-definition meth) t) :macros-expanded) :test #'equal :key #'(lambda (x) (if (consp x) (car x) x)))) (add (get-debug-info-field (get-debug-info-struct (meth-definition meth) t) :macros-expanded) )) (when remove (dolist (fn remove) (let ((fn (if (consp fn) (car fn) fn))) (when (and (consp fn ) (eq :method (car fn))) (remove-method-reference fn (function-name old-definition)))))) (when add (dolist (fn add) (let ((fn (if (consp fn) (car fn) fn))) (when (and (consp fn ) (eq :method (car fn ))) (add-method-reference fn (meth-function-spec meth)))))))) (definition-new ;; This SETF, by virtue of the preceding clause, ;; arranges that if we abort out before finishing recompilation ;; then the recompilation will be done again if the user ;; either redoes the defmethod or does undefmethod. (setf (meth-definition meth) 'aborted-definition) (recompile-flavor flavor message) (setf (meth-definition meth) arg1)) ;; If method defined as a random symbol, ;; must fix up hash table each time it changes. ((or (symbolp old-definition) (symbolp arg1)) (recompile-flavor flavor message)) ;; phd 2/15/86 if the old method is expanded in a combined method ;; then rebuild it for that we use meth as third arg for recompile-flavor ((and (get-debug-info-field (get-debug-info-struct old-definition t) :macros-expanded-into ) (not (fef-equal old-definition (meth-definition meth)))) (recompile-flavor flavor message meth))))) (fdefinition (meth-definition meth)) (fdefinedp (and meth (values (meth-definedp meth) (and (meth-definedp meth) (meth-definition meth))))) (fdefinition-location (locf (meth-definition meth))) (fundefine (setf (meth-definition meth) 'undefinition-in-progress) (recompile-flavor (flavor-name fl) message) ;Propagate the change (nullify-method-definition meth)) ;Say propagation is complete. (compiler-fdefinedp meth) (get (if meth (getf (meth-plist meth) arg1 arg2) arg2)) (putprop (let ((default-cons-area background-cons-area)) (setf (getf (meth-plist meth) arg2) arg1))) (push-property (let ((default-cons-area background-cons-area)) (setf (getf (meth-plist meth) arg2) (cons arg1 (getf (meth-plist meth) arg2))))) (dwimify (catch 'sys:dwimify-package (dolist (component (or (flavor-depends-on-all fl) (compose-flavor-combination fl ()))) (let* ((flavor (compilation-flavor component)) (meths (and flavor (cdddr (assoc message (flavor-method-table flavor) :test #'eq))))) (dolist (meth meths) (when (meth-definedp meth) (dwimify-package-2 (meth-function-spec meth) nil arg1 arg2 t) )))) nil)) (otherwise (function-spec-default-handler function function-spec arg1 arg2))))))))))) (defun add-method-reference (fn combined-method) ;; add the reference to combined-method from the debug-info :macros-expanded-into of fn (let((default-cons-area background-cons-area) (sys:%inhibit-read-only t) (debug-info (get-debug-info-struct (fdefinition fn ) t)) prop) (if debug-info (unless (member combined-method (setf prop (get-debug-info-field debug-info :macros-expanded-into)) :test #'equal) (put-debug-info-field debug-info :macros-expanded-into (nconc prop (list combined-method)))) nil );(foo (make-debug-info-struct :macros-expanded-into combined-method))) )) (defun remove-method-reference (fn combined-method) ;; remove the reference to combined-method from the debug-info :macros-expanded-into of fn (let((default-cons-area background-cons-area) (sys:%inhibit-read-only t) (debug-info (get-debug-info-struct (fdefinition fn ) t))) (when debug-info (put-debug-info-field debug-info :macros-expanded-into (delete combined-method (get-debug-info-field debug-info :macros-expanded-into) :test #'equal :count 1))) )) ;Like EQUAL, but compares the contents of FEFs. ;;PHD 1/5/86, Replaced equal by equalp so debug-info-structure are ;;Compared for their values and not for eqness. (defun fef-equal (fef1 fef2 &aux dt) (or (equal fef1 fef2) (and (= (%structure-total-size fef1) (%structure-total-size fef2)) (= (%structure-boxed-size fef1) (%structure-boxed-size fef2)) (let ((boxed (%structure-boxed-size fef1)) (total (%structure-total-size fef1))) (and (= (%p-pointer fef1) (%p-pointer fef2)) ;; TGC (and (= (%p-ldb %%q-pointer fef1) (%p-ldb %%q-pointer fef2)) (do ((i 1 (1+ i))) ((= i boxed) t) (or (and (= (setq dt (%p-data-type-offset fef1 i)) (%p-data-type-offset fef2 i)) ;; TGC (= (%p-ldb-offset %%q-data-type fef1 i) (%p-ldb-offset %%q-data-type fef2 i)) (OR ;; Check for self ref pointer. They're "same" if same pointer field. ;; Never try to get "contents" of SRP. 3-19-87, -ab (WHEN (= dt dtp-self-ref-pointer) (IF (eq (%p-pointer-offset fef1 i) (%p-pointer-offset fef2 i)) t (RETURN nil))) (equal (%p-safe-contents-offset fef1 i) (%p-safe-contents-offset fef2 i)) (eql i %fef-debugging-info-word))) (return ()))) (do ((i boxed (1+ i))) ((= i total) t) (or (and (= (%p-ldb-offset %%q-low-half fef1 i) (%p-ldb-offset %%q-low-half fef2 i)) (= (%p-ldb-offset %%q-high-half fef1 i) (%p-ldb-offset %%q-high-half fef2 i))) (return ())))))))) ;This is left as the method definition if you abort out of the recompilation ;caused by defining a previously undefined method. (deff aborted-definition 'prog1) ;This is what the method definition is while the method is being FUNDEFINEd. (deff undefinition-in-progress 'prog1) ;; Run-time alternative flavors. (defun get-run-time-alternative-flavor-names (flavor) (mapcar 'cdr (flavor-get flavor 'run-time-alternative-alist))) (defun make-run-time-alternative-defflavors (flavor-name specs) "Return a list of defflavor forms for the run-time alternatives of FLAVOR-NAME. These are the flavors generated automatically by defining FLAVOR-NAME and one of which you get when you instantiate FLAVOR-NAME. SPECS should be the value of the :RUN-TIME-ALTERNATIVES option in its definition; this function can be called before the definition is really in effect." (loop for alt in (make-run-time-alternative-combinations-1 flavor-name specs) when (and (not (member-if 'stringp alt)) (> (length alt) 1)) collect `(defflavor ,(intern (combination-flavor-name alt)) () ,alt))) (defun make-run-time-alternative-alist (flavor-name specs) (mapcar #'(lambda (combination) (cons combination (intern (combination-flavor-name combination)))) (make-run-time-alternative-combinations-1 flavor-name specs))) (defun combination-flavor-name (flavor-list &aux combined-name) (dolist (name (remove-duplicates flavor-list)) (if (string-equal name "-FLAVOR" (- (length name) 7)) (setq name (SUBSEQ NAME 0 (- (length name) 7)))) (if (string-equal name "-MIXIN" (- (length name) 6)) (setq name (SUBSEQ name 0 (- (length name) 6)))) (if combined-name (setq combined-name (string-append combined-name "-" name)) (setq combined-name name))) combined-name) (defun make-run-time-alternative-combinations (flavor) "Return a list of flavor combinations which are run-time alternatives of FLAVOR-NAME. Each combination is a list of the flavor names to be combined." (let ((specs (flavor-get flavor :run-time-alternatives))) (make-run-time-alternative-combinations-1 flavor specs))) (defun make-run-time-alternative-combinations-1 (flavor-name specs) (if (null specs) (if flavor-name `((,flavor-name)) '(nil)) (let ((remaining-specs-alternatives (make-run-time-alternative-combinations-1 flavor-name (cdr specs))) (this-spec-alternatives (make-run-time-alternatives (car specs)))) (loop for this-spec in this-spec-alternatives nconc (loop for remaining in remaining-specs-alternatives collect (append this-spec remaining)))))) (defun make-run-time-alternatives (spec) (if (consp (cadr spec)) (loop for alternative in (cdr spec) append (make-run-time-alternative-combinations-1 (cadr alternative) (cddr alternative))) `(nil . ,(make-run-time-alternative-combinations-1 (cadr spec) (cddr spec))))) ;; Note that it is vital that the combination to be used ;; be consed up in the same order as the combination was made by ;; MAKE-RUN-TIME-ALTERNATIVE-COMBINATIONS, or it will not be recognized ;; in the RUN-TIME-ALTERNATIVE-ALIST. (defun choose-run-time-alternative (flavor init-plist) "This is the :INSTANTIATION-FLAVOR-FUNCTION used for run-time alternative flavors." (let* ((specs (flavor-get flavor :run-time-alternatives)) (combination (choose-run-time-alternative-1 specs init-plist (flavor-name flavor)))) (or (cdr (assoc (append combination (list (flavor-name flavor))) (flavor-get flavor 'run-time-alternative-alist) :test #'equal)) (if (member-if 'stringp combination) (ferror () (car (member-if 'stringp combination))) (ferror () "Bug in :RUN-TIME-ALTERNATIVE processing:~%Flavor ~S, combination ~S." flavor combination))))) (defun choose-run-time-alternative-1 (specs init-plist flavor-name) (loop for spec in specs append (choose-run-time-alternative-2 spec init-plist flavor-name))) (defun choose-run-time-alternative-2 (spec init-plist flavor-name) (let ((value (get init-plist (car spec))) tem) (if (consp (cadr spec)) (setq tem (assoc value (cdr spec) :test #'eq)) (case value ((t) (setq tem spec)) ((nil) (setq tem '(foo))))) (unless tem (ferror () "Keyword ~S with value ~S is not legitimate for flavor ~S." (car spec) value flavor-name)) (when (stringp (cadr tem)) (ferror () (cadr tem) (car spec) value flavor-name)) (let ((subs (choose-run-time-alternative-1 (cddr tem) init-plist flavor-name))) (if (cadr tem) (append subs (list (cadr tem))) subs)))) (defun assure-flavor-composed (flavor-name &aux fl) "Compose flavor FLAVOR-NAME and its methods if that has not already been done." (check-arg flavor-name (setq fl (get-flavor-tracing-aliases flavor-name)) "the name of an instantiable flavor, or alias thereof") ;; Do any composition (compilation) of combined stuff, if not done already (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) (or (flavor-method-hash-table fl) (compose-method-combination fl))) ;;;#+elroy ;;;(defun make-method-hash-table (fl) ;;; ;; makes the hash table from a list of (key . value) stored in the flavor-hash-table of fl. ;;; (let* ((entry-list (flavor-method-hash-table fl)) ;;; (ht (make-flavor-hash-array permanent-storage-area ;;; (1+ (ceiling (/ (length entry-list ) 0.8s0))))) ;;; (*create-mapping-tables* t)) ;;; (dolist (entry entry-list) ;;; (puthash-array (car entry ) (second entry) ht ;;; (third entry) )) ;;; (setf (flavor-method-hash-table fl) ht))) ;;;#+elroy ;;;(defun instantiate-flavor (flavor init-plist &optional send-init-message-p return-unhandled-keywords-p;as second value ;;; area-to-cons-instance-in &aux fl unhandled-keywords instance vars new-plist plist) ;;; "Create and return an instance of the specified FLAVOR, low level. ;;;INIT-PLIST's CDR is the list of init keywords and their values. ;;;This list will be modified destructively so that any default init plist ;;;keywords (except those that just set instance variables) are on it. ;;;We send a :INIT message only if SEND-INIT-MESSAGE-P is non-nil. ;;;That may further modify the INIT-PLIST. ;;;If RETURN-UNHANDLED-KEYWORDS-P is non-nil, our second value is an ;;;alternating list of keywords and values for those keywords specified in ;;;INIT-PLIST (or in the default init plist) which the flavor doesn't handle. ;;;If RETURN-UNHANDLED-KEYWORDS-P is nil, it is an error if there are any such. ;;;FLAVOR may also be a flavor instance, instead of a flavor name. In this case ;;;the instance is reinitialized using INIT-PLIST, and a new flavor instance is NOT created." ;;; ;;If user supplied first arg a flavor instance, use it instead of creating a new instance. ;;; (if (typep flavor 'instance) ;;; (progn ;;; (setq instance flavor ;;; flavor (type-of instance) ;;; fl (get-flavor-tracing-aliases flavor) ;;; vars (flavor-all-instance-variables fl)) ;;; ;; Default all instance variables to unbound ;;; (do ((v vars (cdr v)) ;;; (i 1 (1+ i))) ;;; ((null v)) ;;; (%p-store-tag-and-pointer (%make-pointer-offset dtp-locative instance i) dtp-null ;;; (car v)))) ;;; ;; Trace any chain of alias flavors to a non-alias flavor. ;;; (progn ;;; (check-arg flavor (setq fl (get-flavor-tracing-aliases flavor)) ;;; "the name of an instantiable flavor, or alias thereof, or a flavor instance to be reinitialized.") ;;; (setf plist (flavor-plist fl)) ;;; (let ((tem (getf plist :instantiation-flavor-function))) ;;; (when tem ;;; (setq tem (funcall tem fl init-plist)) ;;; (unless (and (symbolp tem) (get tem 'flavor)) ;;; (ferror () ;;; "The INSTANTIATION-FLAVOR-FUNCTION for flavor ~S ;;;returned an invalid value, ~S, not a flavor name." ;;; flavor)) ;;; (setq flavor tem ;;; fl (get-flavor-tracing-aliases flavor)))) ;;; (when (getf plist :abstract-flavor) ;;; (ferror () "~S is an abstract flavor (or alias of one) and may not be instantiated." ;;; flavor)) ;;; (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) ;;; (typecase (flavor-method-hash-table fl) ;;; (array nil) ;;; (cons (make-method-hash-table fl)) ;;; (null (compose-method-combination fl)) ;;; (t nil)) ;;; (unless area-to-cons-instance-in ;;; (setq area-to-cons-instance-in ;;; (and (getf plist 'instance-area-function) ;;; (funcall (getf plist 'instance-area-function) init-plist)))) ;;; (let ((missing-keywords ;;; (remove-if #'(lambda (keyword) ;;; (get-location-or-nil init-plist keyword)) ;;; (getf plist 'required-init-keywords)))) ;;; (when missing-keywords ;;; (ferror () "Flavor ~S requires init keywords ~S that are missing." flavor ;;; missing-keywords))) ;;; (setq instance ;;; (%allocate-and-initialize-instance; ;;; fl area-to-cons-instance-in (flavor-instance-size fl)))) ;;; ;; Make the instance object, then fill in its various fields ;;; ; (FUNCALL (OR (GETF PLIST 'INSTANCE-AREA-FUNCTION) 'IGNORE) ;;; ; INIT-PLIST))) ;;; ;; Do any composition (compilation) of combined stuff, if not done already ;;;); (SETQ VARS (FLAVOR-ALL-INSTANCE-VARIABLES FL))) ;;; ;; Default all instance variables to unbound ;;; ; (DO ((V VARS (CDR V)) ;;; ; (I 1 (1+ I))) ;;; ; ((NULL V)) ;;; ; (%P-STORE-TAG-AND-POINTER (%MAKE-POINTER-OFFSET DTP-LOCATIVE INSTANCE I) ;;; ; DTP-NULL (CAR V))) ;;; (setq unhandled-keywords (flavor-unhandled-init-keywords fl)) ;;; (let ((var-keywords (flavor-all-inittable-instance-variables fl)) ;;; (remaining-keywords (flavor-remaining-init-keywords fl))) ;;; ;; First, process any user-specified init keywords that ;;; ;; set instance variables. When we process the defaults, ;;; ;; we will see that these are already set, and will ;;; ;; refrain from evaluating the default forms. ;;; ;; At the same time, we record any init keywords that this flavor doesn't handle. ;;; (do ((pl (cdr init-plist) (cddr pl))) ;;; ((null pl)) ;;; (let ((index (position (car pl) (the list var-keywords) :test #'eq))) ;;; (cond ;;; (index ;;; (or (/= dtp-null (%p-data-type (%instance-loc instance (1+ index)))) ;;; (setf (%instance-ref instance (1+ index)) (cadr pl)))) ;;; ((not (member (car pl) remaining-keywords :test #'eq)) ;;; (pushnew (car pl) unhandled-keywords))))) ;;; ;; Now do all the default initializations, of one sort or other, ;;; ;; that have not been overridden. ;;; (let ((self instance)) ;;; (dolist (d (flavor-instance-variable-initializations fl)) ;;; (or (/= dtp-null (%p-data-type (%instance-loc instance (1+ (car d))))) ;;; (setf (%instance-ref instance (1+ (car d))) (fast-eval (cadr d))))) ;;; ;; Now stick any default init plist items that aren't handled by that ;;; ;; onto the actual init plist. ;;; (do ((pl (flavor-remaining-default-plist fl) (cddr pl))) ;;; ((null pl)) ;;; (or (memq-alternated (car pl) (cdr init-plist)) ;;; (progn ;;; (unless (eq init-plist (locf new-plist)) ;;; (setq new-plist (cdr init-plist) ;;; init-plist (locf new-plist))) ;;; (setq new-plist (list* (car pl) (fast-eval (cadr pl)) new-plist))))))) ;;; ;; Complain if any keywords weren't handled, unless our caller ;;; ;; said it wanted to take care of this. ;;; (and (not return-unhandled-keywords-p) unhandled-keywords ;;; (not (get init-plist :allow-other-keys)) ;;; (ferror () "Flavor ~S does not handle the init keyword~P ~{~S~^, ~}" flavor ;;; (length unhandled-keywords) unhandled-keywords)) ;;; (if send-init-message-p ;;; (send instance :init init-plist)) ;;; (values instance unhandled-keywords)) ;;;#+elroy ;;;(defun %make-instance (flavor-name &rest contents &aux fl instance) ;;; "Create an instance of flavor FLAVOR-NAME and init all slots from CONTENTS. ;;;This ignores completely the default initializations, ;;;and dos not send the :INIT message. But it is very fast. ;;;CONTENTS must have exactly the right number of elements, ;;; and must be a cdr-coded list." ;;; (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "the name of a flavor") ;;; (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) ;;; (typecase (flavor-method-hash-table fl) ;;; (array nil) ;;; (cons (make-method-hash-table fl)) ;;; (null (compose-method-combination fl)) ;;; (t nil)) ;;; (setq instance ;;; (%allocate-and-initialize-instance fl default-cons-area (flavor-instance-size fl))) ;;; (when contents ;;; (%blt-typed contents (%instance-loc instance 1) (1- (flavor-instance-size fl)) 1)) ;;; instance) (defun memq-alternated (elt list) (do ((l list (cddr l))) ((null l) nil) (if (eq (car l) elt) (return l)))) (defun flavor-default-init-plist (flavor-name &optional (init-plist (cons () ())) &aux fl) "Returns the default init plist for FLAVOR-NAME. If INIT-PLIST is specified, it is modified to contain any default init plist entries which it does not override." (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "the name of a flavor") ;; Do any composition (compilation) of combined stuff, if not done already (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) (dolist (ffl (flavor-depends-on-all fl)) (setq ffl (get ffl 'flavor)) (do ((l (getf (flavor-plist ffl) :default-init-plist) (cddr l))) ((null l) nil) (do ((m (cdr init-plist) (cddr m))) ((null m) (setf (get init-plist (car l)) (eval (cadr l)))) (and (eq (car m) (car l)) (return))))) init-plist) (defun flavor-allows-init-keyword-p (flavor-name keyword) "Return non-nil if flavor FLAVOR-NAME handles init keyword KEYWORD. The actual value is the particular component flavor which handles it." (map-over-component-flavors 0 t t #'(lambda (fl ignore keyword) (and (or (assoc keyword (flavor-inittable-instance-variables fl) :test #'eq) (member keyword (flavor-init-keywords fl) :test #'eq)) (flavor-name fl))) flavor-name () keyword)) (defun flavor-allowed-init-keywords (flavor-name) "Return a list of all init keywords handled by flavor FLAVOR-NAME." (let ((init-keywords nil)) (map-over-component-flavors 0 t () #'(lambda (flavor ignore) (setq init-keywords (append (mapcar #'(lambda (kwd) (if (consp kwd) (car kwd) kwd)) (flavor-local-init-keywords flavor)) init-keywords))) flavor-name ()) (sort (delete-duplicates (the list init-keywords) :test #'eq) #'alphalessp))) (defun flavor-local-init-keywords (flavor) (append (flavor-inittable-instance-variables flavor) (flavor-init-keywords flavor))) (defun flavor-default-init-putprop (flavor form init-keyword &aux fl) "Add or change an entry in FLAVOR's default init plist. The entry is for init keyword INIT-KEYWORD, and the value will be computed by evaluating FORM." (setq fl (if (symbolp flavor) (compilation-flavor flavor) flavor)) (unless (flavor-allows-init-keyword-p flavor init-keyword) (ferror () "Init keyword ~S invalid for flavor ~S." init-keyword flavor)) (setf (getf (getf (flavor-plist fl) :default-init-plist) init-keyword) form) (perform-flavor-bindings-redefinition flavor)) (defprop flavor-default-init-get ((flavor-default-init-get fl kwd) flavor-default-init-putprop fl val kwd) setf) (defun flavor-default-init-remprop (flavor init-keyword &aux fl) "Remove any entry for INIT-KEYWORD from FLAVOR's default init plist." (setq fl (if (symbolp flavor) (compilation-flavor flavor) flavor)) (remprop (locf (get (locf (flavor-plist fl)) :default-init-plist)) init-keyword) (perform-flavor-bindings-redefinition flavor)) (defun flavor-default-init-get (flavor init-keyword &aux fl) "Return the form for INIT-KEYWORD in FLAVOR's default init plist, or NIL." (setq fl (if (symbolp flavor) (compilation-flavor flavor) flavor)) (getf (getf (flavor-plist fl) :default-init-plist) init-keyword)) ; Function to map over all components of a specified flavor. We must do the ; DEPENDS-ON's to all levels first, then the INCLUDES's at all levels and ; what they depend on. ; Note that it does the specified flavor itself as well as all its components. ; Note well: if there are included flavors, this does not do them in the ; right order. Also note well: if there are multiple paths to a component, ; it will be done more than once. ; RECURSION-STATE is 0 except when recursively calling itself. ; ERROR-P is T if not-yet-defflavored flavors are to be complained about, ; NIL if they are to be ignored. This exists to get rid of certain ; bootstrapping problems. ; RETURN-FIRST-NON-NIL is T if the iteration should terminate as soon ; as FUNCTION returns a non-null result. ; At each stage FUNCTION is applied to the flavor (not the name), the ; STATE, and any ARGS. STATE is updated to whatever the function returns. ; The final STATE is the final result of this function. ; RECURSION-STATE is: ; 0 top-level ; 1 first-pass over just depends-on's ; 6 second-pass, this flavor reached via depends-on's so don't do it again ; 2 second-pass, this flavor reached via includes's so do it. (defvar some-component-undefined ()) ;If we find an undefined component, we put its name here. (defun map-over-component-flavors (recursion-state error-p return-first-non-nil function flavor-name state &rest args) (block map-over-component-flavors (prog (fl) (cond ((or error-p (compilation-flavor flavor-name)) (check-arg flavor-name (setq fl (compilation-flavor flavor-name)) "a defined flavor") ;; First do this flavor, unless this is the second pass and it shouldn't be done (or (logtest 4 recursion-state) (setq state (apply function fl state args))) ;; After each call to the function, see if we're supposed to be done now (and return-first-non-nil (not (null state)) (return-from map-over-component-flavors)) ;; Now do the depends-on's. (dolist (component-flavor (flavor-depends-on fl)) (setq state (apply #'map-over-component-flavors (if (zerop recursion-state) 1 recursion-state) error-p return-first-non-nil function component-flavor state args)) (and return-first-non-nil (not (null state)) (return-from map-over-component-flavors))) ;; Unless this is the first pass, do the includes. (or (logtest 1 recursion-state) (dolist (component-flavor (flavor-includes fl)) (setq state (apply #'map-over-component-flavors 2 error-p return-first-non-nil function component-flavor state args)) (and return-first-non-nil (not (null state)) (return-from map-over-component-flavors)))) ;; If this is the top-level, run the second pass on its depends-on's ;; which doesn't do them but does do what they include. (or (not (zerop recursion-state)) (dolist (component-flavor (flavor-depends-on fl)) (setq state (apply #'map-over-component-flavors 6 error-p return-first-non-nil function component-flavor state args)) (and return-first-non-nil (not (null state)) (return-from map-over-component-flavors))))) ((null some-component-undefined) (setq some-component-undefined flavor-name))))) state) (defparameter *dont-recompile-flavors* () "T means RECOMPILE-FLAVOR does nothing. Used to speed up multiple redefinitions on flavors. Turn this on for the redefinitions, turn this off, then recompile by hand. It can be a , in that case the combined methods will be recompiled if they contain (meth-function-spec in line") (defun recompile-flavor (flavor-name &optional (single-operation nil) (*use-old-combined-methods* t) (do-dependents t) &aux fl) "Recompute some or all combined methods for flavor FLAVOR-NAME and dependents. If SINGLE-OPERATION is NIL, all operations are done; otherwise that specifies which operation to do. If DO-DEPENDENTS is specified as NIL, the dependents are not done. If *USE-OLD-COMBINED-METHODS* is specified as NIL, existing combined methods are replaced even if they appear to be valid when checked. Do this to correct for a bug in a combined method creation function or a change in a macro that a wrapper expands into." ;; If this is called during file compilation, the output goes to the QFASL file. (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "the name of a flavor") (unless *dont-recompile-flavors* ;; Only update the method combination if it has been done before, else doesn't matter (cond ((flavor-method-hash-table fl) (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) (compose-method-combination fl single-operation))) (when do-dependents (let ((inhibit-fdefine-warnings t);Don't give warnings for combined methods (fdefine-file-pathname nil));And they don't "belong" to a file that calls this. (dolist (fn (flavor-depended-on-by-all fl)) (if (flavor-method-hash-table (get fn 'flavor)) (recompile-flavor fn single-operation *use-old-combined-methods* ()))))))) (defun flavor-depended-on-by-all (fl &optional list-so-far &aux scan-pointer tail ffl) "Return a list of the names of all flavors that depend on the flavor FL. Values are in breadth-first order, a good though not perfect order for doing redefinitions." (push fl list-so-far) (setq tail (last list-so-far)) (setq scan-pointer list-so-far) (do () ((null scan-pointer) (cdr list-so-far)) (let* ((fn (car scan-pointer)) (fl (if (symbolp fn) (compilation-flavor fn) fn))) (dolist (fn1 (flavor-depended-on-by fl)) (or (member fn1 list-so-far :test #'eq) (not (setq ffl (compilation-flavor fn1 ))) (rplacd tail (setq tail (cons fn1 ())))))) (pop scan-pointer))) ;This function takes care of flavor-combination. It sets up the list ;of all component flavors, in appropriate order, and the list of all ;instance variables. It generally needs to be called only once for a ;flavor, and must be called before method-combination can be dealt with. (defvar flavors-being-composed ()) ;;;PHD 3/9/87 Be carefull with nunion that destruct more than they used to do. (defun compose-flavor-combination (fl &optional (error-p t) &aux fls vars ords reqs specs size (some-component-undefined nil) (flavors-being-composed (cons fl flavors-being-composed)) (perm-area (if *just-compiling* default-cons-area permanent-storage-area)) (default-cons-area (if *just-compiling* default-cons-area *flavor-area*))) "Find and record component flavors of flavor object FL. ERROR-P says whether to get error on undefined components. We return a list of all known components; if they are all defined, then they are really all the components, and the flavor is marked as composed by setting its FLAVOR-DEPENDS-ON-ALL to that list." ;; Make list of all component flavors' names. ;; This list is in outermost-first order. ;; Would be nice for this not to have to search to all levels, but for ;; the moment that is hard, so I won't do it. ;; Included-flavors are hairy: if not otherwise in the list of components, they ;; are stuck in after the rightmost component that includes them, along with ;; any components of their own not otherwise in the list. (setq fls (copy-list (compose-flavor-inclusion (flavor-name fl) error-p) perm-area)) ;; Vanilla-flavor may have been put in by magic, so maintain the dependencies ;; in case new methods get added to it later. (let ((van (compilation-flavor 'vanilla-flavor)) (flav (flavor-name fl))) (and (not (null van)) (neq flav 'vanilla-flavor) (member 'vanilla-flavor fls :test #'eq) (not *just-compiling*) (not (member flav (flavor-depended-on-by van) :test #'eq)) (push flav (flavor-depended-on-by van)))) ;; Compute what the instance variables will be, and in what order. ;; Also collect the required but not present instance variables, which go onto the ;; ADDITIONAL-INSTANCE-VARIABLES property. The instance variables of the ;; :REQUIRED-FLAVORS work the same way. Such instance variables are ok ;; for our methods to access. (dolist (f fls) (setq f (compilation-flavor f)) (dolist (v (flavor-local-instance-variables f)) (or (atom v) (setq v (car v))) (or (member v vars :test #'eq) (push v vars))) (setq specs (nunion specs (copylist* (flavor-special-instance-variables f)) :test #'eq)) (setq reqs (nunion reqs (copylist* (getf (flavor-plist f) :required-instance-variables)) :test #'eq)) ;; Any variables our required flavors have or require, we require. (dolist (ff (getf (flavor-plist f) :required-flavors)) (cond ((and (not (member ff fls :test #'eq)) (setq ff (compilation-flavor ff)) (not (member ff (cdr flavors-being-composed) :test #'eq))) (or (flavor-depends-on-all ff) (compose-flavor-combination ff ())) (setq specs (nunion specs (copylist* (flavor-all-special-instance-variables ff)) :test #'eq)) (setq reqs (nunion (nunion reqs (copylist* (flavor-all-instance-variables ff)) :test #'eq) (copylist* (getf (flavor-plist ff) 'additional-instance-variables)) :test #'eq))))) (let ((ord (getf (flavor-plist f) :ordered-instance-variables))) ;; Merge into existing order requirement. Shorter of the two must be ;; a prefix of the longer, and we take the longer. (do ((l1 ord (cdr l1)) (l2 ords (cdr l2))) (nil) (cond ((null l1) (return ())) ((null l2) (return (setq ords ord))) ((neq (car l1) (car l2)) (ferror () ":ORDERED-INSTANCE-VARIABLES conflict, ~S vs ~S" (car l1) (car l2))))))) ;; Must not merge this with the previous loop, ;; to avoid altering order of instance variables ;; if a DEFFLAVOR is redone. (dolist (f fls) (setq f (compilation-flavor f))); ;; Any variables our components's methods reference, we must keep having. ; (SETQ VARS (UNION VARS (FLAVOR-MAPPED-INSTANCE-VARIABLES F)))) ;; This NREVERSE makes it compatible with the old code. There is no other reason for it. (setq vars (nreverse vars)) ;; Apply ordering requirement by moving those variables to the front. (dolist (v ords) (or (member v vars :test #'eq) (ferror () "Flavor ~S lacks instance variable ~S which has an order requirement" (flavor-name fl) v)) (setq vars (delete v (the list vars) :test #'eq))) (setq vars (append ords vars)) (setf (flavor-all-instance-variables fl) (copy-list vars perm-area)) (if (or ords (flavor-unmapped-instance-variables fl)) (setf (flavor-unmapped-instance-variables fl) ords)) ;; Instance size must be at least 2 or microcode blows out - fix some day? (setq size (max (1+ (length vars)) 2)) (and (flavor-instance-size fl) (/= (flavor-instance-size fl) size) (format *error-output* "~&Warning: changing the size of an instance of ~S from ~S to ~S This may cause you problems.~%";* This should perhaps do something about it * (flavor-name fl) (flavor-instance-size fl) size)) (setf (flavor-instance-size fl) size) ;; If there are any instance variables required but not present, save them ;; so that they can be accessed in methods. (dolist (v vars) (setq reqs (delete v (the list reqs) :test #'eq))) (and reqs (setf (getf (flavor-plist fl) 'additional-instance-variables) reqs)) (and specs (setf (flavor-all-special-instance-variables fl) specs)) ;; Don't mark this flavor as "composed" if there were errors. (or some-component-undefined (setf (flavor-depends-on-all fl) fls)) fls) (defun compose-flavor-inclusion (flavor error-p) (multiple-value-bind (fls additions) (compose-flavor-inclusion-1 flavor () error-p) ;; The new additions may themselves imply more components (do ((l additions (cdr l))) ((null l) nil) (let ((more-fls (compose-flavor-inclusion-1 (car l) fls error-p))) (dolist (f more-fls) ;; This hair inserts F before (after) the thing that indirectly included it ;; and then puts that next on ADDITIONS so it gets composed also (let ((ll (member (car l) fls :test #'eq))) (rplaca (rplacd ll (cons (car ll) (cdr ll))) f) (rplacd l (cons f (cdr l))))))) ;; Now attach vanilla-flavor if desired (or (loop for flavor in fls thereis (let ((tem (compilation-flavor flavor))) (and tem (getf (flavor-plist tem) :no-vanilla-flavor)))) (push 'vanilla-flavor fls)) (nreverse fls))) (defun compose-flavor-inclusion-1 (flavor other-components error-p &aux flavor-1) ;; First, make a backwards list of all the normal (non-included) components (declare (special other-components)) (let ((fls (map-over-component-flavors 1 error-p () #'(lambda (fl list) (setq fl (flavor-name fl)) (or (member fl list :test #'eq) (member fl other-components :test #'eq) (push fl list)) list) flavor ())) (additions nil)) ;; If there are any inclusions that aren't in the list, plug ;; them in right after (before in backwards list) their last (first) includer (do ((l fls (cdr l))) ((null l) nil) (dolist (fl (flavor-includes (compilation-flavor (car l)))) (or (member fl fls :test #'eq) (member fl other-components :test #'eq) (push (car (rplaca (rplacd l (cons (car l) (cdr l))) fl)) additions)))) (or (member flavor fls :test #'eq) ;; Avoid error if FLAVOR is undefined and ERROR-P is NIL. (not (or (setq flavor-1 (compilation-flavor flavor)) error-p)) (setq fls (nconc fls (nreverse (loop for fl in (flavor-includes flavor-1) unless (or (member fl fls :test #'eq) (member fl other-components :test #'eq)) collect fl and do (push fl additions)))))) (values fls additions))) ;Mapping tables. ;Each mapping table relates a method-flavor to an instance-flavor. ;It maps several of the instance vars accessible from the method-flavor ;to slot positions in the instances of the instance flavor. ;Ths instance variables mapped are those in the (FLAVOR-MAPPED-INSTANCE-VARIABLES ...) ;of the method flavor. Those conprise all the instance variables actually ;referred to by compiled code of methods of the method flavor, ;except for ordered instance variables, which are not mapped at all. ;Note that "method-flavor" simply means a flavor on which a method has been defined ;and "instance-flavor" simply means a flavor which depends on the method-flavor ;and has been instantiated. ;Pointers to the mapping tables for one instance-flavor (and various method-flavors) ;are stored in an art-q-list array called ;(FLAVOR-COMPONENT-MAPPING-TABLE-VECTOR instance-flavor). ;But they are found thru an alist, (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST instance-flavor). ;The CDRs of alist elements are locatives into the vector. ;When a new method-flavor is seen to need a mapping table, ;the entire alist is recopied so it will be compact; ;and a previously unused slot in the vector is used. ;This way, we keep the alist maximally short and compact, ;while keeping the vector short but avoiding forwarding it ;unless the flavor gets recomposed with new mixins. ;Methods called by message passing get their mapping tables ;from the method hash table. ;Methods called from combined methods are given mapping tables ;by the combined method. This does not search the alist. ;Instead, the combined method looks in its own mapping table, ;in the array leader, to find the mapping table to supply for the ;method it is calling. ;Given a list (FLAVOR-NAME VAR-NAME), return the number of the slot ;in mapping tables from that flavor as the method flavor ;for the specified variable. ;If necessary, add this variable to the flavor's mapped variables ;and update all the flavor's mapping tables. ;Given instead a list (FLAVOR-NAME T COMPONENT-FLAVOR-NAME), ;we pass it on to FLAVOR-COMPONENT-FLAVOR-SELF-REF-INDEX. (defun flavor-var-self-ref-index (flavor-and-varname) ;; 4/19/85 DNG - Use COMPILATION-FLAVOR instead of GET. (let ((flavor (compilation-flavor (car flavor-and-varname)))) (or flavor (ferror () "Loading a method for flavor ~S which is not defined" (car flavor-and-varname))) (if (and (CDDR flavor-and-varname) (eq (second flavor-and-varname) t)) (flavor-component-flavor-self-ref-index flavor-and-varname) (let* ((varname (cadr flavor-and-varname)) (pos (position varname (the list (flavor-mapped-instance-variables flavor)) :test #'eq)) (opos (position varname (the list (flavor-unmapped-instance-variables flavor)) :test #'eq))) (cond (opos) ((and (eq (third flavor-and-varname) :unmapped) ;; Unmapped reference requested by COMPILER:TRY-REF-SELF (position varname (the list (flavor-all-instance-variables flavor)) :test #'eq))) (pos (dpb 1 %%self-ref-relocate-flag pos)) (t (setf (flavor-mapped-instance-variables flavor) (nconc (flavor-mapped-instance-variables flavor) (cons-in-area varname () working-storage-area))) (remake-mapping-tables flavor flavor) (dpb 1 %%self-ref-relocate-flag (position varname (the list (flavor-mapped-instance-variables flavor)) :test #'eq)))))))) ;Don't record evaluations of this function in QFASL files. (defprop flavor-var-self-ref-index t qfasl-dont-record) ;Given a list (FLAVOR-NAME T COMPONENT-FLAVOR-NAME), return the number of the slot ;in the array leader of a mapping table between any-flavor and FLAVOR-NAME ;which contains the locative to the ptr to the mapping table between ;any-flavor and COMPONENT-FLAVOR-NAME. Adds such an array leader slot if none yet. (defun flavor-component-flavor-self-ref-index (flavor-and-component-flavor-name) ;; 3/28/85 DNG - Use COMPILATION-FLAVOR instead of GET. (let* ((flavor (compilation-flavor (car flavor-and-component-flavor-name))) (component-flavor-name (caddr flavor-and-component-flavor-name)) (pos (position component-flavor-name (the list (flavor-mapped-component-flavors flavor)) :test #'eq))) (or pos (setq pos (progn (let ((default-cons-area background-cons-area)) ;; Note that the SETF does a PUTPROP which can cons. (setf (flavor-mapped-component-flavors flavor) (nconc (flavor-mapped-component-flavors flavor) (cons component-flavor-name ())))) (remake-mapping-tables flavor flavor) (position component-flavor-name (the list (flavor-mapped-component-flavors flavor)) :test #'eq)))) (dpb 1 %%self-ref-relocate-flag (dpb 1 %%self-ref-map-leader-flag (+ pos 3))))) (defun flavor-decode-self-ref-pointer (flavor-name pointer-number) "Decode the pointer field of a DTP-SELF-REF-POINTER. Assumes that it is used with flavor FLAVOR-NAME. Values are an instance variable name and NIL, or a component flavor name and T." (declare (values instance-var-or-component-flavor t-if-component-flavor)) (let ((flavor (get flavor-name 'flavor))) (cond ((null flavor) nil) ((ldb-test %%self-ref-map-leader-flag pointer-number) (values (nth (- (ldb %%self-ref-index pointer-number) 3) (flavor-mapped-component-flavors flavor)) t)) ((ldb-test %%self-ref-relocate-flag pointer-number) (nth (ldb %%self-ref-index pointer-number) (flavor-mapped-instance-variables flavor))) ((nth (ldb %%self-ref-index pointer-number) (flavor-unmapped-instance-variables flavor))) (t (nth (ldb %%self-ref-index pointer-number) (flavor-all-instance-variables flavor)))))) (defun flavor-inherit-mapping-table-flavors (fl) "Return a list of component flavor objects of FL from which FL can inherit mapping tables." (if (symbolp fl) (setq fl (get fl 'flavor))) (loop for fn1 in (cdr (flavor-depends-on-all fl)) as fl1 = (get fn1 'flavor) when (and (flavor-all-instance-variables fl1) (flavor-method-hash-table fl1) (do ((vs (flavor-all-instance-variables fl) (cdr vs)) (v1s (flavor-all-instance-variables fl1) (cdr v1s))) ((null v1s) t) (if (or (null vs) (neq (car vs) (car v1s))) (return ())))) collect fl1)) ;Update the mapping tables from method-flavor to instance-flavor ;and all flavors that depend on instance-flavor. ;Don't create any new mapping tables; only update those that exist. ;We take short cuts that assume that this is being done because a new mapped instance var ;or mapped component-flavor has been added, and that the goal is to make the maps longer. (defun remake-mapping-tables (instance-flavor method-flavor) ;; 3/28/85 DNG - Use COMPILATION-FLAVOR instead of GET. (and instance-flavor (let ((loc (assoc (flavor-name method-flavor) (flavor-component-mapping-table-alist instance-flavor) :test #'eq))) ;; If this instance-flavor's mapping table already maps as many variables ;; as need to be mapped, it must have been reached by a different path, ;; so don't bother with it or its dependants again. (if (and (cddr loc) (eq (array-leader (cddr loc) 0) (length (flavor-mapped-instance-variables method-flavor))) (= (array-leader-length (cddr loc)) (+ 3 (length (flavor-mapped-component-flavors method-flavor))))) () (progn (cond ((cddr loc) (let ((omap (cddr loc))) (setf (cddr loc) (update-mapping-table instance-flavor method-flavor (cddr loc))) (and (arrayp (flavor-method-hash-table instance-flavor)) (replace-through-hash-table (flavor-method-hash-table instance-flavor) omap (cddr loc)))))) (dolist (subflavor (flavor-depended-on-by instance-flavor)) (remake-mapping-tables (if (symbolp subflavor) (compilation-flavor subflavor) subflavor) method-flavor))))))) (defun replace-through-hash-table (hash-table old new) (let ((len (array-total-size hash-table))) (do ((i 2 (+ 3 i))) ((>= i len)) (if (eq (aref hash-table i) old) (setf (aref hash-table i) new))))) (defvar trace-mapping-table-growth () "T => print a message every time an existing flavor mapping table is made bigger.") ;Construct a new map for a pair of flavors, or reuse an old map if it is long enough. ;If we construct a new map, we make it a little bigger than necessary ;so that if only a couple more mapped vars are needed we can reuse it. (defun update-mapping-table (instance-flavor method-flavor &optional old-map) ;; 3/28/85 DNG - Use COMPILATION-FLAVOR instead of GET. (if (symbolp method-flavor) (setq method-flavor (compilation-flavor method-flavor))) (let ((mapvars (flavor-mapped-instance-variables method-flavor)) (mapflavs (flavor-mapped-component-flavors method-flavor)) (ivars (flavor-all-instance-variables instance-flavor))) (let ((map old-map)) (when (or (null map) (> (length mapvars) (array-total-size map)) (> (length mapflavs) (- (array-leader-length map) 3))) (and map trace-mapping-table-growth (format t "~&Growing mapping table for method flavor ~S, instance flavor ~S." (flavor-name method-flavor) (if (symbolp instance-flavor) instance-flavor (flavor-name instance-flavor)))) (setq map (make-array (+ 4 (length mapvars)) :type art-16b :leader-length (+ 3 (length mapflavs)) :area permanent-storage-area))) ;; Fill in the extra leader slots with mapping table locatives ;; for this instance flavor and the method flavor's mapped component-flavors ;; as method flavors. (do ((i 3 (1+ i)) (flavs mapflavs (cdr flavs))) ((null flavs)) (setf (array-leader map i) (get-mapping-table-location instance-flavor (car flavs)))) ;; Fill in the array elements of the mapping table ;; with indices in the instance flavor of the method flavor's mapped variables. (do ((i 0 (1+ i)) (vars mapvars (cdr vars))) ((null vars) (setf (array-leader map 0) i)) (setf (aref map i) (or (position (car vars) (the list ivars) :test #'eq) #XFFFFFF))) ;; The 7771 or #XFFFFFFis recognize by the microcode, when somebody tries to get that offset ;; into an instance the microcode traps (> #XFFFFFE) (setf (array-leader map 1) method-flavor) (setf (array-leader map 2) instance-flavor) map))) (defvar *create-mapping-tables* () "T while method-composing; create any mapping table a method wants to use.") ;Get a cell whose CDR is or will be the mapping table for a pair of flavors. ;If the instance flavor has been instantiated, we also create a mapping table ;if there isn't one. Otherwise, we just make a slot in the alist and leave it nil. ;The mapping tables will be created when the flavor is instantiated. (defun get-mapping-table-location (instance-flavor method-flavor) (if (symbolp instance-flavor) (setq instance-flavor (compilation-flavor instance-flavor ))) (or (symbolp method-flavor) (setq method-flavor (flavor-name method-flavor))) (or (cdr (assoc method-flavor (flavor-component-mapping-table-alist instance-flavor) :test #'eq)) ;; If the method-flavor is no longer a component of the instance-flavor, ;; it must be someone's mapped-component-flavor that is no longer used. ;; Just ignore it. (and (member method-flavor (flavor-depends-on-all instance-flavor) :test #'eq) ;; This method flavor is not in the alist, so make a slot for its mapping table. (let ((vector (flavor-component-mapping-table-vector instance-flavor)) vector-index) ;; Make sure vector exists and is long enough for all our component flavors. (let ((len (length (flavor-depends-on-all instance-flavor)))) (or vector (setf (flavor-component-mapping-table-vector instance-flavor) (setq vector (make-array len :type 'art-q-list :area permanent-storage-area :leader-list '(0))))) (if (or (> len (array-total-size vector)) (= (array-active-length vector) (array-total-size vector))) (adjust-array vector (max len (1+ (length vector)))))) ;; Add a slot for the new mapping table to the vector. (setq vector-index (vector-push () vector)) ;; Add an entry to the alist, pointing at newly added vector slot. (let ((default-cons-area background-cons-area)) (push (cons method-flavor (locf (aref vector vector-index))) (flavor-component-mapping-table-alist instance-flavor))) ;; Now fill in the slot in the vector with a mapping table ;; if the instance flavor may have been instantiated already. (and (or *create-mapping-tables* (flavor-method-hash-table instance-flavor)) (setf (aref vector vector-index) (update-mapping-table instance-flavor method-flavor))) (locf (aref vector vector-index)))))) (defun fef-flavor-name (fef) "Return the flavor which the compiled function FEF assumes SELF is an instance of." (and (typep fef 'compiled-function) (not (zerop (%p-ldb %%FEF-HEADER-Self-Mapping-Table fef))) (%p-contents-offset fef (if (= (%p-ldb si::%%fef-header-call-type fef) %fef-call-long) %fef-second-optional-word %fef-first-optional-word)))) (defun get-handler-mapping-table (flavor handler definition-location) (or (cdr (get-mapping-table-location flavor (or (and (= dtp-symbol (%p-data-type definition-location)) (fboundp (car definition-location)) (fef-flavor-name (symbol-function (car definition-location)))) (cadr handler)))) (ferror () "No mapping table for method ~S in flavor ~S" handler flavor))) (defvar total-inherited-mapping-table-size 0) ;Update all the mapping tables for INSTANCE-FLAVOR and various method-flavors. ;Creates a mapping table for each slot which is empty. ;If REPLACE-ALL is set, creates a new mapping table for every slot, ;throwing away the old mapping tables. That is used when a flavor has ;changed incompatibly. (defun make-component-mapping-tables (instance-flavor &optional replace-all &aux (inherit-mapping-table-flavors (flavor-inherit-mapping-table-flavors instance-flavor))) ;; Make sure vector exists and is long enough for all our component flavors. (let ((len (length (flavor-depends-on-all instance-flavor)))) (or (flavor-component-mapping-table-vector instance-flavor) (setf (flavor-component-mapping-table-vector instance-flavor) (make-array len :type 'art-q-list :area permanent-storage-area :leader-list '(0)))) (if (> len (array-total-size (flavor-component-mapping-table-vector instance-flavor))) (adjust-array (flavor-component-mapping-table-vector instance-flavor) len))) ;; Make sure all components are in the vector and alist. (dolist (mf (flavor-depends-on-all instance-flavor)) (get-mapping-table-location instance-flavor mf)) ;; Copy the alist now so it is compact, if it has changed. ;; It is now copied by LINEARIZE-FLAVOR-PLISTS after full-gc. ; (OR (EQ OALIST (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST INSTANCE-FLAVOR)) ; (SETF (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST INSTANCE-FLAVOR) ; (COPYALIST (FLAVOR-COMPONENT-MAPPING-TABLE-ALIST INSTANCE-FLAVOR) ; PERMANENT-STORAGE-AREA))) ;; Make sure all mapping tables exist and are up to date. (dolist (elt (flavor-component-mapping-table-alist instance-flavor)) (when (or replace-all (null (cddr elt))) ;; Inherit mapping tables when possible. (dolist (ifl inherit-mapping-table-flavors) (when (member (car elt) (flavor-depends-on-all ifl) :test #'eq) (setf (cddr elt) (car (get-mapping-table-location ifl (car elt)))) (incf total-inherited-mapping-table-size (%structure-total-size (cddr elt))))) (setf (cddr elt) (update-mapping-table instance-flavor (car elt)))))) ;Once the flavor-combination stuff has been done, do the method-combination stuff. ;The above function usually only gets called once, but this function gets called ;when a new method is added. ;Specify SINGLE-OPERATION to do this for just one operation, for incremental update. ;This function should not be called for a single operation until it has ;been called at least once to do all operations. ;NOTE WELL: If a meth is in the method-table at all, it is considered to be defined ; for purposes of compose-method-combination. Thus merely putprop'ing a method, ; or calling flavor-notice-method, will make the flavor think that method exists ; when it is next composed. This is necessary to make compile-flavor-methods work. ; (Putprop must create the meth because loading does putprop before fdefine.) (defun compose-method-combination (fl &optional (single-operation nil) &aux tem magic-list order msg elem handlers ffl pl (default-cons-area *flavor-area*)) (if (flavor-get fl :alias-flavor) (ferror () "Attempt to compose methods of ~S, an alias flavor." (flavor-name fl))) ;; If we are doing wholesale method composition, ;; compose the flavor bindings list also. ;; This way it is done often enough, but not at every defmethod. (or single-operation *just-compiling* (flavor-get fl :abstract-flavor) (progn (compose-flavor-bindings fl) (compose-flavor-initializations fl))) ;; Look through all the flavors depended upon and collect the following: ;; A list of all the operations handled and all the methods for each, called MAGIC-LIST. ;; The default handler for unknown operations. ;; The declared order of entries in the select-method alist. ;; Also generate any automatically-created methods not already present. ;; MAGIC-LIST is roughly the same format as the flavor-method-table, see its comments. ;; Each magic-list entry is (message comb-type comb-order (type function-spec...)...) (do ((ffls (flavor-depends-on-all fl) (cdr ffls))) ((null ffls)) (setq ffl (compilation-flavor (car ffls)) pl (locf (flavor-plist ffl))) (cond ((not single-operation) (and (setq tem (get pl :select-method-order)) (setq order (nconc order (copy-list tem)))))) ;; Add data from flavor method-table to magic-list ;; But skip over combined methods, they are not relevant here (dolist (mte (flavor-method-table ffl)) (setq msg (car mte)) (cond ((or (not single-operation) (eq msg single-operation)) ;; Well, we're supposed to concern ourselves with this operation (setq elem (assoc msg magic-list :test #'eq));What we already know about it (cond ((dolist (meth (cdddr mte)) (or (eq (meth-method-type meth) :combined) (not (meth-definedp meth)) (return t))) ;; OK, this flavor really contributes to handling this operation (or elem (push (setq elem (list* msg () () ())) magic-list)) ;; For each non-combined method for this operation, add it to the front ;; of the magic-list element, thus they are in base-flavor-first order. (dolist (meth (cdddr mte)) (let ((type (meth-method-type meth))) (cond ((eq type :combined)) ((not (meth-definedp meth))) ((not (setq tem (assoc type (cdddr elem) :test #'eq))) (push (list type (meth-function-spec meth)) (cdddr elem))) ;; Don't let the same method get in twice (how could it?) ((not (member (meth-function-spec meth) (cdr tem) :test #'eq)) (push (meth-function-spec meth) (cdr tem)))))))) ;; Pick up method-combination declarations (and (cadr mte) (cadr elem);If both specify combination-type, check ;;;PHD 2/11/86 Fixed bug about some method-combinations being equal but ;;; not eq, changed neq to not equal . (or (neq (cadr mte) (cadr elem)) (not (equal (caddr mte) (caddr elem)))) (ferror () "Method-combination mismatch ~S-~S vs. ~S-~S, check your DEFFLAVOR's" (cadr mte) (caddr mte) (cadr elem) (caddr elem))) (cond ((cadr mte);Save combination-type when specified (or elem (push (setq elem (list* msg () () ())) magic-list)) (setf (cadr elem) (cadr mte)) (setf (caddr elem) (caddr mte)))))))) ;; This NREVERSE tends to put base-flavor methods last (setq magic-list (nreverse magic-list)) ;; Re-order the magic-list according to any declared required order (dolist (msg (nreverse order)) (and (setq tem (assoc msg magic-list :test #'eq)) (setq magic-list (cons tem (delete tem (the list magic-list) :count 1 :test #'eq))))) ;; Map over the magic-list. For each entry call the appropriate method-combining ;; routine, which will return a function spec for the handler to use for this operation. (dolist (mte magic-list) ;; Punt if there are no methods at all (just a method-combination declaration) (cond ((cdddr mte) ;; Process the :DEFAULT methods; if there are any untyped methods the ;; default methods go away, otherwise they become untyped methods. (and (setq tem (assoc :default (cdddr mte) :test #'eq)) (if (assoc () (cdddr mte) :test #'eq) (setf (cdddr mte) (delete tem (the list (cdddr mte)) :test #'eq)) (rplaca tem ()))) (or (setq tem (get (or (cadr mte) :daemon) 'method-combination)) (ferror () "~S unknown method combination type for ~S operation" (cadr mte) (car mte))) (push (funcall tem fl mte) handlers)) (t (setq magic-list (delete mte (the list magic-list) :count 1 :test #'eq))))) (or *just-compiling* (flavor-get fl :abstract-flavor) (progn ;; Make sure that the required variables and methods are present. (unless single-operation (verify-required-flavors-methods-and-ivars fl magic-list)) ;; If the flavor does not have mapping tables yet, make some. (make-component-mapping-tables fl))) ;; Get back into declared order. We now have a list of function specs for handlers. (setq handlers (nreverse handlers)) (cond (*just-compiling*);If just compiling, don't affect hash table. ((flavor-get fl :abstract-flavor) (setf (flavor-method-hash-table fl) t)) (single-operation ;; If doing SINGLE-OPERATION, put it into the hash table. ;; If the operation is becoming defined and wasn't, or vice versa, ;; must recompute the which-operations list. (without-interrupts;SWAPHASH or REMHASH might rehash. (cond ((null handlers);Deleting method ;; Remove entry from the which-operations list. (and (member single-operation (flavor-which-operations fl) :test #'eq) (setf (flavor-which-operations fl) (delete single-operation (the list (flavor-which-operations fl)) :test #'eq))) (remhash single-operation (flavor-method-hash-table fl))) (t ;; Add an entry to the which-operations list. (unless (member single-operation (flavor-which-operations fl) :test #'eq) (when (flavor-which-operations fl) (setf (flavor-which-operations fl) (copy-list (cons single-operation (flavor-which-operations fl)))))) ;; Add one to the hash table. (let (def) (swaphash single-operation (setq def (fdefinition-location (car handlers))) (flavor-method-hash-table fl) (get-handler-mapping-table fl (car handlers) def)))))) (setf (flavor-method-hash-table fl) (FOLLOW-STRUCTURE-FORWARDING (flavor-method-hash-table fl)))) ;; Working on all operations at once. (t (let ((ht (make-flavor-hash-array permanent-storage-area (1+ (ceiling (/ (length magic-list) 0.8s0))))) def) (do ((handlers handlers (cdr handlers)) (*create-mapping-tables* t) (ml magic-list (cdr ml))) ((null ml)) (puthash-array (caar ml) (setq def (fdefinition-location (car handlers))) ht (get-handler-mapping-table fl (car handlers) def))) (setf (flavor-method-hash-table fl) ht) (setf (flavor-which-operations fl) ());This will have to be recomputed (let ((hash-instance (flavor-method-hash-table fl))) ;; If a hash-instance exists, make sure SEND will use the latest ;; version of the hash array of that hash instance. (when hash-instance (setf (flavor-method-hash-table fl) (follow-structure-forwarding hash-instance ))))))) (unless (or *just-compiling* (flavor-which-operations fl) (flavor-get fl :abstract-flavor)) ;; Make the :WHICH-OPERATIONS list. (let ((ht (flavor-method-hash-table fl)) list) (declare (special list)) (maphash-array #'(lambda (op &rest ignore) (push op list)) ht) (setq list (sort list 'alphalessp)) (unless (equal list (flavor-which-operations fl)) (setf (flavor-which-operations fl) (copy-list list))))) ()) (defun flavor-all-inheritable-methods (flavor-name operation &aux fl) "Return a list of function specs of all methods used by OPERATION on FLAVOR-NAME. This may include some that are shadowed by others in the list." (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "a flavor name") (do ((ffls (flavor-depends-on-all fl) (cdr ffls)) mte list) ((null ffls) (nreverse list)) (setq mte (assoc operation (flavor-method-table (compilation-flavor (car ffls))) :test #'eq)) (when mte ;; For each non-combined method for this operation, add it to the front ;; of the list, thus they are in base-flavor-first order. (dolist (meth (cdddr mte)) (let ((type (meth-method-type meth))) (cond ((eq type :combined)) ((not (meth-definedp meth))) (t (push (meth-function-spec meth) list)))))))) (defun verify-required-flavors-methods-and-ivars (fl magic-list) (do ((ffls (flavor-depends-on-all fl) (cdr ffls)) (missing-methods nil) (missing-instance-variables nil) (missing-flavors nil) (requiring-flavor-alist nil)) ((null ffls) (and (or missing-instance-variables missing-methods missing-flavors) (ferror () "Flavor ~S is missing ~ ~:[~2*~;instance variable~P ~{~S~^, ~} ~]~ ~:[~3*~;~:[~;and ~]method~P ~{~S~^, ~}~]~ ~:[~3*~;~:[~;and ~]component flavor~P ~{~S~^, ~}~] Requiring Flavor alist: ~S" (flavor-name fl) missing-instance-variables (length missing-instance-variables) missing-instance-variables missing-methods missing-instance-variables (length missing-methods) missing-methods missing-flavors (or missing-instance-variables missing-methods) (length missing-flavors) missing-flavors requiring-flavor-alist))) (let ((pl (locf (flavor-plist (get (car ffls) 'flavor))))) (dolist (reqm (get pl :required-methods)) (or (assoc reqm magic-list :test #'eq) (member reqm missing-methods :test #'eq) (progn (push reqm missing-methods) (push (cons (first ffls) reqm) requiring-flavor-alist)))) (dolist (reqv (get pl :required-instance-variables)) (or (member reqv (flavor-all-instance-variables fl) :test #'eq) (member reqv missing-instance-variables :test #'eq) (progn (push reqv missing-instance-variables) (push (cons (first ffls) reqv) requiring-flavor-alist)))) (dolist (reqf (get pl :required-flavors)) (or (member reqf (flavor-depends-on-all fl) :test #'eq) (member reqf missing-flavors :test #'eq) (progn (push reqf missing-flavors) (push (cons (first ffls) reqf) requiring-flavor-alist))))))) (defun flavor-method-alist (fl) "Return an alist of operations and their handlers, for flavor FL." (if (symbolp fl) (setq fl (compilation-flavor fl))) (if fl (let ((ht (flavor-method-hash-table fl)) alist) (and (arrayp ht) (maphash #'(lambda (op meth-locative &rest ignore) (push (cons op (car meth-locative)) alist)) (flavor-method-hash-table fl))) alist))) ;; Make the instance-variable getting and setting methods (defprop compose-automatic-methods t qfasl-dont-record) ;;;??? This needs to get changed so that the methods are always compiled ;;; once most files are compiled so that this is not called at load time. ;;AB 7-15-87. Removed unused AUX var to clean up compiler warning. (defun compose-automatic-methods (fl) ;;phd 7/8/86 changed the generation of accessor method so that if the instance is settable ;; the accessor method is of type :default instead of untyped. This allows the user to ;; provide his/her own accessor method. ;;Phd 1/2/87 Previous change turned to be wrong, because inherited method will ;; override the accessor method. ;; Phd 10/4/85 add new flag to allow more that 120 settable instance variables. ;; This will prevent the generation of :case :set methods for the instance variables. ;; Avoid lossage on PROPERTY-LIST-MIXIN while reading this file into the cold load. (when (fboundp 'compile-at-appropriate-time) (dolist (v (flavor-gettable-instance-variables fl)) (let* ((vv (corresponding-keyword v)) (meth `(:method ,(flavor-name fl) ,vv))) (if (or (not (flavor-notice-method meth)) *just-compiling*) (compile-at-appropriate-time fl meth `(named-lambda (,meth) (ignore) (declare (function-parent ,(flavor-name fl) defflavor) (:self-flavor ,(flavor-name fl))) ,v)) (record-source-file-name meth)))) (dolist (v (flavor-settable-instance-variables fl)) (let* ((sv (intern1 (string-append "SET-" (symbol-name v)) pkg-keyword-package)) (meth `(:method ,(flavor-name fl) ,sv))) (if (or (not (flavor-notice-method meth)) *just-compiling*) (compile-at-appropriate-time fl meth `(named-lambda (,meth) (ignore .newvalue.) (declare (function-parent ,(flavor-name fl) defflavor) (:self-flavor ,(flavor-name fl))) (setq ,v .newvalue.))) (record-source-file-name meth))) (when *flavor-enable-case-set-methods* (let* ((vv (corresponding-keyword v)) (meth `(:method ,(flavor-name fl) :case :set ,vv))) (if (or (not (flavor-notice-method meth)) *just-compiling*) (compile-at-appropriate-time fl meth `(named-lambda (,meth) (ignore ignore .newvalue.) (declare (function-parent ,(flavor-name fl) defflavor) (:self-flavor ,(flavor-name fl))) (setq ,v .newvalue.))) (record-source-file-name meth))))))) ;INTERN but always return-storage the print-name argument (defun intern1 (pname &optional (pkg *package*)) (prog1 (intern pname pkg) (return-storage (prog1 pname (setq pname ()))))) ;Given a symbol return the corresponding one in the keyword package (defun corresponding-keyword (symbol) (intern (symbol-name symbol) pkg-keyword-package)) ;Make sure that the flavor bindings are up to date; ;see which instance variables are supposed to be special. ;We assume that the flavor has been composed. (defun compose-flavor-bindings (fl) (let ((fls (flavor-depends-on-all fl)) (specials (flavor-special-instance-variables fl))) (dolist (f fls) (setq f (compilation-flavor f )) (setq specials (union specials (flavor-special-instance-variables f) :test #'eq)) (cond ((flavor-all-instance-variables-special f) (or (flavor-depends-on-all f) (compose-flavor-combination f)) (setq specials (union (union specials (flavor-all-instance-variables f) :test #'eq) (flavor-additional-instance-variables f) :test #'eq))))) ;; Any instance variables which the user has declared special elsewhere ;; ought to be special. (dolist (v (flavor-all-instance-variables fl)) (cond ((and (not (member v specials :test #'eq)) (fboundp 'compiler::specialp) (compiler::specialp v)) (format *error-output* "~&Instance variable ~S of ~S being made special because that variable is globally special~%" v (flavor-name fl)) (push v specials)))) ;; Tell microcode about the instance variables (let ((b (mapcar #'(lambda (v) (if (member v specials :test #'eq) (locf (symbol-value v)))) (flavor-all-instance-variables fl)))) (do ((bb b (cdr bb)) (prev (locf b) bb)) ((null bb)) (if (null (car bb)) (do ((bbb bb (cdr bbb)) (i 0 (1+ i))) ((car bbb) (rplaca bb i) (rplacd bb bbb)) (if (null bbb) (progn (rplacd prev ()) (rplacd bb ()) (return ())))))) (setf (flavor-bindings fl) (copy-list b))))) ;Figure out the information needed to instantiate a flavor quickly. ;We store these three properties on the flavor: ;INSTANCE-VARIABLE-INITIALIZATIONS - alist of (ivar-index . init-form) ;REMAINING-DEFAULT-PLIST - a default plist from which kwds that init ivars have been removed. ;ALL-INITTABLE-INSTANCE-VARIABLES - a list parallel to FLAVOR-ALL-INSTANCE-VARIABLES ; which has either the keyword to init with or NIL. ;REMAINING-INIT-KEYWORDS - the init keywords that are handled and dont just init ivars. ;We also set up the FLAVOR-DEFAULT-HANDLER of the flavor. (defun compose-flavor-initializations (fl &aux alist remaining-default-plist all-inittable-ivars area-function required-init-keywords remaining-init-keywords unhandled-init-keywords) (setq all-inittable-ivars (make-list (length (flavor-all-instance-variables fl)) :area (if *just-compiling* default-cons-area background-cons-area))) ;; First make the mask saying which ivars can be initted by init kywords. (dolist (ffl (flavor-depends-on-all fl)) (let ((ffl (compilation-flavor ffl))) (or area-function (setq area-function (flavor-get ffl :instance-area-function))) (setq required-init-keywords (union required-init-keywords (flavor-get ffl :required-init-keywords) :test #'eq)) (or (flavor-default-handler fl) (setf (flavor-default-handler fl) (getf (flavor-plist ffl) :default-handler))) (dolist (iiv (flavor-inittable-instance-variables ffl)) (let ((index (position (cdr iiv) (the list (flavor-all-instance-variables fl)) :test #'eq))) (and index (setf (nth index all-inittable-ivars) (car iiv))))))) (setq remaining-init-keywords (mapcan #'(lambda (x) (if (member x all-inittable-ivars :test #'eq) () (list x))) (flavor-allowed-init-keywords fl))); (subset-not #'MEMQ (FLAVOR-ALLOWED-INIT-KEYWORDS FL) (CIRCULAR-LIST ALL-INITTABLE-IVARS))) (pushnew :allow-other-keys remaining-init-keywords) (setf (flavor-remaining-init-keywords fl) remaining-init-keywords) ;; Then look at all the default init plists, for anything there ;; that initializes an instance variable. If it does, make an entry on ALIST. ;; Any that doesn't initialize a variable, put on the "remaining" list. (dolist (ffl (flavor-depends-on-all fl)) (setq ffl (compilation-flavor ffl)) (do ((l (getf (flavor-plist ffl) :default-init-plist) (cddr l))) ((null l)) (let* ((keyword (car l)) (arg (cadr l)) (index (position keyword (the list all-inittable-ivars) :test #'eq))) ;; Remove this keyword from the list of required ones, ;; since it is cannot ever be missing. (setq required-init-keywords (delete keyword (the list required-init-keywords) :test #'eq)) (if index ;; This keyword initializes an instance variable, ;; so record an initialization of that variable if none found yet. (or (assoc index alist :test #'eq) (push (list index arg) alist)) ;; This keyword does not just initialize an instance variable. (progn (unless (getf remaining-default-plist keyword) (setf (getf remaining-default-plist keyword) arg)) (unless (member keyword remaining-init-keywords :test #'eq) (pushnew keyword unhandled-init-keywords))) ;;(IF (MEMQ KEYWORD (FLAVOR-REMAINING-INIT-KEYWORDS FL)) ;; (OR (GET (LOCF REMAINING-DEFAULT-PLIST) KEYWORD) ;; (PUTPROP (LOCF REMAINING-DEFAULT-PLIST) ARG KEYWORD)) ;; (FERROR NIL "The flavor ~S has keyword ~S in its default init plist, but doesn't handle it" (FLAVOR-NAME FL) KEYWORD)) )))) (setf (flavor-unhandled-init-keywords fl) unhandled-init-keywords) ;; Then, look for default values provided in list of instance vars. (dolist (ffl (flavor-depends-on-all fl)) (setq ffl (compilation-flavor ffl)) (dolist (v (flavor-local-instance-variables ffl)) (and (not (atom v)) ;; When we find one, put it in if there is no init for that variable yet. (let ((index (position (car v) (the list (flavor-all-instance-variables fl)) :test #'eq))) (and (not (assoc index alist :test #'eq)) (push (list index (cadr v)) alist)))))) (if area-function (setf (getf (flavor-plist fl) 'instance-area-function) area-function) (remprop (locf (flavor-plist fl)) 'instance-area-function)) (if required-init-keywords (setf (getf (flavor-plist fl) 'required-init-keywords) required-init-keywords) (remprop (locf (flavor-plist fl)) 'required-init-keywords)) (setf (flavor-instance-variable-initializations fl) alist) (setf (flavor-remaining-default-plist fl) remaining-default-plist) (setf (flavor-all-inittable-instance-variables fl) all-inittable-ivars)) ; Method-combination functions. Found on the SI:METHOD-COMBINATION property ; of the combination-type. These are passed the flavor structure, and the ; magic-list entry, and must return the function-spec for the handler ; to go into the select-method, defining any necessary functions. ; This function interprets combination-type-arg, ; which for many combination-types is either :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST. ; :DAEMON combination ; The primary method is the outermost untyped-method (or :DEFAULT). ; The :BEFORE methods are called base-flavor-last, the :AFTER methods are called ; base-flavor-first. An important optimization is not to generate a combined-method ; if there is only a primary method. You are allowed to omit the primary method ; if there are any daemons (I'm not convinced this is really a good idea) in which ; case the method's returned value will be NIL. (defun (:property :daemon method-combination) (fl magic-list-entry) (let ((primary-method (car (get-certain-methods magic-list-entry () '(:before :after) t :base-flavor-last))) (before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last)) (after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first)) (wrappers-p (specially-combined-methods-present magic-list-entry))) ;; Remove shadowed primary methods from the magic-list-entry so that it won't look like ;; we depend on them (which could cause extraneous combined-method recompilation). (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq))) (and (cddr mle) (setf (cdr mle) (list primary-method)))) (or (and (not wrappers-p) (null before-methods) (null after-methods) primary-method) (have-combined-method fl magic-list-entry) (make-combined-method fl magic-list-entry (daemon-combination primary-method before-methods after-methods))))) (defun daemon-combination (primary-method before-methods after-methods &optional or-methods and-methods) (let ((inner-call (and primary-method (method-call primary-method)))) (and or-methods (setq inner-call `(or ,@(mapcar 'method-call or-methods) ,inner-call))) (and and-methods (setq inner-call `(and ,@(mapcar 'method-call and-methods) ,inner-call))) `(progn ,@(mapcar 'method-call before-methods) ,(if after-methods `(multiple-value-prog1 ,inner-call ,@(mapcar 'method-call after-methods)) ;; You are allowed to not have a primary method inner-call)))) (defun method-call (method) `(lexpr-funcall-with-mapping-table-internal (function ,method) (method-mapping-table ,method) .daemon-caller-args.)) ; :DAEMON-WITH-OVERRIDE combination ; This is the same as :DAEMON (the default), except that :OVERRIDE type methods ; are combined with the :BEFORE-primary-:AFTER methods in an OR. This allows ; overriding of the main methods function. For example, a combined method as follows ; might be generated: (OR (FOO-OVERRIDE-BAR-METHOD) (PROGN (FOO-BEFORE-BAR-METHOD))) (defun (:property :daemon-with-override method-combination) (fl magic-list-entry) (let ((primary-method (car (get-certain-methods magic-list-entry () '(:before :after :override) t :base-flavor-last))) (before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last)) (after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first)) (wrappers-p (specially-combined-methods-present magic-list-entry)) (override-methods (get-certain-methods magic-list-entry :override t t ()))) ;; Remove shadowed primary methods from the magic-list-entry so that it won't look like ;; we depend on them (which could cause extraneous combined-method recompilation). (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq))) (and (cddr mle) (setf (cdr mle) (list primary-method)))) (or (and (not wrappers-p) (null before-methods) (null after-methods) (null override-methods) primary-method) (have-combined-method fl magic-list-entry) (make-combined-method fl magic-list-entry `(or ,@(mapcar 'method-call override-methods) ,(daemon-combination primary-method before-methods after-methods)))))) ; :DAEMON-WITH-OR combination ; This is the same as :DAEMON (the default), except that :OR type methods ; are combined with the primary methods inside an OR, and used in place of ; the primary method in :DAEMON type combination. ; For example, the following combined method might be generated: ; (PROGN (FOO-BEFORE-BAR-METHOD) ; (OR (FOO-OR-BAR-METHOD) ; (BAZ-OR-BAR-METHOD) ; (MULTIPLE-VALUE-PROG1 ; (BUZZ-PRIMARY-METHOD) ; (FOO-AFTER-BAR-METHOD))) (defun (:property :daemon-with-or method-combination) (fl magic-list-entry) (let ((primary-method (car (get-certain-methods magic-list-entry () '(:before :after :or) t :base-flavor-last))) (before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last)) (after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first)) (wrappers-p (specially-combined-methods-present magic-list-entry)) (or-methods (get-certain-methods magic-list-entry :or t t ()))) ;; Remove shadowed primary methods from the magic-list-entry so that it won't look like ;; we depend on them (which could cause extraneous combined-method recompilation). (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq))) (and (cddr mle) (setf (cdr mle) (list primary-method)))) (or (and (not wrappers-p) (null before-methods) (null after-methods) (null or-methods) primary-method) (have-combined-method fl magic-list-entry) (make-combined-method fl magic-list-entry (daemon-combination primary-method before-methods after-methods or-methods))))) ; :DAEMON-WITH-AND combination ; This is the same as :DAEMON (the default), except that :AND type methods ; are combined with the primary methods inside an AND, and used in place of ; the primary method in :DAEMON type combination. ; For example, the following combined method might be generated: ; (PROGN (FOO-BEFORE-BAR-METHOD) ; (AND (FOO-AND-BAR-METHOD) ; (BAZ-AND-BAR-METHOD) ; (MULTIPLE-VALUE-PROG1 ; (BUZZ-PRIMARY-METHOD) ; (FOO-AFTER-BAR-METHOD))) (defun (:property :daemon-with-and method-combination) (fl magic-list-entry) (let ((primary-method (car (get-certain-methods magic-list-entry () '(:before :after :and) t :base-flavor-last))) (before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last)) (after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first)) (wrappers-p (specially-combined-methods-present magic-list-entry)) (and-methods (get-certain-methods magic-list-entry :and t t ()))) ;; Remove shadowed primary methods from the magic-list-entry so that it won't look like ;; we depend on them (which could cause extraneous combined-method recompilation). (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq))) (and (cddr mle) (setf (cdr mle) (list primary-method)))) (or (and (not wrappers-p) (null before-methods) (null after-methods) (null and-methods) primary-method) (have-combined-method fl magic-list-entry) (make-combined-method fl magic-list-entry (daemon-combination primary-method before-methods after-methods () and-methods))))) ; :LIST combination ; No typed-methods allowed. Returns a list of the results of all the methods. ; There will always be a combined-method, even if only one method to be called. (defun (:property :list method-combination) (fl magic-list-entry) (or (have-combined-method fl magic-list-entry) (make-combined-method fl magic-list-entry `(list . ,(mapcar 'method-call (append (get-certain-methods magic-list-entry :list '(nil) t ()) (get-certain-methods magic-list-entry () '(:list) () ()))))))) ; :INVERSE-LIST combination ; No typed-methods allowed. Apply each method to an element of the list. Given ; the result of a :LIST-combined method with the same ordering, and corresponding ; method definitions, the result that emerged from each component flavor gets handed ; back to that same flavor. The combined-method returns no particular value. (defun (:property :inverse-list method-combination) (fl magic-list-entry) (or (have-combined-method fl magic-list-entry) (make-combined-method fl magic-list-entry `(let ((.foo. (cadr .daemon-caller-args.))) ,@(do ((ml (append (get-certain-methods magic-list-entry :inverse-list '(nil) t ()) (get-certain-methods magic-list-entry () '(:inverse-list) () ())) (cdr ml)) (r nil)) ((null ml) (nreverse r)) (push `(funcall-with-mapping-table-internal (function ,(car ml)) (method-mapping-table ,(car ml)) (car .daemon-caller-args.) (car .foo.)) r) (and (cdr ml) (push '(setq .foo. (cdr .foo.)) r))))))) ; Combination types PROGN, AND, OR, MAX, MIN, +, APPEND, NCONC ; These just call all their typed methods then the untyped methods, ; inside the indicated special form or function. ; As an optimization, if there is only one method it is simply called. (defprop :progn simple-method-combination method-combination) (defprop :and simple-method-combination method-combination) (defprop :or simple-method-combination method-combination) (defprop :max simple-method-combination method-combination) (defprop :min simple-method-combination method-combination) (defprop :+ simple-method-combination method-combination) (defprop :append simple-method-combination method-combination) (defprop :nconc simple-method-combination method-combination) (defprop :progn progn simple-method-combination) (defprop :and and simple-method-combination) (defprop :or or simple-method-combination) (defprop :max max simple-method-combination) (defprop :min min simple-method-combination) (defprop :+ + simple-method-combination) (defprop :append append simple-method-combination) (defprop :nconc nconc simple-method-combination) ;;PHD 12/28/86 Fixed bug, a primary method is no longer necessary. ;;This allows for better compatibility with Symbolics. (defun simple-method-combination (fl magic-list-entry) (let ((methods (append (get-certain-methods magic-list-entry (cadr magic-list-entry) '(nil) t ()) (get-certain-methods magic-list-entry () (list (cadr magic-list-entry)) t ()))) (wrappers-p (specially-combined-methods-present magic-list-entry))) (or (and (not wrappers-p) (null (cdr methods)) (car methods)) (have-combined-method fl magic-list-entry) (make-combined-method fl magic-list-entry (cons (get (cadr magic-list-entry) 'simple-method-combination) (mapcar 'method-call methods)))))) (defun (:property :case method-combination) (fl magic-list-entry) ;; 9/16/85 DNG - Invoke CASE-METHOD-DEFAULT-HANDLER with FUNCALL instead ;; of LEXPR-FUNCALL to allow combined method integration. ;; 4/10/89 JLM - modified delete mle to setf the magic-list-entry. This is safer. (let* ((primary-method (car (get-certain-methods magic-list-entry () '(:case :or :otherwise :before :after) t :base-flavor-last))) (otherwise-method (or (car (get-certain-methods magic-list-entry :otherwise t t :base-flavor-last)) primary-method)) (before-methods (get-certain-methods magic-list-entry :before t t :base-flavor-last)) (after-methods (get-certain-methods magic-list-entry :after t t :base-flavor-first)) (or-methods (get-certain-methods magic-list-entry :or t t :base-flavor-last)) (methods (get-certain-methods magic-list-entry :case t t ()))) ;; Remove shadowed :otherwise methods from the magic-list-entry so that it won't look like ;; we depend on them (which could cause extraneous combined-method recompilation). (let ((mle (assoc :otherwise (cdddr magic-list-entry) :test #'eq))) (and (cddr mle) (setf (cdr mle) (list otherwise-method)))) ;; Remove shadowed primary methods too. (let ((mle (assoc () (cdddr magic-list-entry) :test #'eq))) (if (eq otherwise-method primary-method) (and (cddr mle) (setf (cdr mle) (list primary-method))) ;; If there is a :OTHERWISE method, all the primary ones are shadowed. (and mle (setf magic-list-entry (delete mle (the list magic-list-entry) :test #'eq))))) ;;; jlm 4/10/89 (or (have-combined-method fl magic-list-entry) (make-combined-method fl magic-list-entry (let ((inner-call `(progn ,@(mapcar 'method-call before-methods) (case (cadr .daemon-caller-args.) ,@(mapcar #'(lambda (method) `(,(fifth method) ,(method-call method))) methods) ((:get-handler-for :operation-handled-p :case-documentation) (funcall 'case-method-default-handler ',(flavor-name fl) ',(car magic-list-entry) ',methods (cadr .daemon-caller-args.) (caddr .daemon-caller-args.))) (:which-operations ',(mapcar #'(lambda (x) (car (cddddr x))) methods)) (t (or ,@(mapcar 'method-call or-methods) ,(and otherwise-method (method-call otherwise-method)))))))) ;; Copied from DAEMON-COMBINATION. (if after-methods `(multiple-value-prog1 ,inner-call ,@(mapcar 'method-call after-methods)) ;; No :AFTER methods, hair not required ;; You are allowed to not have a primary method inner-call)))))) (defun case-method-default-handler (flavor operation case-methods suboperation &rest args) flavor operation (dolist (cm case-methods) (if (eq (fifth cm) (car args)) (return (case suboperation (:get-handler-for (fdefinition cm)) (:operation-handled-p t) (:case-documentation (documentation cm))))))) ; :PASS-ON combination ; The values from the individual methods are the arguments to the next one; ; the values from the last method are the values returned by the combined ; method. Format is (:METHOD-COMBINATION (:PASS-ON (ORDERING . ARGLIST) . OPERATION-NAMES) ; ORDERING is :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST. ARGLIST can have &AUX and &OPTIONAL. (defun (:property :pass-on method-combination) (fl magic-list-entry) (let ((methods (append (get-certain-methods magic-list-entry :pass-on '(nil) t (caaddr magic-list-entry)) (get-certain-methods magic-list-entry () '(:pass-on) () (caaddr magic-list-entry)))) (arglist (cdaddr magic-list-entry)) args rest-arg-p) (do ((l arglist (cdr l)) (arg) (nl nil)) ((null l) (setq args (nreverse nl))) (setq arg (car l)) (and (consp arg) (setq arg (car arg))) (cond ((eq arg '&rest) (setq rest-arg-p t)) ((eq arg '&aux)) ((eq arg '&optional)) (t (push arg nl)))) (or (have-combined-method fl magic-list-entry) (make-combined-method fl magic-list-entry `(destructuring-bind (.operation. . ,arglist) .daemon-caller-args. ,@(do ((meths methods (cdr meths)) (list ()) (meth)) ((null meths) (nreverse list)) (setq meth `(,(if rest-arg-p 'lexpr-funcall-with-mapping-table-internal 'funcall-with-mapping-table-internal) (function ,(car meths)) (method-mapping-table ,(car meths)) .operation. ,@args)) (and (cdr meths) (setq meth (if (null (cdr args)) `(setq ,(car args) ,meth) `(multiple-value-setq ,args ,meth)))) (push meth list))))))) ; This function does most of the analysis of the magic-list-entry needed by ; method-combination functions, including most error checking. (defun get-certain-methods (magic-list-entry method-type other-methods-allowed no-methods-ok ordering-declaration &aux methods default-methods) "Perform analysis needed by method-combination functions. Returns a list of the method symbols for METHOD-TYPE extracted from MAGIC-LIST-ENTRY. This value is shared with the data structure, don't bash it. OTHER-METHODS-ALLOWED is a list of method types not to complain about (T = allow all). NO-METHODS-OK = NIL means to complain if the returned value would be NIL. ORDERING-DECLARATION is :BASE-FLAVOR-FIRST, :BASE-FLAVOR-LAST, or NIL meaning take one of those symbols from the MAGIC-LIST-ENTRY." ;; Find the methods of the desired type, and barf at any extraneous methods (dolist (x (cdddr magic-list-entry)) (cond ((eq (car x) method-type) (setq methods (cdr x))) ((assoc (car x) *specially-combined-method-types* :test #'eq)) ;Wrappers ignored at this level ((assoc (car x) *inverse-specially-combined-method-types* :test #'eq)) ;Wrappers ignored at this level ((eq (car x) :default) (setq default-methods (cdr x))) ((or (eq other-methods-allowed t) (member (car x) other-methods-allowed :test #'eq))) (t (ferror () "~S ~S method(s) illegal when using :~A method-combination" (car x) (car magic-list-entry) (or (cadr magic-list-entry) :daemon))))) ;; If we were looking for primary methods and there are none, use the :DEFAULT methods. (and (null method-type) (null methods) (setq methods default-methods)) ;; Complain if no methods supplied (and (null methods) (not no-methods-ok) (ferror () "No ~S ~S method(s) supplied to :~A method-combination" method-type (car magic-list-entry) (cadr magic-list-entry))) ;; Get methods into proper order. Don't use NREVERSE! (case (or ordering-declaration (setq ordering-declaration (caddr magic-list-entry))) (:base-flavor-first) (:base-flavor-last (setq methods (reverse methods))) (otherwise (ferror () "~S invalid method combination order; must be :BASE-FLAVOR-FIRST or :BASE-FLAVOR-LAST" ordering-declaration))) methods) (defun specially-combined-methods-present (mle) (loop for (type) in (cdddr mle) thereis (assoc type *specially-combined-method-types* :test #'eq))) ;; It is up to the caller to decide that a combined-method is called for at all. ;; If one is, this function decides whether it already exists OK or needs ;; to be recompiled. Returns the symbol for the combined method if it is ;; still valid, otherwise returns NIL. ;; Always canonicalizes the magic-list-entry, since it will be needed ;; canonicalized later. (defun have-combined-method (fl magic-list-entry &aux operation-name cms mte old-mle old-cms tem ometh) ;; Canonicalize the magic-list-entry so can compare with EQUAL (setf (cdddr magic-list-entry);Canonicalize before comparing (sort (cdddr magic-list-entry) #'string-lessp :key #'car));Sort by method-type (setq operation-name (car magic-list-entry)) ;; See if we can inherit one in either the current or future (being-compiled) world, ;; or use an existing combined method of this flavor. ;; Get the :COMBINED method function spec for this flavor. Note that if a suitable ;; one can be inherited, we will do so. ;; *USE-OLD-COMBINED-METHODS* controls whether we reuse an existing one for this ;; flavor; if we inherit one it will always be up-to-date already. ;; If all OK, return the function spec, else return NIL if new combined method must be made. (or (dolist (ffl (flavor-depends-on-all fl)) (let ((flavor1 (compilation-flavor ffl))) (and (or (neq flavor1 fl) *use-old-combined-methods*) ;; ^ Combined methods of this flavor can be used only if permitted. (setq mte (assoc operation-name (flavor-method-table flavor1) :test #'eq)) (setq ometh (meth-lookup (cdddr mte) :combined)) (meth-definedp ometh) ;; Check that *use-old-combined-methods* has not been expanded in line ;; in the combined method (null (and (neq t *use-old-combined-methods*) (meth-definition ometh) (member (meth-function-spec *use-old-combined-methods*) (get-debug-info-field (get-debug-info-struct (meth-definition ometh) t) :macros-expanded ) :test #'equal :key #'(lambda (x) (if (consp x) (car x) x))))) (or (meth-definition ometh) (and *just-compiling* (neq fl flavor1))) (setq cms (meth-function-spec ometh)) (equal magic-list-entry (setq tem (or (and (meth-definition ometh) (get-debug-info-field (get-debug-info-struct (meth-definition ometh) t) 'combined-method-derivation )) (getf (meth-plist ometh) 'combined-method-derivation)))) (or (not (fboundp 'compiler:expr-sxhash)) (dolist (elt (and (meth-definition ometh) (get-debug-info-field (get-debug-info-struct (meth-definition ometh) t) 'wrapper-sxhashes )) t);Return T if get thru whole list without mismatch. ;; If any wrappers were used, make sure their definitions now ;; match the definitions that were used to make the combined method. (unless (eql (compiler:expr-sxhash (car elt)) (cadr elt)) (return ()))));Return NIL if mismatch. (return cms)));Save first combined-method seen for tracing, it's the one we would ;have been most likely to inherit (or old-cms (null cms) (setq old-cms cms old-mle tem))) ;; Have to make a new combined method. Trace if desired, but return NIL in any case. (progn (cond (*flavor-compile-trace* (format *flavor-compile-trace* "~&~S's ~S combined method needs to be recompiled~%to come from " (flavor-name fl) operation-name) (print-combined-method-derivation magic-list-entry *flavor-compile-trace*) (cond (old-cms (format *flavor-compile-trace* "~%rather than using ~S which comes from " old-cms) (print-combined-method-derivation old-mle *flavor-compile-trace*)) ((not *use-old-combined-methods*) (format *flavor-compile-trace* "~%because of forced recompilation."))))) ()))) (defun print-combined-method-derivation (mle stream) (loop for (type . function-specs) in (cdddr mle) do (loop for function-spec in function-specs do (format stream "~S " function-spec))) (if (or (cadr mle) (caddr mle)) (format stream "with method-combination ~S ~S" (cadr mle) (caddr mle)))) (defun optimize-method-body-and-args (form) ;; 9/16/85 DNG - Original version, separated from MAKE-COMBINED-METHOD. (declare (values body arglist)) (let (ll) (let ((number-of-method-args nil) (minimum-number-of-method-args 0) (method-arg-list '(operation .method-arg-1. .method-arg-2. .method-arg-3.))) (declare (special number-of-method-args minimum-number-of-method-args method-arg-list)) (if (and *integrate-combined-methods* (catch 'out (setq form (substitute-funcall-in-expression form)))) (if (null number-of-method-args) (setq ll (append (firstn minimum-number-of-method-args method-arg-list) '(&rest ignore))) (setq ll method-arg-list)) (setq ll '(&rest .daemon-caller-args.)))) (values form ll))) ;; This function creates a combined-method, and returns the appropriate function spec. ;; Its main job in life is to take care of wrappers. Note the combined method ;; always takes a single &REST argument named .DAEMON-CALLER-ARGS. ;; FORM is a single form to be used as the body. ;;AB for PHD 8/11/87. Added :self-flavor declaration so COMPILE-AT-APPROPRIATE-TIME does not ;; have to change local-declarations. [SPR 6180] (defun make-combined-method (fl magic-list-entry form &aux fspec wrappers wrapper-sxhashes) ;; 9/16/85 DNG - Modified to use new function OPTIMIZE-METHOD-BODY-AND-ARGS. (setq form `(compile-time-remember-mapping-table ,(flavor-name fl) ,form)) ;; Get the function spec which will name the combined-method (setq fspec `(:method ,(flavor-name fl) :combined ,(car magic-list-entry))) ;; Put the wrappers and :AROUND methods around the form. ;; The base-flavor wrapper goes on the inside. (setq wrappers (append (get-specially-combined-methods magic-list-entry fl) (get-inverse-specially-combined-methods magic-list-entry fl))) (do ((wr wrappers (cdr wr)) (last-method-type nil)) ((null wr)) (let ((method (car wr))) ;; Record sxhash of each wrapper that goes in. ;; This way we can tell if the combined method is obsolete when fasloaded. (when (and (member (caddr method) '(:wrapper :inverse-wrapper) :test #'eq) (fboundp 'compiler:expr-sxhash)) (push (list method (compiler:expr-sxhash method)) wrapper-sxhashes)) (setq form (funcall (cadr (or (assoc (caddr method) *specially-combined-method-types* :test #'eq) (assoc (caddr method) *inverse-specially-combined-method-types* :test #'eq))) fl last-method-type method form)) (setq last-method-type (caddr method)))) ;; Remember that it's going to be there, for HAVE-COMBINED-METHOD (flavor-notice-method fspec) (when *just-compiling* (function-spec-putprop fspec magic-list-entry 'combined-method-derivation)) ;; Compile the function. It will be inserted into the flavor's tables either ;; now or when the QFASL file is loaded. (multiple-value-bind (body ll) (optimize-method-body-and-args form) (compile-at-appropriate-time fl fspec `(named-lambda (,fspec) ,ll ,@(if wrapper-sxhashes `((declare (wrapper-sxhashes ,@wrapper-sxhashes)))) (declare (combined-method-derivation ,@magic-list-entry) (function-parent ,(flavor-name fl) defflavor) ,(flavor-declaration (flavor-name fl))) (let ((.daemon-mapping-table. self-mapping-table)) ,body)) () )) fspec) (defun substitute-funcall-in-expression (form) ;; In order to prepare a combined method function body for the ;; compiler to do inline expansion of method calls, try to replace ;; all LEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL forms which were ;; created by METHOD-CALL with equivalent FUNCALL-WITH-MAPPING-TABLE ;; forms. This requires making sure that all of the calls will ;; use the same number of arguments. ;; A THROW is done to OUT if a consistent transformation is not ;; possible. ;; 8/03/85 DNG - Fixed to handle &REST args correctly. [SPR 249] ;; 9/16/85 DNG - Save time by not looking at argument of METHOD-MAPPING-TABLE. ;; 4/07/86 DNG - Modified for VM2 to use ARGS-DESC instead of ARGS-INFO. (declare (special number-of-method-args minimum-number-of-method-args method-arg-list)) (if (atom form) (if (eq form '.daemon-caller-args.) ;; A reference to the combined method's &REST argument ;; which was not removed by one of the special cases ;; below. Give up on optimization. (throw 'out nil) form) (let ((f (first form))) (cond ((null (REST form)) (if (atom f) form (cons (substitute-funcall-in-expression f) nil))) ((member f '(quote function method-mapping-table) :test #'eq) form) ((and (eq (second form) '.daemon-caller-args.) (member f '(car cadr caddr first second third) :test #'eq)) (let ((new (funcall f method-arg-list)) (min (funcall f '(1 2 3)))) (when (null new) (throw 'out nil)) (when (> min minimum-number-of-method-args) (setq minimum-number-of-method-args min)) new)) ((and (member f '(lexpr-funcall-with-mapping-table lexpr-funcall-with-mapping-table-internal) :test #'eq) (eq (fourth form) '.daemon-caller-args.) (null (NTHCDR 4 form)) (consp (second form)) (eq (first (second form)) 'function)) (multiple-value-bind (min max rest) (args-desc (or (declared-definition (second (second form))) (throw 'out nil))) (cond ((or (/= min max) (> max 3) (< min minimum-number-of-method-args) rest) (throw 'out nil)) ((null number-of-method-args) (setq number-of-method-args min) (setq method-arg-list (firstn min method-arg-list))) ((/= min number-of-method-args) (throw 'out nil))) (list* 'funcall-with-mapping-table (second form) (third form) method-arg-list))) ((and (atom f) (null (CDDR form))) (let ((new (substitute-funcall-in-expression (second form)))) (if (eq (second form) new) form (list f new)))) (t (loop for x in form collecting (substitute-funcall-in-expression x))))))) ;; These macros are used in combined methods to compile the appropriate code ;; to set the self mapping table from time to time. ;; COMPILE-TIME-REMEMBER-MAPPING-TABLE goes around the entire method combination ;; and METHOD-MAPPING-TABLE goes at each place where a specific mapping table ;; is wanted. METHOD-MAPPING-TABLE takes a method function spec as quoted arg ;; and turns into code to return the appropriate mapping table. (defvar compiler-flavor) (defmacro compile-time-remember-mapping-table (flavor &body body) `(compiler-let ((compiler-flavor ',flavor)) ,@body)) (defmacro method-mapping-table (method-function-spec) (or (eq (car method-function-spec) :method) (ferror () "METHOD-FUNCTION-SPEC is not one")) (let ((flavor (cadr method-function-spec))) (if (eq flavor compiler-flavor) '.daemon-mapping-table. `(self-ref ,compiler-flavor t ,flavor)))) (defun get-specially-combined-methods (mle *fl*) (declare (special *fl*)) ;; First get all :AROUNDs followed by all :WRAPPERs, ;; then reorder by flavor but preserve the order of things for a given flavor. (stable-sort (mapcan #'(lambda (method-type-cons) (copy-list (cdr (assoc (car method-type-cons) (cdddr mle) :test #'eq)))) *specially-combined-method-types*) #'(lambda (fs1 fs2) ;; Return T if FS1's flavor comes later ;; in our list of dependents than FS2's flavor. (member (cadr fs1) (cdr (member (cadr fs2) (flavor-depends-on-all *fl*) :test #'eq)) :test #'eq)))) (defun get-inverse-specially-combined-methods (mle *fl*) (declare (special *fl*)) ;; First get all :INVERSE-AROUNDs followed by all :INVERSE-WRAPPERs, ;; then reorder by flavor but preserve the order of things for a given flavor. (stable-sort (mapcan #'(lambda (method-type-cons) (copy-list (cdr (assoc (car method-type-cons) (cdddr mle) :test #'eq)))) *inverse-specially-combined-method-types*) #'(lambda (fs1 fs2) ;; Return T if FS2's flavor comes later ;; in our list of dependents than FS1's flavor. (member (cadr fs2) (cdr (member (cadr fs1) (flavor-depends-on-all *fl*) :test #'eq)) :test #'eq)))) (defun put-wrapper-into-combined-method (flavor previous-method-type wrapper-name form) flavor ;; Before any sequence of wrappers, stick on a binding of SELF-MAPPING-TABLE ;; because the body, a typical combined method, clobbers it, ;; but the code expanded by the wrapper itself may assume it is preserved. ;; If the last thing done was another wrapper, this is not necessary. (and (not (member previous-method-type '(:wrapper :inverse-wrapper) :test #'eq)) (setq form `(let ((self-mapping-table self-mapping-table)) ,form))) (let ((def (cond ((declared-definition wrapper-name)) ((fdefinedp wrapper-name) (fdefinition wrapper-name)) (t (ferror () "~S supposed to be a wrapper macro, but missing!" wrapper-name))))) (if (eq def 'aborted-definition) form (progn (cond ((or (atom def) (neq (car def) 'macro)) (ferror () "~S, supposed to be a wrapper macro, is poorly formed. Definiton is ~s" wrapper-name def))) `(macrocall ,wrapper-name .daemon-caller-args. ,form)) ;; Here we just put the wrapper in as a macro. It will be expanded by the compiler. ))) ;Sort of a macro version of funcall, for wrappers (defmacro macrocall (&rest x) (let ((macro (cond ((declared-definition (car x))) ((fdefinedp (car x)) (fdefinition (car x))) (t (ferror () "Unable to find definition of wrapper ~s at expand time" (car x)))))) (if (and (consp macro) (eq (car macro) 'macro)) (call (cdr macro) () x :optional *macroexpand-environment*) ;;--- Temporary code so I can test things in the kludge environment (if (and (symbolp macro) (consp (symbol-function macro)) (eq (car (symbol-function macro)) 'macro)) (call (cdr (symbol-function macro)) () x :optional *macroexpand-environment*) (ferror () "~S evaluated to ~S, which is not a macro" (car x) macro))))) (defun put-around-method-into-combined-method (flavor previous-method-type method-function-spec form) ;; 9/16/85 DNG - Use function OPTIMIZE-METHOD-BODY-AND-ARGS to enable ;; inline expansion of method calls in the continuation function. (declare (ignore previous-method-type)) (multiple-value-bind (body ll) (optimize-method-body-and-args form) `(compile-time-remember-mapping-table ,(flavor-name flavor) (lexpr-funcall-with-mapping-table-internal (function ,method-function-spec) (method-mapping-table ,method-function-spec) (car .daemon-caller-args.) #'(named-lambda continuation ,ll (let ((.daemon-mapping-table. self-mapping-table)) ,body)) .daemon-mapping-table. .daemon-caller-args. (cdr .daemon-caller-args.))))) ;Use this inside an :AROUND method, to call the continuation. ;Pass the first three args that the :AROUND method received. (defsubst around-method-continue (continuation mapping-table args) (lexpr-funcall-with-mapping-table continuation mapping-table args)) ;Return the FLAVOR declaration for use in methods, DECLARE-FLAVOR-INSTANCE-VARIABLES, etc. ;Declares all the instance variables of the flavor, as well as the flavor name. ;(EVAL-WHEN (COMPILE EVAL LOAD) (defun flavor-declaration (flavor-name &aux fl) (let ((*just-compiling* (just-compiling))) (labels ((internal-function (fl vl) (dolist (x (flavor-local-instance-variables fl)) (or (atom x) (setq x (car x))) (or (member x vl :test #'eq) (push x vl))) (append vl (getf (flavor-plist fl) :required-instance-variables) (loop for flname in (getf (flavor-plist fl) :required-flavors) nconc (get-instance-variables flname)))) (get-instance-variables (name) (let ((fl (compilation-flavor name))) (and fl (map-over-component-flavors 0 () () #'internal-function name ()))))) (when (setq fl (compilation-flavor flavor-name)) (cond ((flavor-components-defined-p flavor-name) (unless (flavor-depends-on-all fl) (let ((default-cons-area working-storage-area)) (compose-flavor-combination fl nil))) (let ((vars (flavor-all-instance-variables fl)) (more-vars (getf (flavor-plist fl) 'additional-instance-variables))) `(:self-flavor ,flavor-name ,(flavor-get-all-special-instance-variables fl) ,@more-vars ,@vars))) (t ;Try to get as many variables as we can. `(:self-flavor ,flavor-name ,(flavor-special-instance-variables fl) ,@(get-instance-variables flavor-name) ))))))) (defun flavor-get-all-special-instance-variables (flavor) "Return a list of all the special instance variables of FLAVOR (a flavor object or name). This function is for compatibility with flavors composed before the ALL-SPECIAL-INSTANCE-VARIABLES property started being used." (if (symbolp flavor) (setq flavor (compilation-flavor flavor))) (or (flavor-all-special-instance-variables flavor) (do ((ivars (flavor-all-instance-variables flavor) (cdr ivars)) (specials) (normal-bindings-left (flavor-bindings flavor)) (next-normal-binding)) ((null ivars) specials) ;; Figure out whether the next ivar is bound as special by message sending. (or (and (numberp next-normal-binding) (plusp next-normal-binding)) (setq next-normal-binding (pop normal-bindings-left))) (if (numberp next-normal-binding) (decf next-normal-binding)) ;; If it isn't, we must put it on our binding list to be bound now. (if (locativep next-normal-binding) (push (car ivars) specials))))) ;;; Get the function that would handle an operation for a flavor (defun get-flavor-handler-for (flavor-name operation &aux fl) (check-arg flavor-name (setq fl (get-flavor-tracing-aliases flavor-name)) "the name of a flavor") ;; Do any composition (compilation) of combined stuff, if not done already (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) (or (flavor-method-hash-table fl) (compose-method-combination fl)) (if (eq (flavor-method-hash-table fl) t) (ferror () "The flavor ~S is an :ABSTRACT-FLAVOR." flavor-name)) (car (without-interrupts (gethash operation (flavor-method-hash-table fl))))) ;; (:HANDLER flavor operation) refers to the function that is called when ;; an object of flavor FLAVOR is sent the message OPERATION. ;; Storing into this changes the value in the method table for that specific flavor ;; which should make it possible to trace and so forth. (defprop :handler handler-function-spec-handler function-spec-handler) (defun handler-function-spec-handler (function function-spec &optional arg1 arg2) (let ((flavor (second function-spec)) (operation (third function-spec))) ;; Checking structure like :INTERNAL (and (symbolp flavor) (let ((fl (get-flavor-tracing-aliases flavor))) (or fl (ferror 'invalid-function-spec "In the function spec ~S, ~S is not the name of a flavor" function-spec flavor)) ;; Do any composition (compilation) of combined stuff, if not done already (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) (or (flavor-method-hash-table fl) (compose-method-combination fl)) (if (eq (flavor-method-hash-table fl) t) (ferror () "The flavor ~S is an :ABSTRACT-FLAVOR." flavor)) (let ((loc (without-interrupts;Location of method (gethash operation (flavor-method-hash-table fl))))) (or (not (null loc)) (member function '(validate-function-spec fdefinedp) :test #'eq) (ferror () "The flavor ~S does not handle the ~S operation." flavor operation)) (case function (validate-function-spec t) (fdefine (rplacd loc arg1)) (fdefinition (cdr loc)) (fdefinedp loc) (fdefinition-location loc) (fundefine (ferror () "FUNDEFINE is not implemented for :HANDLER")) (otherwise (function-spec-default-handler function function-spec arg1 arg2)))))))) (defprop %instance-ref ((%instance-ref instance index) set-%instance-ref instance index val) setf) (defprop %instance-ref ((%instance-ref instance index) %instance-loc instance index) locf) ;Interface to the compiler. ;If called in *JUST-COMPILING* mode, during a QC-FILE, sends its output into the QFASL file. ;If called during a compilation to core, for instance from ;the editor c-t-C command, compiles to core as part of the compilation ;in progress (assuming you are in the top level macro-expanding part of the ;compiler rather than deep inside its guts). If called at a random time, ;simply compiles to core. ;Note that if LOCAL-DECLARATIONS is bound when this is called it will be obeyed. ;;AB for PHD 8/5/87. Removed the binding of local-declarations. For [SPR 6180]. ;; 3/18/89 DNG - Include modifications for CLOS. Use new function FLAVOR-DEFINITION-PACKAGE. (defun compile-at-appropriate-time (fl name lambda-exp &optional form-to-eval) ;; Switch to the appropriate package so gensyms get defined in that package and ;; and error messages about wrong package defining a function are avoided. But ;; if compiling, don't mess with the package, so that symbols in the qfasl file ;; get interned in the proper place. (let ((*package* (if compiler::qc-file-in-progress *package* (flavor-definition-package fl)))) (if (and compiler::qc-file-in-progress compiler::qcompile-temporary-area) ;; This case if in QC-FILE or editor-compile (if *just-compiling* ;; Here if QC-FILE. If it's a combined method, ;; actually FDEFINE a FASLOAD-COMBINED method when we load, ;; but make the FEF's name say :COMBINED. (compiler::qc-translate-function (if (and (= 4 (length name)) (eq (third name) :combined)) (list* (first name) (second name) 'fasload-combined (cdddr name)) name) lambda-exp 'compiler:macro-compile 'compiler:qfasl name) ;; Here for compiling from editor buffer, or QC-FILE to core. (compiler::locking-resources-no-qfasl (let ((inhibit-fdefine-warnings t)) (push (list name fdefine-file-pathname) *flavor-compilations*) (compiler::qc-translate-function name lambda-exp 'compiler:macro-compile 'compiler:compile-to-core)))) ;; This case if not doing anything special (progn (push (list name fdefine-file-pathname) *flavor-compilations*) (let ((fdefine-file-pathname nil) (inhibit-fdefine-warnings t)) ;; If the compiler is not loaded, try to limp through with interpreted methods (funcall (if (fboundp 'compile) 'compile 'fdefine) name lambda-exp)))) ;; Evaluate form now or send it over in the qfasl file (and form-to-eval (if *just-compiling* (compiler::fasd-form form-to-eval) (eval form-to-eval))))) (defmacro compile-flavor-methods (&rest flavor-names) "In a file being compiled, put combined methods of flavors into the QFASL file." `(progn (eval-when (compile) ,@(mapcan #'(lambda (flavor-name) (nconc (and (get flavor-name 'flavor) (cons `(setf (get (locf (flavor-plist (get ',flavor-name 'flavor))) 'compile-flavor-methods) t) ;;`(putprop (locf (flavor-plist (get ',flavor-name 'flavor))) t 'compile-flavor-methods) ;jlm 4/11/89 ())) (cons `(compile-flavor-methods-1 ',flavor-name) ()))) flavor-names)) (eval-when (load eval) ,@(mapcar #'(lambda (flavor-name) `(compile-flavor-methods-2 ',flavor-name)) flavor-names)))) ;; Cause the combined-methods to get compiled. ;; Executed only from the compiler, and does something ;; only if compiling to a file. (defun compile-flavor-methods-1 (flavor-name) (let ((*integrate-combined-methods* (or *integrate-combined-methods* (and (fboundp 'compiler:speed-over-safety-p) (dont-optimize (compiler:speed-over-safety-p)))))) (cond ((just-compiling) (let ((*just-compiling* t) (*use-old-combined-methods* nil) fl) (cond ((flavor-components-defined-p flavor-name 'compile-flavor-methods) (setq fl (compilation-flavor flavor-name)) ;; Make sure we are not hacking the installed flavor object, ;; in case there is no defflavor or defmethod for the flavor in this file. (and (eq fl (get flavor-name 'flavor)) (compilation-define-flavor flavor-name (setq fl (flavor-redefinition-for-compilation fl ())))) (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) (compose-method-combination fl ()) (dolist (alternative (get-run-time-alternative-flavor-names fl)) (compile-flavor-methods-1 alternative)))))) (*integrate-combined-methods* (integrate-flavor-methods flavor-name))))) ;; Do the composition now. This should normally just generate data-structure ;; as the methods should already all have been compiled, unless something has changed. (defprop compile-flavor-methods-2 t qfasl-dont-record) (defun compile-flavor-methods-2 (flavor-name &aux fl) (check-arg flavor-name (setq fl (get flavor-name 'flavor)) "the name of a flavor") (setf (getf (flavor-plist fl) 'compile-flavor-methods) (or fdefine-file-pathname t)) (cond ((flavor-components-defined-p flavor-name) (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) (or (flavor-method-hash-table fl) (compose-method-combination fl)) (dolist (alternative (get-run-time-alternative-flavor-names fl)) (compile-flavor-methods-2 alternative)))) flavor-name) (defun integrate-flavor-methods (flavor-name) "Compile any combined methods, using inline expansion for component methods." ;;phd 1/16/86 added compose-flavor-combination to fix a bug. (let ((fl (get flavor-name 'flavor)) (*integrate-combined-methods* t) (*dont-recompile-flavors* nil)) (or (flavor-depends-on-all fl) (compose-flavor-combination fl)) (if (flavor-method-hash-table fl) (recompile-flavor flavor-name () ()) (compose-method-combination fl)))) (defun flavor-components-defined-p (flavor-name &optional complaint &aux fl) "Returns T if all components of this flavor are defined. If COMPLAINT is non-NIL, a message containing it is printed if not all components are defined." (cond ((setq fl (compilation-flavor flavor-name)) (or (flavor-depends-on-all fl);Already composed, be fast (and (do ((l (flavor-depends-on fl) (cdr l))) ((null l) t) (or (flavor-components-defined-p (car l)) (return ()))) (do ((l (flavor-includes fl) (cdr l))) ((null l) t) (or (flavor-components-defined-p (car l)) (return ()))) (do ((l (getf (flavor-plist fl) :required-flavors) (cdr l))) ((null l) t) (or (flavor-components-defined-p (car l)) (return ())))))) (complaint (format *error-output* "~&~A - ~S undefined flavor" complaint flavor-name) nil) (t nil))) (defun flavor-undefined-components (flavor-name ) "Returns the list of the undefined components or required flavors" (let ((*just-compiling* (just-compiling))) (labels ((flavor-undefined-components-internal (flavor-name) (let ((fl (compilation-flavor flavor-name (just-compiling))) (l nil)) (if fl (and (null (flavor-depends-on-all fl)) ;Already composed, be fast (progn (dolist (comp (flavor-depends-on fl) nil) (setf l (nconc (flavor-undefined-components-internal comp) l))) (dolist (inc (flavor-includes fl) nil) (setf l (nconc (flavor-undefined-components-internal inc) l))) (dolist (req (getf (flavor-plist fl) :required-flavors) nil) (setf l (nconc (flavor-undefined-components-internal req) l))) l)) (cons flavor-name nil))))) (flavor-undefined-components-internal flavor-name)))) ;;;PHD 11/4/86 Fix up method lists generated by Genasys to hash table (defun fixup-method-hash-tables () (dolist (fl-name *all-flavor-names*) (let* ((fl (get fl-name 'flavor)) (ht (flavor-method-hash-table fl))) (when (consp ht) (make-method-hash-table fl))))) (add-initialization "Fix Up Flavor Method Hashtables" '(fixup-method-hash-tables) :once) (pushnew ':FLAVORS *features*) ; added 12/10/87 by DNG