--- /dev/null
+;;; -*-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-class' 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).
+
+ Unused properties in PSET are diagnosed as errors."
+
+ (with-default-error-location (location)
+ (let* ((pset (property-set pset))
+ (class (make-instance (get-property pset :lisp-class :symbol
+ 'sod-class)
+ :name name
+ :superclasses superclasses
+ :location (file-location location)
+ :pset pset)))
+ (check-unused-properties 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 `:lisp-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'.
+
+ Unused properties on PSET are diagnosed as errors."))
+
+(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.
+
+ Unused properties on PSET are diagnosed as errors."))
+
+(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.
+
+ Unused properties on PSET are diagnosed as errors."))
+
+(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 `:lisp-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 `:lisp-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'.
+
+ Unused properties on PSET are diagnosed as errors."))
+
+(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.
+
+ Unused properties on PSET are diagnosed as errors."))
+
+(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 `:lisp-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
+ `:lisp-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 --------------------------------------------------
~mdw / sod / blobdiff