X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/4f5ac503eaef8d661edc5c9cafdbcbe3b9450db4..e895be217c3be6769708da17c9ae87cb22db040e:/src/class-make-proto.lisp

diff --git a/src/class-make-proto.lisp b/src/class-make-proto.lisp
index 8b024bd..5622dc6 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
@@ -46,12 +54,13 @@
   (with-default-error-location (location)
     (let* ((pset (property-set pset))
 	   (best-class (or (get-property pset :lisp-metaclass :symbol nil)
-			   (if superclasses
-			       (maximum (mapcar #'class-of superclasses)
-					#'subtypep
-					(format nil "Lisp metaclass for ~A"
-						name))
-			       'sod-class)))
+			   (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
@@ -59,19 +68,11 @@
 				 :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.
 
@@ -85,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)
   (:documentation
    "Construct and attach an instance slot initializer, to CLASS.
 
@@ -94,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.
+
+   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)
   (:documentation
    "Construct and attach a class slot initializer, to CLASS.
 
@@ -111,7 +118,7 @@
 
 (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.
 
@@ -132,11 +139,62 @@
    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.
 
@@ -152,7 +210,7 @@
 
 (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.
 
@@ -214,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 --------------------------------------------------