X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/aa14a4cddcb96b681d5c19a2ec8bad382f43b264..c6b4ed992d81518f240509e6ab212d8fe705485a:/src/class-make-proto.lisp diff --git a/src/class-make-proto.lisp b/src/class-make-proto.lisp index 692da40..09b9f98 100644 --- a/src/class-make-proto.lisp +++ b/src/class-make-proto.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible 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 @@ -28,63 +28,65 @@ ;;;-------------------------------------------------------------------------- ;;; Classes. +(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.")) + (export 'make-sod-class) -(defun make-sod-class (name superclasses pset &optional location) +(defun make-sod-class (name superclasses pset &key 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 + 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. + `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." + 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-class :symbol - 'sod-class) + (best-class (or (get-property pset :lisp-metaclass :symbol nil) + (select-minimal-class-property + superclasses #'class-of #'subtypep 'sod-class + "Lisp metaclass" + :present (lambda (class) + (format nil "`~S'" + (class-name class))) + :allow-empty t))) + (class (make-instance best-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) +(defgeneric make-sod-slot (class name type pset &key 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 + 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'. - - Unused properties on PSET are diagnosed as errors.")) + 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) + (class nick name value pset &key location inhibit-initargs add-to-class) (:documentation "Construct and attach an instance slot initializer, to CLASS. @@ -93,13 +95,17 @@ 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. + in CLASS unless ADD-TO-CLASS is nil. - Unused properties on PSET are diagnosed as errors.")) + Usually, if an `initarg' property is set on PSET, then a slot initarg is + created and attached to the slot; this can be prevented by setting + INHIBIT-INITARGS non-nil. This is needed when creating a slot and + initializer from the same property set, in order to prevent creation of a + duplicate initarg.")) (export 'make-sod-class-initializer) (defgeneric make-sod-class-initializer - (class nick name value-kind value-form pset &optional location) + (class nick name value pset &key location add-to-class) (:documentation "Construct and attach a class slot initializer, to CLASS. @@ -108,23 +114,21 @@ 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.")) + in CLASS unless ADD-TO-CLASS is nil.")) (export 'make-sod-initializer-using-slot) (defgeneric make-sod-initializer-using-slot - (class slot init-class value-kind value-form pset location) + (class slot init-class value 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 + 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 @@ -135,28 +139,78 @@ You are not expected to call this generic function directly; it's more useful as a place to hang methods for custom initializer classes.")) +(export 'make-sod-user-initarg) +(defgeneric make-sod-user-initarg + (class name type pset &key default location) + (:documentation + "Attach a user-defined initialization keyword argument to the CLASS. + + The new argument has the given NAME and TYPE, and maybe a DEFAULT value. + Currently, initialization arguments are just dumb objects held in a + list.")) + +(export 'make-sod-slot-initarg) +(defgeneric make-sod-slot-initarg + (class name nick slot-name pset &key location) + (:documentation + "Attach an initialization keyword argument to a slot by name. + + The default method uses `find-instance-slot-by-name' to find the slot, and + `make-slot-initarg-using-slot' to actually make and attach the initarg.")) + +(export 'make-sod-slot-initarg-using-slot) +(defgeneric make-sod-slot-initarg-using-slot + (class name slot pset &key location) + (:documentation + "Attach an initialization keyword argument to a SLOT. + + The argument's type is taken from the slot type. Slot initargs can't have + defaults: the slot's most-specific initializer is used instead. + + You are not expected to call this generic function directly; it's more + useful as a place to hang methods for custom classes.")) + +(export 'sod-initarg-argument) +(defgeneric sod-initarg-argument (initarg) + (:documentation "Returns an `argument' object for the initarg.")) + +(export 'make-sod-class-initfrag) +(defgeneric make-sod-class-initfrag (class frag pset &key location) + (:documentation + "Attach an initialization fragment FRAG to the CLASS. + + Currently, initialization fragments are just dumb objects held in a + list.")) + +(export 'make-sod-class-tearfrag) +(defgeneric make-sod-class-tearfrag (class frag pset &key location) + (:documentation + "Attach a teardown fragment FRAG to the CLASS. + + Currently, teardown fragments are just dumb objects held in a + list.")) + ;;;-------------------------------------------------------------------------- ;;; Messages and methods. (export 'make-sod-message) -(defgeneric make-sod-message (class name type pset &optional location) +(defgeneric make-sod-message (class name type pset &key 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.")) + process. The default method uses the `:message-class' property to choose + a (CLOS) class to instantiate; if no such property is provided but a + `combination' property is present, then `aggregating-message' is chosen; + otherwise `standard-message' is used. 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) + (class nick name type body pset &key location) (:documentation "Construct and attach a new method to CLASS. @@ -168,9 +222,7 @@ 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.")) + example.")) (export 'make-sod-method-using-message) (defgeneric make-sod-method-using-message @@ -180,7 +232,7 @@ 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 + 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 @@ -200,9 +252,9 @@ "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.")) + `: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) @@ -220,74 +272,4 @@ 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 --------------------------------------------------