;;;----- 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
(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-instance-initializer)
(defgeneric make-sod-instance-initializer
- (class nick name value-kind value-form pset &optional location)
+ (class nick name value pset &optional location)
(:documentation
"Construct and attach an instance slot initializer, to CLASS.
(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 &optional location)
(:documentation
"Construct and attach a class slot initializer, to CLASS.
(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.
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 &optional 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 &optional 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 &optional 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 &optional 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 &optional location)
+ (:documentation
+ "Attach a teardown fragment FRAG to the CLASS.
+
+ Currently, teardown fragments are just dumb objects held in a
+ list."))
+
;;;--------------------------------------------------------------------------
;;; Messages and methods.
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
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