[unix-history] / usr / src / ucb / lisp / lisplib / flavorm.l

;; (c) Copywrite 1983, Massachusetts Institute of Technology
(setq rcs-flavorm-
   "$Header: flavorm.l,v 1.2 85/03/24 11:25:34 sklower Exp $")

;; This file contains some of the support macros that are need by the
;; flavor system.

(environment-maclisp)
(declare (macros t))

; The data-structure on the FLAVOR property of a flavor-name
(DEFSTRUCT (FLAVOR :NAMED)
  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.
  FLAVOR-NAME			;Symbol which is the name of the flavor.
				; This is returned by TYPEP.
  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-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 NIL)	;List of operations handled, created when needed.
				; This is NIL if it has not been computed yet.
  ;; Redundant copy of :DEFAULT-HANDLER property, for speed in calling it.
  (FLAVOR-DEFAULT-HANDLER NIL)
  (FLAVOR-GETTABLE-INSTANCE-VARIABLES NIL)
  (FLAVOR-SETTABLE-INSTANCE-VARIABLES NIL)
  (FLAVOR-INITABLE-INSTANCE-VARIABLES NIL)
				;Alist from init keyword to name of variable
  (FLAVOR-INIT-KEYWORDS NIL)			;option
  (FLAVOR-PLIST NIL)		;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
				; ADDITIONAL-INSTANCE-VARIABLES
				; COMPILE-FLAVOR-METHODS
				; MAPPED-COMPONENT-FLAVORS
				; INSTANCE-VARIABLE-INITIALIZATIONS
				; ALL-INITABLE-INSTANCE-VARIABLES
				; REMAINING-DEFAULT-PLIST
				; REMAINING-INIT-KEYWORDS
				;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.
  )
\f
(defsubst instancep (x)
  (and (fclosurep x) (eq (fclosure-function x) #'flavor-dispatch)))

(defvar self ()
  "Self referential pointer for flavors")

(defmacro send (object message &rest args) 
  (if (eq object 'self)
      `(send-self ,message ,@args)
      `(send-internal ,object ,message ,@args)))

(defmacro lexpr-send (object &rest args)
  (if (eq object 'self)
      `(lexpr-send-self ,@args)
      `(lexpr-funcall #'send-internal ,object ,@args)))

;; These two functions are used when sending a message to yourself, for 
;; extra efficiency.  They avoid the variable unbinding and binding 
;; required when entering a closure.
(defmacro send-self (message &rest args)
  `(funcall (or (gethash ,message (flavor-method-hash-table .own-flavor.))
		(flavor-default-handler .own-flavor.))
	    ,message . ,args))
(defmacro funcall-self (&rest args) `(send-self . ,args))

(defmacro lexpr-send-self (message &rest args)
  `(lexpr-funcall (or (gethash ,message
			       (flavor-method-hash-table .own-flavor.))
		      (flavor-default-handler .own-flavor.))
		  ,message . ,args))
(defmacro lexpr-funcall-self (&rest args) `(lexpr-send-self . ,args))

(defsetf send (e v)
  (if (or (atom (caddr e))
	  (neq (car (caddr e)) 'quote))
      (ferror () "Don't know how to setf this ~S" e))
  (cond ((eq (cadr (caddr e)) ':get)
	 `(send ,(cadr e) ':putprop ,v ,(cadddr e)))
	(t
	 `(send ,(cadr e) ',(intern (format () ":set-~A"
					    (remove-colon (cadr (caddr e)))))
			  ,v))))

(putprop 'flavorm t 'version)
Commit	Line	Data
88bd7495 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)