; 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. ;;; 4/11/89 JLM Changed (PURPROP ... usage to (SETF (GET ... ;;; This is the runtime version, this file must content the minimum set of functions ;;; required to be able to instantiate and call a flavor. ;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. (proclaim '(special %gc-generation-number)) (defvar *flavor-area* working-storage-area) ;; 3/18/89 DNG - Slot FLAVOR-PACKAGE replaced by FLAVOR-CLASS-OBJECT. (defstruct (flavor :named :array (:constructor make-flavor) (:alterant nil) (:make-array (:area permanent-storage-area)) (:conc-name nil) (:callable-constructors nil) (:predicate nil) (:copier nil)) flavor-instance-size;1+ the number of instance variables flavor-bindings;List of locatives to instance variable ; internal value cells. MUST BE CDR-CODED!! ;Fixnums can also appear. They say to skip ;whatever number of instance variable slots. flavor-method-hash-table;The hash table for methods of this flavor. ; NIL means method-combination not composed yet. ; T means abstract flavor with COMPILE-FLAVOR-METHODS done. flavor-name;Symbol which is the name of the flavor. ; This is returned by TYPEP. flavor-component-mapping-table-alist;Alist of component flavor names vs. ;locatives into vector containing mapping tables. ;; End of magic locations known in microcode and QCOM. flavor-local-instance-variables;Names and initializations, ; does not include inherited ones. flavor-all-instance-variables;Just names, only valid when flavor-combination composed. ; Corresponds directly to FLAVOR-BINDINGS and the instances. flavor-method-table;Defined below. ;; End of locations depended on in many other files. flavor-depends-on;List of names of flavors incorporated into this flavor. flavor-depended-on-by;List of names of flavors which incorporate this one. ;The above are only immediate dependencies. flavor-includes;List of names of flavors to include at the end ; rather than as immediate depends-on's. flavor-class-object ; points to CLOS class object corresponding to this flavor. flavor-depends-on-all;Names of all flavors depended on, to all levels, including ; this flavor itself. NIL means flavor-combination not ; composed yet. This is used by TYPEP of 2 arguments. (flavor-which-operations ());List of operations handled, created when needed. ; This is NIL if it has not been computed yet. ;;This is the list of instance variables accessable from this flavor ;;which are mapped by mapping tables with this flavor as the method-flavor. (flavor-mapped-instance-variables ()) ;; Redundant copy of :DEFAULT-HANDLER property, for speed in calling it. (flavor-default-handler ()) (flavor-inittable-instance-variables ());Alist from init keyword to name of variable (flavor-init-keywords ());option (flavor-plist ());Esoteric things stored here as properties ;Known: :ORDERED-INSTANCE-VARIABLES, :DEFAULT-HANDLER ; :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES, :ACCESSOR-PREFIX, ; :REQUIRED-INSTANCE-VARIABLES, :REQUIRED-METHODS, ; :REQUIRED-FLAVORS, :SELECT-METHOD-ORDER, ; :DEFAULT-INIT-PLIST, :DOCUMENTATION, :NO-VANILLA-FLAVOR ; :GETTABLE-INSTANCE-VARIABLES :SETTABLE-INSTANCE-VARIABLES ; :SPECIAL-INSTANCE-VARIABLES ; :ABSTRACT-FLAVOR, :ALIAS-FLAVOR ; :INSTANTIATION-FLAVOR-FUNCTION ; :RUN-TIME-ALTERNATIVES or :MIXTURE ; RUN-TIME-ALTERNATIVE-ALIST ; -- is the alist of lists of flavors vs ; names we constructed for those combinations. ; ADDITIONAL-INSTANCE-VARIABLES ; COMPILE-FLAVOR-METHODS ; UNMAPPED-INSTANCE-VARIABLES ; MAPPED-COMPONENT-FLAVORS ; ALL-INSTANCE-VARIABLES-SPECIAL ; INSTANCE-VARIABLE-INITIALIZATIONS ; ALL-INITTABLE-INSTANCE-VARIABLES ; REMAINING-DEFAULT-PLIST ; REMAINING-INIT-KEYWORDS ; :INSTANCE-AREA-FUNCTION - the one specified for this fl. ; INSTANCE-AREA-FUNCTION - the one to be used (maybe inherited) ; :REQUIRED-INIT-KEYWORDS - the ones specified for this fl. ; REQUIRED-INIT-KEYWORDS - all required ones incl. inherited. ;The convention on these is supposed to be that ;ones in the keyword packages are allowed to be ;used by users. ;Some of these are not used by the flavor system, they are ;just remembered on the plist in case anyone cares. The ;flavor system does all its handling of them during the ;expansion of the DEFFLAVOR macro. ) ;; Before release 6, this was the package in which the DEFFLAVOR was done. ;; That slot in the flavor structure is now used for the class object. (defsubst flavor-package (fl) (flavor-definition-package fl)) (defun flavor-definition-package (fl) ; the package in which the DEFFLAVOR was done. (or (getf (flavor-plist fl) :package) (symbol-package (flavor-name fl)))) (defsetf flavor-definition-package (fl) (value) `(progn (unless (eq ,value (symbol-package (flavor-name ,fl))) (setf (getf (flavor-plist ,fl) :package) ,value)) ,value)) ;Named-structure handler for above structure, to make it print nicer (defun (:property flavor named-structure-invoke) (operation &optional self &rest args) (case operation (:which-operations '(:print-self :describe)) ((:print-self) (printing-random-object (self (car args)) (format (car args) "FLAVOR ~S" (flavor-name self)))) (:describe (describe-flavor self)) (otherwise (ferror () "~S unknown" operation)))) ;Used by other files to avoid compile-time dependency on our defstruct. (proclaim '(compiler:inline flavor-get)) ; save definition for local inline. (defun flavor-get (flavor prop) (getf (flavor-plist flavor) prop)) (proclaim '(compiler:notinline flavor-get)) (defvar flavor-data-area si:working-storage-area "Area for flavor plists and other lists associated with a flavor definition.") ;; This is just the old Zetalisp MAKE-INSTANCE with a new name to keep it ;; separate from the CLOS version. New for release 6. -- DNG 3/18/89 (defun sys:make-flavor-instance (flavor &rest init-options) "Create and return an instance of FLAVOR. INIT-OPTIONS is an alternating list of init keywords and their values. The new instance is sent an :INIT message. FLAVOR may also be a flavor instance, instead of a flavor name. In this case the instance is used instead of creating a new instance. It is initialized using the INIT-OPTIONS and is sent an :INIT message. The instance is returned." (instantiate-flavor flavor (locf init-options) t)) (deff zlc::make-instance #'sys:make-flavor-instance) ;; This definition is just for use in the cold band. It is replaced ;; when file "CLOS;MAKE-INSTANCE" is loaded. -- DNG 3/18/89 (defun ticl:make-instance (flavor &rest init-options) "Create and return an instance of FLAVOR. INIT-OPTIONS is an alternating list of init keywords and their values. The new instance is sent an :INIT message. FLAVOR may also be a flavor instance, instead of a flavor name. In this case the instance is used instead of creating a new instance. It is initialized using the INIT-OPTIONS and is sent an :INIT message. The instance is returned." (instantiate-flavor flavor (locf init-options) t)) ;Make an object of a particular flavor (the usual use), or reinitialize a flavor instance. ;In the first case, if the flavor hasn't been composed yet, must do so now. ; Delaying it until the first time it is needed aids initialization, ; e.g. up until now we haven't depended on the depended-on flavors being defined yet. ;Note that INIT-PLIST can be modified, if the :DEFAULT-INIT-PLIST option was ; used or the init methods modify it. ;;****** phd 9/2/85: changed INSTANTIATE-FLAVOR to use a specialized miscop to create the instance ;;****** This requires microcode 213 of newer. (defsubst fast-eval (form) "for internal use only" (typecase form (symbol (symbol-value form)) (atom form) (list (if (eq (first form) 'quote) (second form) (eval form))) (t (eval form)))) (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))) ;(setf (flavor-which-operations fl) ());This will have to be recomputed ;(let ((hash-instance (dont-optimize (hash-table-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) (symeval-in-instance hash-instance 'hash-array))))) ;; 5/07/89 DNG - Permit the instantiation-flavor-function to return an instance. (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)) (when (instancep tem) (return-from instantiate-flavor tem)) (error "The INSTANTIATION-FLAVOR-FUNCTION for flavor ~S returned an invalid value, ~S, not a flavor name or instance." 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)) (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) ;This function is called whenever the microcode fails to find an operation ;in the flavor's hash table. ;It could be because it is really undefined. ;Or maybe a GC has taken place and the method hash table must be rehashed. ;Or maybe the hash table has been forwarded. The ucode doesn't follow the ;forwarding, but rather gives up, so that we can un-forward it permanently. ;note: instance-hash-failure is called from the microcode via the ;support vector ;;;PHD 4/2/87 Fix this function broken because the rehash function does not work ;;;without interrupts (CR:AB) (defun instance-hash-failure (op &rest args &aux (ht (%function-inside-self)) fn-location func) (cond ((/= (dont-optimize (hash-table-gc-generation-number ht)) %gc-generation-number) (let ((newht (with-lock ((hash-table-lock ht)) (funcall (dont-optimize (hash-table-rehash-function ht)) ht ())))) ;; Some %POINTER's may have changed, try rehashing ;(set-in-instance (dont-optimize (hash-table-instance ht)) 'hash-array newht) (setf (instance-function self) (FOLLOW-STRUCTURE-FORWARDING newht))))) ;; In case a GC has happened or the hash table has been rehashed and forwarded, ;; search it again using GETHASH to find out if the operation is really there. (setq fn-location ;; GETHASH does follow forwarding, and rehashes if nec. (gethash op ht )) ;(dont-optimize (hash-table-instance ht)))) (when fn-location ;; In case GETHASH rehashed, snap out forwarding. (setf (instance-function self) (FOLLOW-STRUCTURE-FORWARDING (instance-function self)))) ; (symeval-in-instance (dont-optimize (hash-table-instance ht)) 'hash-array)))) (cond ((setq func (or (car fn-location);Found a definition (flavor-default-handler (instance-flavor self)))) (apply func op args)) ((setq func (and (neq op :unclaimed-message);user defined handler (get-handler-for self :unclaimed-message))) (apply func :unclaimed-message op args)) (t (apply 'flavor-unclaimed-message op args)))) ;default handler ;This is the default handler for flavors. (defun flavor-unclaimed-message (&rest message) (report-unclaimed-message (%stack-frame-pointer) message)) (defprop report-unclaimed-message t :error-reporter) (defun report-unclaimed-message (frame-pointer message) ;; Make this frame be a call to SELF so retrying it works. (rplaca frame-pointer self) (let ((new-operation (cerror :new-operation () 'unclaimed-message "The object ~S received a ~S message, which went unclaimed. The rest of the message was ~S." self (car message) (cdr message)))) (apply self new-operation (cdr message)))) ;This is a flavor which is automatically made a component of nearly all ;other flavors. It provides some basic facilities such as PRINT ;and DESCRIBE. ;This is a flavor which is automatically made a component of nearly all ;other flavors. It provides some basic facilities such as PRINT ;and DESCRIBE. (eval-when (load eval);Allow this file to compile if it isn't loaded (defflavor vanilla-flavor () () :no-vanilla-flavor;No instance variables, no other flavors (:method-combination (:case :base-flavor-last :set)) (:documentation :mixin "The default base flavor. This flavor provides the normal handlers for the :PRINT, :DESCRIBE, and :WHICH-OPERATIONS operations. Only esoteric hacks should give the :NO-VANILLA-FLAVOR option to DEFFLAVOR to prevent this inclusion."))) (defmethod (vanilla-flavor :default :init) (ignore) ()) (defmethod (vanilla-flavor :print-self) (stream &rest ignore) (printing-random-object (self stream :typep))) (defmethod (vanilla-flavor :describe) () (format t "~&~S, an object of flavor ~S,~% has instance variable values:~%" self (type-of self)) (dolist (ivar (flavor-all-instance-variables (instance-flavor self)) ) (format t "~% ~S:~27T~S" ivar (let ((loc (locate-in-instance self ivar))) (if (location-boundp loc) (contents loc) '|unbound|))))) (defmethod (vanilla-flavor :which-operations) () (flavor-which-operations (instance-flavor self))) (defmethod (vanilla-flavor :apropos) (substring) (SUB-APROPOS substring (flavor-which-operations (instance-flavor self)) :dont-print t)) (defmethod (vanilla-flavor :operation-handled-p) (op) (let ((fl (instance-flavor self))) (if (arrayp (flavor-method-hash-table fl)) (multiple-value-bind (nil definedp) (without-interrupts (gethash op (dont-optimize (flavor-method-hash-table fl)))) definedp) (let ((wo (or (flavor-which-operations fl) (funcall self :which-operations)))) (not (not (member op wo :test #'eq))))))) (defmethod (vanilla-flavor :send-if-handles) (op &rest to-send) (let ((fl (instance-flavor self))) (if (arrayp (flavor-method-hash-table fl)) (multiple-value-bind (fn-location definedp) (without-interrupts (gethash op (dont-optimize (flavor-method-hash-table fl)))) (if definedp (apply (car fn-location) op to-send))) (let ((wo (or (flavor-which-operations fl) (funcall self :which-operations)))) (and (member op wo :test #'eq) (apply self op to-send)))))) (defmethod (vanilla-flavor :get-handler-for) (op) (get-handler-for self op)) ;Useful methods for debugging. ;They all cause the instance variables of SELF to be bound as specials. (defmethod (vanilla-flavor :eval-inside-yourself) (form) (with-self-variables-bound (eval form))) (defmethod (vanilla-flavor :funcall-inside-yourself) (function &rest args) (with-self-variables-bound (apply function args))) (defmethod (vanilla-flavor :break) () (with-self-variables-bound (break "~S" self))) ;;; This flavor is a useful mixin that provides messages for a property list protocol. (DEFFLAVOR PROPERTY-LIST-MIXIN ((PROPERTY-LIST NIL)) () :SETTABLE-INSTANCE-VARIABLES (:DOCUMENTATION :MIXIN "A mixin that provides property list messages.")) (DEFMETHOD (PROPERTY-LIST-MIXIN :GET) (INDICATOR &OPTIONAL DEFAULT) (GET (LOCF PROPERTY-LIST) INDICATOR DEFAULT)) (DEFMETHOD (PROPERTY-LIST-MIXIN :CASE :SET :GET) (INDICATOR &REST PROPERTY) (DECLARE (ARGLIST INDICATOR PROPERTY)) ;; use car last is to ignore optional default eg from "(push zap (send foo :get bar))" ;;(PUTPROP (LOCF PROPERTY-LIST) (CAR (LAST PROPERTY)) INDICATOR) ; jlm 4/11/89 (setf (get (LOCF PROPERTY-LIST) INDICATOR) (CAR (LAST PROPERTY)))) (DEFMETHOD (PROPERTY-LIST-MIXIN :GET-LOCATION-OR-NIL) (INDICATOR) (GET-LOCATION-OR-NIL (LOCF PROPERTY-LIST) INDICATOR)) (DEFMETHOD (PROPERTY-LIST-MIXIN :GET-LOCATION) (INDICATOR) (LOCF (GET (LOCF PROPERTY-LIST) INDICATOR))) (DEFMETHOD (PROPERTY-LIST-MIXIN :GETL) (INDICATOR-LIST) (GETL (LOCF PROPERTY-LIST) INDICATOR-LIST)) (DEFMETHOD (PROPERTY-LIST-MIXIN :PUTPROP) (PROPERTY INDICATOR) ;;(PUTPROP (LOCF PROPERTY-LIST) PROPERTY INDICATOR) ; jlm 4/11/89 (setf (get (LOCF PROPERTY-LIST) INDICATOR) PROPERTY)) (DEFMETHOD (PROPERTY-LIST-MIXIN :REMPROP) (INDICATOR) (REMPROP (LOCF PROPERTY-LIST) INDICATOR)) (DEFMETHOD (PROPERTY-LIST-MIXIN :PUSH-PROPERTY) (PROPERTY INDICATOR) (PUSH PROPERTY (GET (LOCF PROPERTY-LIST) INDICATOR))) (DEFMETHOD (PROPERTY-LIST-MIXIN :PLIST) () PROPERTY-LIST) (DEFMETHOD (PROPERTY-LIST-MIXIN :PLIST-LOCATION) () (LOCF PROPERTY-LIST)) (DEFMETHOD (PROPERTY-LIST-MIXIN :PROPERTY-LIST-LOCATION) () (LOCF PROPERTY-LIST)) (DEFMETHOD (PROPERTY-LIST-MIXIN :SETPLIST) (NEW-PLIST) (SETQ PROPERTY-LIST NEW-PLIST)) (compile-flavor-methods PROPERTY-LIST-MIXIN ) ;;; ;;;(DEFCONST INSTANCE-INVOKE-VECTOR-CONTENTS ;;; '(:GET :GETL :GET-LOCATION-OR-NIL :CAR :CDR :SET-CAR :SET-CDR) ;;; "A list of elements to copy into the value of INSTANCE-INVOKE-VECTOR.") (DEFPARAMETER INSTANCE-INVOKE-VECTOR #(:GET :GETL :GET-LOCATION-OR-NIL :CAR :CDR :SET-CAR :SET-CDR) "A vector of operations that the microcode wants to perform on instances. Indices in this vector are known by the microcode. Do not change the positions of any items. The vector may not be forwarded.") (defflavor print-readably-mixin () () (:required-methods :reconstruction-init-plist)) ;;AB for PHD 6/19/87. Fixed pp-objify so circular flavor and structures are printed right. SPR 5557. (defmethod (print-readably-mixin :print-self) (stream &optional (pl 0) &rest ignore) (send stream :string-out "#") (let ((*package* pkg-user-package)) (print-object (type-of self) (1+ pl) stream)) (send stream :tyo #\Space) (do ((init-options (send self :reconstruction-init-plist) (cddr init-options))) ((null init-options)) (print-object (car init-options) (1+ pl) stream) (send stream :tyo #\Space) (print-object (cadr init-options) (1+ pl) stream) (if (cddr init-options) (send stream :tyo #\Space))) (send stream :tyo #\)) ;;PHD 2/13/87 Fixed (defmethod (print-readably-mixin :read-instance) (flavor stream) (do (ch init-options) ((prog1 (= (setq ch (internal-read-char stream t () t)) #\) (unread-char ch stream)) (apply #'make-instance flavor init-options)) ;; Skip past spaces. (do () ((not (= (setq ch (internal-read-char stream t () t)) #\Space)) (unread-char ch stream))) (setq init-options (list* (read stream t nil t) (read stream t nil t) init-options)))) ;;PHD 2/13/87 new-function. ;;CLM for PHD 9/02/87 - Use all-inittable-instance-variables instead of ;;inittable-instance-variables. This version also fixes the problem with ;;unitialized instance variables. (defmethod (print-readably-mixin :default :reconstruction-init-plist) (&aux plist) (do ((i (flavor-all-inittable-instance-variables (instance-flavor self)) (cdr i)) (idx 1 (1+ idx))) ((null i) plist) (when (car i) (let ((loc (%instance-loc self idx))) (when (location-boundp loc) (setf plist (list* (car i) (contents loc) plist))))))) (defun get-handler-for (function operation &optional (superiors-p t)) "Given a functional object, return its subfunction to do the given operation or NIL. Returns NIL if it does not handle that." (declare (ignore superiors-p)) (do () (nil) (select (%data-type function) (dtp-array ;Set function to NIL or Named-structure handler (setq function (get (named-structure-p function) 'named-structure-invoke))) (dtp-symbol (unless (fboundp function) (return ())) (setq function (symbol-function function))) (dtp-closure (setq function (car (%make-pointer dtp-list function)))) (dtp-instance (setq function (instance-function function)) (when (arrayp function) (return-from get-handler-for (car (without-interrupts (gethash operation function)))))) (otherwise (return-from get-handler-for nil))))) ;; 1/30/89 DNG - Modified to permit the argument to be a flavor structure for ;; when INSTANTIATE-FLAVOR is called by the new generic MAKE-INSTANCE. (defun get-flavor-tracing-aliases (flavor-name) "Return the flavor object for FLAVOR-NAME, or the one it is an alias for ..." (declare (inline flavor-get)) (do* ((name flavor-name) (fl (if (typep name 'flavor) name (get name 'flavor)) (get name 'flavor))) (nil) (unless fl (return nil)) (if (flavor-get fl :alias-flavor) (setq name (car (flavor-depends-on fl))) (return fl)))) (defun set-in-instance (instance ptr val) "Set the value of instance variable PTR in INSTANCE to VAL. PTR can also be a locative pointer to a value cell." (setf (contents (locate-in-instance instance ptr)) val) val) (defsubst symeval-in-instance (instance variable) (contents (locate-in-instance instance variable))) (defprop symeval-in-instance ((symeval-in-instance instance ptr) locate-in-instance instance ptr) locf) ;; LOCATE-IN-INSTANCE is now microcoded. (defun symeval-maybe-in-instance (instance ptr) "Try SYMEVAL-IN-INSTANCE; if not an instance variable of INSTANCE, then do SYMEVAL" (check-arg instance (typep instance 'instance) "an instance") (or (symbolp ptr) (setq ptr (%find-structure-header ptr))) (let ((n (position ptr (the list (flavor-all-instance-variables (instance-flavor instance))) :test #'eq))) (if n (%instance-ref instance (1+ n)) (symbol-value ptr)))) ;; 3/18/89 DNG - fixed to use APPLY instead of undefined SYS:LEXPR-FUNCALL. (DEFUN LEXPR-FUNCALL-WITH-MAPPING-TABLE (FUNCTION "E TABLE &EVAL &REST ARGS) "Call FUNCTION like LEXPR-FUNCALL but provide mapping table TABLE. If FUNCTION is a flavor method, this saves it from having to find the correct flavor mapping table, but it will lose if you give the wrong one." (declare (ignore TABLE)) (APPLY FUNCTION ARGS)) (DEFF LEXPR-FUNCALL-WITH-MAPPING-TABLE-INTERNAL 'LEXPR-FUNCALL-WITH-MAPPING-TABLE) (DEFUN FUNCALL-WITH-MAPPING-TABLE (FUNCTION "E TABLE &EVAL &REST ARGS) "Call FUNCTION like FUNCALL but provide mapping table TABLE. If FUNCTION is a flavor method, this saves it from having to find the correct flavor mapping table, but it will lose if you give the wrong one." TABLE (APPLY FUNCTION ARGS)) (DEFF FUNCALL-WITH-MAPPING-TABLE-INTERNAL 'FUNCALL-WITH-MAPPING-TABLE) ;;;03/16/89 clm - Integrated into Kernel for CLOS. (defsubst get-flavor (flavor-name &optional environment) ;; Given a flavor name, return the flavor structure or nil. ;; 11/23/88 DNG - Original. (compiler:get-from-environment flavor-name 'si::flavor nil environment))