| 1 | ;; (c) Copywrite 1983, Massachusetts Institute of Technology |
| 2 | (setq rcs-flavorm- |
| 3 | "$Header: flavorm.l,v 1.2 85/03/24 11:25:34 sklower Exp $") |
| 4 | |
| 5 | ;; This file contains some of the support macros that are need by the |
| 6 | ;; flavor system. |
| 7 | |
| 8 | (environment-maclisp) |
| 9 | (declare (macros t)) |
| 10 | |
| 11 | ; The data-structure on the FLAVOR property of a flavor-name |
| 12 | (DEFSTRUCT (FLAVOR :NAMED) |
| 13 | FLAVOR-BINDINGS ;List of locatives to instance variable |
| 14 | ; internal value cells. MUST BE CDR-CODED!! |
| 15 | ;Fixnums can also appear. They say to skip |
| 16 | ;whatever number of instance variable slots. |
| 17 | FLAVOR-METHOD-HASH-TABLE ;The hash table for methods of this flavor. |
| 18 | ; NIL means method-combination not composed yet. |
| 19 | FLAVOR-NAME ;Symbol which is the name of the flavor. |
| 20 | ; This is returned by TYPEP. |
| 21 | FLAVOR-LOCAL-INSTANCE-VARIABLES ;Names and initializations, |
| 22 | ; does not include inherited ones. |
| 23 | FLAVOR-ALL-INSTANCE-VARIABLES ;Just names, only valid when "flavor |
| 24 | ; combination" composed. Corresponds directly |
| 25 | ; to FLAVOR-BINDINGS and the instances. |
| 26 | FLAVOR-METHOD-TABLE ;Defined below. |
| 27 | ;; End of locations depended on in many other files. |
| 28 | FLAVOR-DEPENDS-ON ;List of names of flavors incorporated into this flavor. |
| 29 | FLAVOR-DEPENDED-ON-BY ;List of names of flavors which incorporate this one. |
| 30 | ;The above are only immediate dependencies. |
| 31 | FLAVOR-INCLUDES ;List of names of flavors to include at the end |
| 32 | ; rather than as immediate depends-on's. |
| 33 | FLAVOR-DEPENDS-ON-ALL ;Names of all flavors depended on, to all levels, including |
| 34 | ; this flavor itself. NIL means flavor-combination not |
| 35 | ; composed yet. This is used by TYPEP of 2 arguments. |
| 36 | (FLAVOR-WHICH-OPERATIONS NIL) ;List of operations handled, created when needed. |
| 37 | ; This is NIL if it has not been computed yet. |
| 38 | ;; Redundant copy of :DEFAULT-HANDLER property, for speed in calling it. |
| 39 | (FLAVOR-DEFAULT-HANDLER NIL) |
| 40 | (FLAVOR-GETTABLE-INSTANCE-VARIABLES NIL) |
| 41 | (FLAVOR-SETTABLE-INSTANCE-VARIABLES NIL) |
| 42 | (FLAVOR-INITABLE-INSTANCE-VARIABLES NIL) |
| 43 | ;Alist from init keyword to name of variable |
| 44 | (FLAVOR-INIT-KEYWORDS NIL) ;option |
| 45 | (FLAVOR-PLIST NIL) ;Esoteric things stored here as properties |
| 46 | ;Known: :ORDERED-INSTANCE-VARIABLES, :DEFAULT-HANDLER |
| 47 | ; :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES, :ACCESSOR-PREFIX, |
| 48 | ; :REQUIRED-INSTANCE-VARIABLES, :REQUIRED-METHODS, |
| 49 | ; :REQUIRED-FLAVORS, :SELECT-METHOD-ORDER, |
| 50 | ; :DEFAULT-INIT-PLIST, :DOCUMENTATION, :NO-VANILLA-FLAVOR |
| 51 | ; :GETTABLE-INSTANCE-VARIABLES :SETTABLE-INSTANCE-VARIABLES |
| 52 | ; ADDITIONAL-INSTANCE-VARIABLES |
| 53 | ; COMPILE-FLAVOR-METHODS |
| 54 | ; MAPPED-COMPONENT-FLAVORS |
| 55 | ; INSTANCE-VARIABLE-INITIALIZATIONS |
| 56 | ; ALL-INITABLE-INSTANCE-VARIABLES |
| 57 | ; REMAINING-DEFAULT-PLIST |
| 58 | ; REMAINING-INIT-KEYWORDS |
| 59 | ;The convention on these is supposed to be that |
| 60 | ;ones in the keyword packages are allowed to be |
| 61 | ;used by users. |
| 62 | ;Some of these are not used by the flavor system, they are |
| 63 | ;just remembered on the plist in case anyone cares. The |
| 64 | ;flavor system does all its handling of them during the |
| 65 | ;expansion of the DEFFLAVOR macro. |
| 66 | ) |
| 67 | \f |
| 68 | (defsubst instancep (x) |
| 69 | (and (fclosurep x) (eq (fclosure-function x) #'flavor-dispatch))) |
| 70 | |
| 71 | (defvar self () |
| 72 | "Self referential pointer for flavors") |
| 73 | |
| 74 | (defmacro send (object message &rest args) |
| 75 | (if (eq object 'self) |
| 76 | `(send-self ,message ,@args) |
| 77 | `(send-internal ,object ,message ,@args))) |
| 78 | |
| 79 | (defmacro lexpr-send (object &rest args) |
| 80 | (if (eq object 'self) |
| 81 | `(lexpr-send-self ,@args) |
| 82 | `(lexpr-funcall #'send-internal ,object ,@args))) |
| 83 | |
| 84 | ;; These two functions are used when sending a message to yourself, for |
| 85 | ;; extra efficiency. They avoid the variable unbinding and binding |
| 86 | ;; required when entering a closure. |
| 87 | (defmacro send-self (message &rest args) |
| 88 | `(funcall (or (gethash ,message (flavor-method-hash-table .own-flavor.)) |
| 89 | (flavor-default-handler .own-flavor.)) |
| 90 | ,message . ,args)) |
| 91 | (defmacro funcall-self (&rest args) `(send-self . ,args)) |
| 92 | |
| 93 | (defmacro lexpr-send-self (message &rest args) |
| 94 | `(lexpr-funcall (or (gethash ,message |
| 95 | (flavor-method-hash-table .own-flavor.)) |
| 96 | (flavor-default-handler .own-flavor.)) |
| 97 | ,message . ,args)) |
| 98 | (defmacro lexpr-funcall-self (&rest args) `(lexpr-send-self . ,args)) |
| 99 | |
| 100 | (defsetf send (e v) |
| 101 | (if (or (atom (caddr e)) |
| 102 | (neq (car (caddr e)) 'quote)) |
| 103 | (ferror () "Don't know how to setf this ~S" e)) |
| 104 | (cond ((eq (cadr (caddr e)) ':get) |
| 105 | `(send ,(cadr e) ':putprop ,v ,(cadddr e))) |
| 106 | (t |
| 107 | `(send ,(cadr e) ',(intern (format () ":set-~A" |
| 108 | (remove-colon (cadr (caddr e))))) |
| 109 | ,v)))) |
| 110 | |
| 111 | (putprop 'flavorm t 'version) |