src/c-types-impl.lisp: Remember `signed' as a C-level synonym for `int'.

[sod] / src / class-make-proto.lisp

diff --git a/src/class-make-proto.lisp b/src/class-make-proto.lisp
index 7305807cc5f7d31ee8535914dca8e03db977122e..2e1fe7c0ca2f4ec54a70b363382f7d3dfb0e2a5b 100644 (file)
--- a/src/class-make-proto.lisp
+++ b/src/class-make-proto.lisp
@@ -28,6 +28,14 @@ (cl:in-package #:sod)
 ;;;--------------------------------------------------------------------------
 ;;; 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)
   "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
@@ -46,12 +54,13 @@ (defun make-sod-class (name superclasses pset &optional location)
   (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,14 +68,6 @@ (defun make-sod-class (name superclasses pset &optional 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.
 
@@ -85,7 +86,7 @@ (defgeneric make-sod-slot (class name type pset &optional location)
 
 (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.
 
@@ -98,7 +99,7 @@ (defgeneric make-sod-instance-initializer
 
 (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.
 
@@ -111,7 +112,7 @@ (defgeneric make-sod-class-initializer
 
 (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,6 +133,57 @@ (defgeneric make-sod-initializer-using-slot
    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.