[sod] / src / class-make-proto.lisp

;;; -*-lisp-*-
;;;
;;; Class construction protocol
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensble Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Classes.

(export 'make-sod-class)
(defun make-sod-class (name superclasses pset &optional location)
  "Construct and return a new SOD class with the given NAME and SUPERCLASSES.

   This is the main constructor function for classes.  The protocol works as
   follows.  The `:lisp-metaclass' property in PSET is checked: if it exists,
   it must be a symbol naming a (CLOS) class, which is used in place of
   `sod-class'.  All of the arguments are then passed to `make-instance';
   further behaviour is left to the standard CLOS instance construction
   protocol; for example, `sod-class' defines an `:after'-method on
   `shared-initialize'.

   Minimal sanity checking is done during class construction; most of it is
   left for `finalize-sod-class' to do (via `check-sod-class')."

  (with-default-error-location (location)
    (let* ((pset (property-set pset))
	   (class (make-instance (get-property pset :lisp-metaclass :symbol
					       'sod-class)
				 :name name
				 :superclasses superclasses
				 :location (file-location location)
				 :pset pset)))
      class)))

(export 'guess-metaclass)
(defgeneric guess-metaclass (class)
  (:documentation
   "Determine a suitable metaclass for the CLASS.

   The default behaviour is to choose the most specific metaclass of any of
   the direct superclasses of CLASS, or to signal an error if that failed."))

;;;--------------------------------------------------------------------------
;;; Slots and slot initializers.

(export 'make-sod-slot)
(defgeneric make-sod-slot (class name type pset &optional location)
  (:documentation
   "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.

   This is the main constructor function for slots.  This is a generic
   function primarily so that the CLASS can intervene in the construction
   process.  The default method uses the `:slot-class' property (defaulting
   to `sod-slot') to choose a (CLOS) class to instantiate.  The slot is then
   constructed by `make-instance' passing the arguments as initargs; further
   behaviour is left to the standard CLOS instance construction protocol; for
   example, `sod-slot' defines an `:after'-method on `shared-initialize'."))

(export 'make-sod-instance-initializer)
(defgeneric make-sod-instance-initializer
    (class nick name value-kind value-form pset &optional location)
  (:documentation
   "Construct and attach an instance slot initializer, to CLASS.

   This is the main constructor function for instance initializers.  This is
   a generic function primarily so that the CLASS can intervene in the
   construction process.  The default method looks up the slot using
   `find-instance-slot-by-name', calls `make-sod-initializer-using-slot' to
   actually make the initializer object, and adds it to the appropriate list
   in CLASS."))

(export 'make-sod-class-initializer)
(defgeneric make-sod-class-initializer
    (class nick name value-kind value-form pset &optional location)
  (:documentation
   "Construct and attach a class slot initializer, to CLASS.

   This is the main constructor function for class initializers.  This is a
   generic function primarily so that the CLASS can intervene in the
   construction process.  The default method looks up the slot using
   `find-class-slot-by-name', calls `make-sod-initializer-using-slot' to
   actually make the initializer object, and adds it to the appropriate list
   in CLASS."))

(export 'make-sod-initializer-using-slot)
(defgeneric make-sod-initializer-using-slot
    (class slot init-class value-kind value-form pset location)
  (:documentation
   "Common construction protocol for slot initializers.

   This generic function does the common work for constructing instance and
   class initializers.  It can usefully be specialized according to both the
   class and slot types.  The default method uses the `:initializer-class'
   property (defaulting to INIT-CLASS) to choose a (CLOS) class to
   instantiate.  The slot is then constructed by `make-instance' passing the
   arguments as initargs; further behaviour is left to the standard CLOS
   instance construction protocol; for example, `sod-initializer' defines an
   `:after'-method on `shared-initialize'.

   Diagnosing unused properties is left for the caller (usually
   `make-sod-instance-initializer' or `make-sod-class-initializer') to do.
   The caller is also expected to have set `with-default-error-location' if
   appropriate.

   You are not expected to call this generic function directly; it's more
   useful as a place to hang methods for custom initializer classes."))

;;;--------------------------------------------------------------------------
;;; Messages and methods.

(export 'make-sod-message)
(defgeneric make-sod-message (class name type pset &optional location)
  (:documentation
   "Construct and attach a new message with given NAME and TYPE, to CLASS.

   This is the main constructor function for messages.  This is a generic
   function primarily so that the CLASS can intervene in the construction
   process.  The default method uses the `:message-class' property
   (defaulting to `sod-message') to choose a (CLOS) class to instantiate.
   The message is then constructed by `make-instance' passing the arguments
   as initargs; further behaviour is left to the standard CLOS instance
   construction protocol; for example, `sod-message' defines an
   `:after'-method on `shared-initialize'."))

(export 'make-sod-method)
(defgeneric make-sod-method
    (class nick name type body pset &optional location)
  (:documentation
   "Construct and attach a new method to CLASS.

   This is the main constructor function for methods.  This is a generic
   function primarily so that the CLASS can intervene in the message lookup
   process, though this is actually a fairly unlikely occurrence.

   The default method looks up the message using `find-message-by-name',
   invokes `make-sod-method-using-message' to make the method object, and
   then adds the method to the class's list of methods.  This split allows
   the message class to intervene in the class selection process, for
   example."))

(export 'make-sod-method-using-message)
(defgeneric make-sod-method-using-message
    (message class type body pset location)
  (:documentation
   "Main construction subroutine for method construction.

   This is a generic function so that it can be specialized according to both
   a class and -- more particularly -- a message.  The default method uses
   the `:method-class' property (defaulting to the result of calling
   `sod-message-method-class') to choose a (CLOS) class to instantiate.  The
   method is then constructed by `make-instance' passing the arguments as
   initargs; further behaviour is left to the standard CLOS instance
   construction protocol; for example, `sod-method' defines an
   `:after'-method on `shared-initialize'.

   Diagnosing unused properties is left for the caller (usually
   `make-sod-method') to do.  The caller is also expected to have set
   `with-default-error-location' if appropriate.

   You are not expected to call this generic function directly; it's more
   useful as a place to hang methods for custom method classes."))

(export 'sod-message-method-class)
(defgeneric sod-message-method-class (message class pset)
  (:documentation
   "Return the preferred class for methods on MESSAGE.

   The message can inspect the PSET to decide on a particular message.  A
   `:method-class' property will usually override this decision: it's then
   the programmer's responsibility to ensure that the selected method class
   is appropriate."))

(export 'check-message-type)
(defgeneric check-message-type (message type)
  (:documentation
   "Check that TYPE is a suitable type for MESSAGE.  Signal errors if not.

   This is separated out of `shared-initialize', where it's called, so that
   it can be overridden conveniently by subclasses."))

(export 'check-method-type)
(defgeneric check-method-type (method message type)
  (:documentation
   "Check that TYPE is a suitable type for METHOD.  Signal errors if not.

   This is separated out of `shared-initialize', where it's called, so that
   it can be overridden conveniently by subclasses."))

;;;--------------------------------------------------------------------------
;;; Builder macros.

(export 'define-sod-class)
(defmacro define-sod-class (name (&rest superclasses) &body body)
  "Construct a new SOD class called NAME in the current module.

   The new class has the named direct SUPERCLASSES, which should be a list of
   strings.

   The BODY begins with a sequence of alternating keyword/value pairs
   defining properties for the new class.  The keywords are (obviously) not
   evaluated, but the value forms are.

   The remainder of the BODY are a sequence of forms to be evaluated as an
   implicit `progn'.  Additional macros are available to the BODY, to make
   defining the class easier.

   In the following, NAME is a string giving a C identifier; NICK is a string
   giving the nickname of a superclass; TYPE is a C type using S-expression
   notation.

     * message NAME TYPE &rest PLIST

     * method NICK NAME TYPE BODY &rest PLIST

     * slot NAME TYPE &rest PLIST

     * instance-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST

     * class-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST"

  (let ((plist nil)
	(classvar (gensym "CLASS-")))
    (loop
      (when (or (null body)
		(not (keywordp (car body))))
	(return))
      (push (pop body) plist)
      (push (pop body) plist))
    `(let ((,classvar (make-sod-class ,name
				      (mapcar #'find-sod-class
					      (list ,@superclasses))
				      (make-property-set
				       ,@(nreverse plist)))))
       (macrolet ((message (name type &rest plist)
		    `(make-sod-message ,',classvar ,name (c-type ,type)
				       (make-property-set ,@plist)))
		  (method (nick name type body &rest plist)
		    `(make-sod-method ,',classvar ,nick ,name (c-type ,type)
				      ,body (make-property-set ,@plist)))
		  (slot (name type &rest plist)
		    `(make-sod-slot ,',classvar ,name (c-type ,type)
				    (make-property-set ,@plist)))
		  (instance-initializer
		      (nick name value-kind value-form &rest plist)
		    `(make-sod-instance-initializer ,',classvar ,nick ,name
						    ,value-kind ,value-form
						    (make-property-set
						     ,@plist)))
		  (class-initializer
		      (nick name value-kind value-form &rest plist)
		    `(make-sod-class-initializer ,',classvar ,nick ,name
						 ,value-kind ,value-form
						 (make-property-set
						  ,@plist))))
	 ,@body
	 (finalize-sod-class ,classvar)
	 (add-to-module *module* ,classvar)))))

;;;----- That's all, folks --------------------------------------------------
Commit	Line	Data
dea4d055 MW	1	;;; --lisp--
	2	;;;
	3	;;; Class construction protocol
	4	;;;
	5	;;; (c) 2009 Straylight/Edgeware
	6	;;;
	7
	8	;;;----- Licensing notice ---------------------------------------------------
	9	;;;
	10	;;; This file is part of the Sensble Object Design, an object system for C.
	11	;;;
	12	;;; SOD is free software; you can redistribute it and/or modify
	13	;;; it under the terms of the GNU General Public License as published by
	14	;;; the Free Software Foundation; either version 2 of the License, or
	15	;;; (at your option) any later version.
	16	;;;
	17	;;; SOD is distributed in the hope that it will be useful,
	18	;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	19	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	20	;;; GNU General Public License for more details.
	21	;;;
	22	;;; You should have received a copy of the GNU General Public License
	23	;;; along with SOD; if not, write to the Free Software Foundation,
	24	;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
	25
	26	(cl:in-package #:sod)
	27
	28	;;;--------------------------------------------------------------------------
	29	;;; Classes.
	30
	31	(export 'make-sod-class)
	32	(defun make-sod-class (name superclasses pset &optional location)
	33	"Construct and return a new SOD class with the given NAME and SUPERCLASSES.
	34
	35	This is the main constructor function for classes. The protocol works as
52a79ab8 MW	36	follows. The `:lisp-metaclass' property in PSET is checked: if it exists,
52a79ab8 MW	37	it must be a symbol naming a (CLOS) class, which is used in place of
dea4d055 MW	38	`sod-class'. All of the arguments are then passed to `make-instance';
	39	further behaviour is left to the standard CLOS instance construction
	40	protocol; for example, `sod-class' defines an `:after'-method on
3109662a	41	`shared-initialize'.
dea4d055 MW	42
dea4d055 MW	43	Minimal sanity checking is done during class construction; most of it is
048d0b2d	44	left for `finalize-sod-class' to do (via `check-sod-class')."
dea4d055 MW	45
	46	(with-default-error-location (location)
	47	(let* ((pset (property-set pset))
52a79ab8	48	(class (make-instance (get-property pset :lisp-metaclass :symbol
dea4d055 MW	49	'sod-class)
	50	:name name
	51	:superclasses superclasses
	52	:location (file-location location)
	53	:pset pset)))
dea4d055 MW	54	class)))
	55
	56	(export 'guess-metaclass)
	57	(defgeneric guess-metaclass (class)
	58	(:documentation
	59	"Determine a suitable metaclass for the CLASS.
	60
	61	The default behaviour is to choose the most specific metaclass of any of
	62	the direct superclasses of CLASS, or to signal an error if that failed."))
	63
	64	;;;--------------------------------------------------------------------------
	65	;;; Slots and slot initializers.
	66
	67	(export 'make-sod-slot)
	68	(defgeneric make-sod-slot (class name type pset &optional location)
	69	(:documentation
	70	"Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
	71
	72	This is the main constructor function for slots. This is a generic
	73	function primarily so that the CLASS can intervene in the construction
52a79ab8	74	process. The default method uses the `:slot-class' property (defaulting
dea4d055 MW	75	to `sod-slot') to choose a (CLOS) class to instantiate. The slot is then
	76	constructed by `make-instance' passing the arguments as initargs; further
	77	behaviour is left to the standard CLOS instance construction protocol; for
048d0b2d	78	example, `sod-slot' defines an `:after'-method on `shared-initialize'."))
dea4d055 MW	79
	80	(export 'make-sod-instance-initializer)
	81	(defgeneric make-sod-instance-initializer
	82	(class nick name value-kind value-form pset &optional location)
	83	(:documentation
	84	"Construct and attach an instance slot initializer, to CLASS.
	85
	86	This is the main constructor function for instance initializers. This is
	87	a generic function primarily so that the CLASS can intervene in the
	88	construction process. The default method looks up the slot using
	89	`find-instance-slot-by-name', calls `make-sod-initializer-using-slot' to
	90	actually make the initializer object, and adds it to the appropriate list
048d0b2d	91	in CLASS."))
dea4d055 MW	92
	93	(export 'make-sod-class-initializer)
	94	(defgeneric make-sod-class-initializer
	95	(class nick name value-kind value-form pset &optional location)
	96	(:documentation
	97	"Construct and attach a class slot initializer, to CLASS.
	98
	99	This is the main constructor function for class initializers. This is a
	100	generic function primarily so that the CLASS can intervene in the
	101	construction process. The default method looks up the slot using
	102	`find-class-slot-by-name', calls `make-sod-initializer-using-slot' to
	103	actually make the initializer object, and adds it to the appropriate list
048d0b2d	104	in CLASS."))
dea4d055 MW	105
	106	(export 'make-sod-initializer-using-slot)
	107	(defgeneric make-sod-initializer-using-slot
	108	(class slot init-class value-kind value-form pset location)
	109	(:documentation
	110	"Common construction protocol for slot initializers.
	111
	112	This generic function does the common work for constructing instance and
	113	class initializers. It can usefully be specialized according to both the
52a79ab8 MW	114	class and slot types. The default method uses the `:initializer-class'
	115	property (defaulting to INIT-CLASS) to choose a (CLOS) class to
	116	instantiate. The slot is then constructed by `make-instance' passing the
	117	arguments as initargs; further behaviour is left to the standard CLOS
	118	instance construction protocol; for example, `sod-initializer' defines an
dea4d055 MW	119	`:after'-method on `shared-initialize'.
	120
	121	Diagnosing unused properties is left for the caller (usually
	122	`make-sod-instance-initializer' or `make-sod-class-initializer') to do.
	123	The caller is also expected to have set `with-default-error-location' if
	124	appropriate.
	125
	126	You are not expected to call this generic function directly; it's more
	127	useful as a place to hang methods for custom initializer classes."))
	128
	129	;;;--------------------------------------------------------------------------
	130	;;; Messages and methods.
	131
	132	(export 'make-sod-message)
	133	(defgeneric make-sod-message (class name type pset &optional location)
	134	(:documentation
	135	"Construct and attach a new message with given NAME and TYPE, to CLASS.
	136
	137	This is the main constructor function for messages. This is a generic
	138	function primarily so that the CLASS can intervene in the construction
52a79ab8 MW	139	process. The default method uses the `:message-class' property
	140	(defaulting to `sod-message') to choose a (CLOS) class to instantiate.
	141	The message is then constructed by `make-instance' passing the arguments
	142	as initargs; further behaviour is left to the standard CLOS instance
	143	construction protocol; for example, `sod-message' defines an
	144	`:after'-method on `shared-initialize'."))
dea4d055 MW	145
	146	(export 'make-sod-method)
	147	(defgeneric make-sod-method
	148	(class nick name type body pset &optional location)
	149	(:documentation
	150	"Construct and attach a new method to CLASS.
	151
	152	This is the main constructor function for methods. This is a generic
	153	function primarily so that the CLASS can intervene in the message lookup
	154	process, though this is actually a fairly unlikely occurrence.
	155
	156	The default method looks up the message using `find-message-by-name',
	157	invokes `make-sod-method-using-message' to make the method object, and
	158	then adds the method to the class's list of methods. This split allows
	159	the message class to intervene in the class selection process, for
048d0b2d	160	example."))
dea4d055 MW	161
	162	(export 'make-sod-method-using-message)
	163	(defgeneric make-sod-method-using-message
	164	(message class type body pset location)
	165	(:documentation
	166	"Main construction subroutine for method construction.
	167
	168	This is a generic function so that it can be specialized according to both
	169	a class and -- more particularly -- a message. The default method uses
52a79ab8	170	the `:method-class' property (defaulting to the result of calling
dea4d055 MW	171	`sod-message-method-class') to choose a (CLOS) class to instantiate. The
	172	method is then constructed by `make-instance' passing the arguments as
	173	initargs; further behaviour is left to the standard CLOS instance
	174	construction protocol; for example, `sod-method' defines an
	175	`:after'-method on `shared-initialize'.
	176
	177	Diagnosing unused properties is left for the caller (usually
	178	`make-sod-method') to do. The caller is also expected to have set
	179	`with-default-error-location' if appropriate.
	180
	181	You are not expected to call this generic function directly; it's more
	182	useful as a place to hang methods for custom method classes."))
	183
	184	(export 'sod-message-method-class)
	185	(defgeneric sod-message-method-class (message class pset)
	186	(:documentation
	187	"Return the preferred class for methods on MESSAGE.
	188
	189	The message can inspect the PSET to decide on a particular message. A
52a79ab8 MW	190	`:method-class' property will usually override this decision: it's then
	191	the programmer's responsibility to ensure that the selected method class
	192	is appropriate."))
dea4d055 MW	193
	194	(export 'check-message-type)
	195	(defgeneric check-message-type (message type)
	196	(:documentation
	197	"Check that TYPE is a suitable type for MESSAGE. Signal errors if not.
	198
	199	This is separated out of `shared-initialize', where it's called, so that
	200	it can be overridden conveniently by subclasses."))
	201
	202	(export 'check-method-type)
	203	(defgeneric check-method-type (method message type)
	204	(:documentation
	205	"Check that TYPE is a suitable type for METHOD. Signal errors if not.
	206
	207	This is separated out of `shared-initialize', where it's called, so that
	208	it can be overridden conveniently by subclasses."))
	209
	210	;;;--------------------------------------------------------------------------
	211	;;; Builder macros.
	212
	213	(export 'define-sod-class)
	214	(defmacro define-sod-class (name (&rest superclasses) &body body)
	215	"Construct a new SOD class called NAME in the current module.
	216
	217	The new class has the named direct SUPERCLASSES, which should be a list of
	218	strings.
	219
	220	The BODY begins with a sequence of alternating keyword/value pairs
	221	defining properties for the new class. The keywords are (obviously) not
	222	evaluated, but the value forms are.
	223
	224	The remainder of the BODY are a sequence of forms to be evaluated as an
	225	implicit `progn'. Additional macros are available to the BODY, to make
	226	defining the class easier.
	227
	228	In the following, NAME is a string giving a C identifier; NICK is a string
	229	giving the nickname of a superclass; TYPE is a C type using S-expression
	230	notation.
	231
	232	* message NAME TYPE &rest PLIST
	233
	234	* method NICK NAME TYPE BODY &rest PLIST
	235
	236	* slot NAME TYPE &rest PLIST
	237
	238	* instance-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST
	239
	240	* class-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST"
	241
	242	(let ((plist nil)
	243	(classvar (gensym "CLASS-")))
	244	(loop
	245	(when (or (null body)
	246	(not (keywordp (car body))))
	247	(return))
	248	(push (pop body) plist)
	249	(push (pop body) plist))
	250	`(let ((,classvar (make-sod-class ,name
	251	(mapcar #'find-sod-class
	252	(list ,@superclasses))
	253	(make-property-set
	254	,@(nreverse plist)))))
	255	(macrolet ((message (name type &rest plist)
	256	`(make-sod-message ,',classvar ,name (c-type ,type)
257	(make-property-set ,@plist)))
258	(method (nick name type body &rest plist)
259	`(make-sod-method ,',classvar ,nick ,name (c-type ,type)
260	,body (make-property-set ,@plist)))
261	(slot (name type &rest plist)
262	`(make-sod-slot ,',classvar ,name (c-type ,type)
263	(make-property-set ,@plist)))
264	(instance-initializer
265	(nick name value-kind value-form &rest plist)
266	`(make-sod-instance-initializer ,',classvar ,nick ,name
267	,value-kind ,value-form
268	(make-property-set
269	,@plist)))
270	(class-initializer
271	(nick name value-kind value-form &rest plist)
272	`(make-sod-class-initializer ,',classvar ,nick ,name
273	,value-kind ,value-form
274	(make-property-set
275	,@plist))))
276	,@body
277	(finalize-sod-class ,classvar)
278	(add-to-module module ,classvar)))))
279
280	;;;----- That's all, folks --------------------------------------------------