Commit | Line | Data |
---|---|---|
5ffa1c4c C |
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) |