X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/52a79ab8b310a785f2c2f1a11069f3a5ad53810c..refs/heads/mdw/progfmt:/src/class-make-proto.lisp diff --git a/src/class-make-proto.lisp b/src/class-make-proto.lisp index 01e18eb..a978ca3 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,8 +28,16 @@ ;;;-------------------------------------------------------------------------- ;;; 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 @@ -45,27 +53,26 @@ (with-default-error-location (location) (let* ((pset (property-set pset)) - (class (make-instance (get-property pset :lisp-metaclass :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))) 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. @@ -79,7 +86,7 @@ (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. @@ -88,11 +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. + + 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. @@ -101,11 +114,11 @@ 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.")) + 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. @@ -126,26 +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 `: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'.")) + 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. @@ -208,73 +273,15 @@ 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))))) +;;; Static instances. + +(export 'make-static-instance) +(defgeneric make-static-instance (class name initializers pset location &key) + (:documentation + "Construct a new static instance of the given CLASS. + + This is the main constructor functoin for static instances. This is a + generic function so that the CLASS can construct static instances in a + special way.")) ;;;----- That's all, folks --------------------------------------------------