X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/abdf50aad1a95f1df8d11c54ff1623077eb84193..1f1d88f5234188f70548a04fd117ac6e251fe8de:/class-builder.lisp

diff --git a/class-builder.lisp b/class-builder.lisp
index 8c945ab..4e05a64 100644
--- a/class-builder.lisp
+++ b/class-builder.lisp
@@ -30,16 +30,21 @@
 
 (defun find-superclass-by-nick (class nick)
   "Returns the superclass of CLASS with nickname NICK, or signals an error."
-  (or (find nick (sod-class-precedence-list class)
-	    :key #'sod-class-nickname
-	    :test #'string=)
-      (error "No superclass of `~A' with nickname `~A'"
-	     (sod-class-name class) nick)))
+
+  ;; Slightly tricky.  The class almost certainly hasn't been finalized, so
+  ;; trundle through its superclasses and hope for the best.
+  (if (string= nick (sod-class-nickname class))
+      class
+      (or (some (lambda (super)
+		  (find nick (sod-class-precedence-list super)
+			:key #'sod-class-nickname
+			:test #'string=))
+		(sod-class-direct-superclasses class))
+	  (error "No superclass of `~A' with nickname `~A'" class nick))))
 
 (flet ((find-item-by-name (what class list name key)
 	 (or (find name list :key key :test #'string=)
-	     (error "No ~A in class `~A' with name `~A'"
-		    what (sod-class-name class) name))))
+	     (error "No ~A in class `~A' with name `~A'" what class name))))
 
   (defun find-instance-slot-by-name (class super-nick slot-name)
     (let ((super (find-superclass-by-nick class super-nick)))
@@ -103,7 +108,7 @@
 			 ((sod-subclass-p meta candidate) meta)
 			 ((sod-subclass-p candidate meta) candidate)
 			 (t (error "Unable to choose metaclass for `~A'"
-				   (sod-class-name class)))))))
+				   class))))))
       ((endp supers) meta)))
 
 (defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
@@ -119,30 +124,26 @@
        (the class's name, forced to lowercase) will be chosen in
        FINALIZE-SOD-CLASS.
 
-     * :CHAIN names the chained superclass.  If unspecified, this class will
+     * :LINK names the chained superclass.  If unspecified, this class will
        be left at the head of its chain."
 
-  (macrolet ((default-slot (slot value)
-	       `(unless (slot-boundp class ',slot)
-		  (setf (slot-value class ',slot) ,value))))
-
-    ;; If no nickname, copy the class name.  It won't be pretty, though.
-    (default-slot nickname
-      (get-property pset :nick :id (slot-value class 'name)))
+  ;; If no nickname, copy the class name.  It won't be pretty, though.
+  (default-slot (class 'nickname)
+    (get-property pset :nick :id (slot-value class 'name)))
 
-    ;; If no metaclass, guess one in a (Lisp) class-specific way.
-    (default-slot metaclass
-      (multiple-value-bind (name floc) (get-property pset :metaclass :id)
-	(if floc
-	    (find-sod-class name floc)
-	    (guess-metaclass class))))
+  ;; If no metaclass, guess one in a (Lisp) class-specific way.
+  (default-slot (class 'metaclass)
+    (multiple-value-bind (name floc) (get-property pset :metaclass :id)
+      (if floc
+	  (find-sod-class name floc)
+	  (guess-metaclass class))))
 
-    ;; If no chained-superclass, then start a new chain here.
-    (default-slot chained-superclass
-      (multiple-value-bind (name floc) (get-property pset :chain :id)
-	(if floc
-	    (find-sod-class name floc)
-	    nil)))))
+  ;; If no chain-link, then start a new chain here.
+  (default-slot (class 'chain-link)
+    (multiple-value-bind (name floc) (get-property pset :link :id)
+      (if floc
+	  (find-sod-class name floc)
+	  nil))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Slot construction.
@@ -306,15 +307,15 @@
 (defmethod make-sod-message
     ((class sod-class) name type pset &optional location)
   (with-default-error-location (location)
-    (let ((slot (make-instance (get-property pset :lisp-class :symbol
-					     'sod-slot)
+    (let ((message (make-instance (get-property pset :lisp-class :symbol
+						'standard-message)
 			       :class class
 			       :name name
 			       :type type
 			       :location (file-location location)
 			       :pset pset)))
-      (with-slots (slots) class
-	(setf slots (append slots (list slot))))
+      (with-slots (messages) class
+	(setf messages (append messages (list message))))
       (check-unused-properties pset))))
 
 (defmethod check-message-type ((message sod-message) (type c-function-type))
@@ -354,7 +355,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 calling CHOOSE-SOD-METHOD-CLASS)
+   the :LISP-CLASS property (defaulting to 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 construction protocol; for example,
@@ -414,7 +415,7 @@
     ((method sod-method) (message sod-message) (type c-type))
   (error "Methods must have function type, not ~A" type))
 
-(defun arguments-lists-compatible-p (message-args method-args)
+(defun argument-lists-compatible-p (message-args method-args)
   "Compare argument lists for compatibility.
 
    Return true if METHOD-ARGS is a suitable method argument list
@@ -436,50 +437,352 @@
 
 (defmethod check-method-type
     ((method sod-method) (message sod-message) (type c-function-type))
-
-  ;; Check compatibility.
   (with-slots ((msgtype type)) message
-    (unless (c-type-equal-p type msgtype)
-      (error "Method type ~A doesn't match message type ~A" type msgtype)))
+    (unless (c-type-equal-p (c-type-subtype msgtype)
+			    (c-type-subtype type))
+      (error "Method return type ~A doesn't match message ~A"
+	      (c-type-subtype msgtype) (c-type-subtype type)))
+    (unless (argument-lists-compatible-p (c-function-arguments msgtype)
+					 (c-function-arguments type))
+      (error "Method arguments ~A don't match message ~A" type msgtype))))
+
+(defmethod shared-initialize :after
+    ((method sod-method) slot-names &key pset)
+  (declare (ignore slot-names pset))
 
   ;; Check that the arguments are named if we have a method body.
-  (with-slots (body) method
+  (with-slots (body type) method
     (unless (or (not body)
 		(every #'argument-name (c-function-arguments type)))
-      (error "Abstract declarators not permitted in method definitions"))))
+      (error "Abstract declarators not permitted in method definitions")))
 
-(defmethod shared-initialize :after
-    ((method sod-method) slot-names &key pset)
-  (declare (ignore slot-names pset))
+  ;; Check the method type.
   (with-slots (message type) method
     (check-method-type method message type)))
 
 ;;;--------------------------------------------------------------------------
 ;;; Bootstrapping the class graph.
+;;;
+;;; FIXME: This is a daft place for this function.  It's also accumulating
+;;; all of the magic associated with initializing class instances.
+
+(defun output-imprint-function (class stream)
+  (let ((ilayout (sod-class-ilayout class)))
+    (format stream "~&~:
+static void *~A__imprint(void *p)
+{
+  struct ~A *sod__obj = p;
+
+  ~:{sod__obj.~A._vt = &~A;~:^~%  ~}
+  return (p);
+}~2%"
+	    class
+	    (ilayout-struct-tag class)
+	    (mapcar (lambda (ichain)
+		      (list (sod-class-nickname (ichain-head ichain))
+			    (vtable-name class (ichain-head ichain))))
+		    (ilayout-ichains ilayout)))))
+
+(defun output-init-function (class stream)
+  ;; FIXME this needs a metaobject protocol
+  (let ((ilayout (sod-class-ilayout class)))
+    (format stream "~&~:
+static void *~A__init(void *p)
+{
+  struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
+	    class
+	    (ilayout-struct-tag class))
+    (dolist (ichain (ilayout-ichains ilayout))
+      (let ((ich (format nil "sod__obj.~A"
+			 (sod-class-nickname (ichain-head ichain)))))
+	(dolist (item (ichain-body ichain))
+	  (etypecase item
+	    (vtable-pointer
+	     (format stream "  ~A._vt = &~A;~%"
+		     ich (vtable-name class (ichain-head ichain))))
+	    (islots
+	     (let ((isl (format nil "~A.~A"
+				ich
+				(sod-class-nickname (islots-class item)))))
+	       (dolist (slot (islots-slots item))
+		 (let ((dslot (effective-slot-direct-slot slot))
+		       (init (effective-slot-initializer slot)))
+		   (when init
+		     (ecase (sod-initializer-value-kind init)
+		       (:single
+			(format stream "  ~A = ~A;~%"
+				isl (sod-initializer-value-form slot)))
+		       (:compound
+			(format stream "  ~A = (~A)~A;~%"
+				isl (sod-slot-type dslot)
+				(sod-initializer-value-form slot)))))))))))))
+    (format stream "~&~:
+  return (p);
+}~2%")))
+
+(defun output-supers-vector (class stream)
+  (let ((supers (sod-class-direct-superclasses class)))
+    (when supers
+      (format stream "~&~:
+static const SodClass *const ~A__supers[] = {
+  ~{~A__class~^,~%  ~}
+};~2%"
+	      class supers))))
+
+(defun output-cpl-vector (class stream)
+  (format stream "~&~:
+static const SodClass *const ~A__cpl[] = {
+  ~{~A__class~^,~%  ~}
+};~2%"
+	  class (sod-class-precedence-list class)))
+
+(defun output-chains-vector (class stream)
+  (let ((chains (sod-class-chains class)))
+    (format stream "~&~:
+~1@*~:{static const SodClass *const ~A__chain_~A[] = {
+~{  ~A__class~^,~%~}
+};~:^~2%~}
+
+~0@*static const struct sod_chain ~A__chains[] = {
+~:{  { ~3@*~A,
+    ~0@*&~A__chain_~A,
+    ~4@*offsetof(struct ~A, ~A),
+    (const struct sod_vtable *)&~A,
+    sizeof(struct ~A) }~:^,~%~}
+};~2%"
+	    class			;0
+	    (mapcar (lambda (chain)	;1
+		      (let* ((head (sod-class-chain-head (car chain)))
+			     (chain-nick (sod-class-nickname head)))
+			(list class chain-nick			    ;0 1
+			      (reverse chain)			    ;2
+			      (length chain)			    ;3
+			      (ilayout-struct-tag class) chain-nick ;4 5
+			      (vtable-name class head)		    ;6
+			      (ichain-struct-tag class head))))	    ;7
+		    chains))))
+
+(defparameter *sod-class-slots*
+  `(
+
+    ;; Basic informtion.
+    ("name" ,(c-type const-string)
+	    :initializer-function
+	    ,(lambda (class)
+	       (prin1-to-string (sod-class-name class))))
+    ("nick" ,(c-type const-string)
+	    :initializer-function
+	    ,(lambda (class)
+	       (prin1-to-string (sod-class-nickname class))))
+
+    ;; Instance allocation and initialization.
+    ("instsz" ,(c-type size-t)
+	      :initializer-function
+	      ,(lambda (class)
+		 (format nil "sizeof(struct ~A)"
+			 (ilayout-struct-tag class))))
+    ("imprint" ,(c-type (* (fun (* void) ("p" (* void)))))
+	       :prepare-function 'output-imprint-function
+	       :initializer-function
+	       ,(lambda (class)
+		  (format nil "~A__imprint" class)))
+    ("init" ,(c-type (* (fun (* void) ("p" (* void)))))
+	    :prepare-function 'output-init-function
+	    :initializer-function
+	    ,(lambda (class)
+	       (format nil "~A__init" class)))
+
+    ;; Superclass structure.
+    ("n_supers" ,(c-type size-t)
+		:initializer-function
+		,(lambda (class)
+		   (length (sod-class-direct-superclasses class))))
+    ("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
+	      :prepare-function 'output-supers-vector
+	      :initializer-function
+	      ,(lambda (class)
+		 (if (sod-class-direct-superclasses class)
+		     (format nil "~A__supers" class)
+		     0)))
+    ("n_cpl" ,(c-type size-t)
+	     :initializer-function
+		,(lambda (class)
+		   (length (sod-class-precedence-list class))))
+    ("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
+	   :prepare-function 'output-cpl-vector
+	   :initializer-function
+	   ,(lambda (class)
+	      (format nil "~A__cpl" class)))
+
+    ;; Chain structure.
+    ("link" ,(c-type (* (class "SodClass" :const)))
+	    :initializer-function
+	    ,(lambda (class)
+	       (let ((link (sod-class-chain-link class)))
+		 (if link
+		     (format nil "~A__class" link)
+		     0))))
+    ("head" ,(c-type (* (class "SodClass" :const)))
+	    :initializer-function
+	    ,(lambda (class)
+	       (format nil "~A__class" (sod-class-chain-head class))))
+    ("level" ,(c-type size-t)
+	     :initializer-function
+	     ,(lambda (class)
+		(position class (reverse (sod-class-chain class)))))
+    ("n_chains" ,(c-type size-t)
+		:initializer-function
+		,(lambda (class)
+		   (length (sod-class-chains class))))
+    ("chains" ,(c-type (* (struct "sod_chain" :const)))
+	      :prepare-function 'output-chains-vector
+	      :initializer-function
+	      ,(lambda (class)
+		 (format nil "~A__chains" class)))
+
+    ;; Class-specific layout.
+    ("off_islots" ,(c-type size-t)
+		  :initializer-function
+		  ,(lambda (class)
+		     (format nil "offsetof(struct ~A, ~A)"
+			     (ichain-struct-tag class
+						(sod-class-chain-head class))
+			     (sod-class-nickname class))))
+    ("islotsz" ,(c-type size-t)
+	       :initializer-function
+	       ,(lambda (class)
+		  (format nil "sizeof(struct ~A)"
+			  (islots-struct-tag class))))))
+
+(defclass sod-class-slot (sod-slot)
+  ((initializer-function :initarg :initializer-function
+			 :type (or symbol function)
+			 :reader sod-slot-initializer-function)
+   (prepare-function :initarg :prepare-function
+		     :type (or symbol function)
+		     :reader sod-slot-prepare-function))
+  (:documentation
+   "Special class for slots defined on sod_object.
+
+   These slots need class-specific initialization.  It's easier to keep all
+   of the information (name, type, and how to initialize them) about these
+   slots in one place, so that's what we do here."))
+
+(defmethod shared-initialize :after
+    ((slot sod-class-slot) slot-names &key pset)
+  (declare (ignore slot-names))
+  (default-slot (slot 'initializer-function)
+    (get-property pset :initializer-function t nil))
+  (default-slot (slot 'prepare-function)
+    (get-property pset :prepare-function t nil)))
+
+(defclass sod-class-effective-slot (effective-slot)
+  ((initializer-function :initarg :initializer-function
+			 :type (or symbol function)
+			 :reader effective-slot-initializer-function)
+   (prepare-function :initarg :prepare-function
+			 :type (or symbol function)
+			 :reader effective-slot-prepare-function))
+  (:documentation
+   "Special class for slots defined on slot_object.
+
+   This class ignores any explicit initializers and computes initializer
+   values using the slot's INIT-FUNC slot and a magical protocol during
+   metaclass instance construction."))
+
+(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
+  (make-instance 'sod-class-effective-slot
+		 :slot slot
+		 :initializer-function (sod-slot-initializer-function slot)
+		 :prepare-function (sod-slot-prepare-function slot)
+		 :initializer (find-slot-initializer class slot)))
 
 (defun bootstrap-classes ()
-  (let* ((sod-object (make-sod-class "sod_object" nil
+  (let* ((sod-object (make-sod-class "SodObject" nil
 				     (make-property-set :nick 'obj)))
-	 (sod-class (make-sod-class "sod_class" (list sod-object)
+	 (sod-class (make-sod-class "SodClass" (list sod-object)
 				    (make-property-set :nick 'cls)))
 	 (classes (list sod-object sod-class)))
-    (setf (slot-value sod-class 'chained-superclass) sod-object)
+
+    ;; Sort out the recursion.
+    (setf (slot-value sod-class 'chain-link) sod-object)
     (dolist (class classes)
       (setf (slot-value class 'metaclass) sod-class))
+
+    ;; Predeclare the class types.
+    (dolist (class classes)
+      (make-class-type (sod-class-name class)))
+
+    ;; Attach the class slots.
+    (loop for (name type . plist) in *sod-class-slots*
+	  do (make-sod-slot sod-class name type
+			    (apply #'make-property-set
+				   :lisp-class 'sod-class-slot
+				   plist)))
+
+    ;; These classes are too closely intertwined.  We must partially finalize
+    ;; them together by hand.  This is cloned from FINALIZE-SOD-CLASS.
+    (dolist (class classes)
+      (with-slots (class-precedence-list chain-head chain chains) class
+	(setf class-precedence-list (compute-cpl class))
+	(setf (values chain-head chain chains) (compute-chains class))))
+
+    ;; Done.
     (dolist (class classes)
       (finalize-sod-class class)
       (record-sod-class class))))
 
-#|
- (defmacro define-sod-class (name superclasses &body body-and-options)
-  "FIXME.  This probably needs the docstring from hell."
-
-  (let ((class-var (gensym "CLASS"))
-	(slots-var (gensym "SLOTS"))
-	(inst-inits-var (gensym "INST-INITS"))
-	(class-inits-var (gensym "CLASS-INITS"))
-	(messages-var (gensym "MESSAGES"))
-	(methods-var (gensym "METHODS")))
-|#
+;;;--------------------------------------------------------------------------
+;;; Builder macro.
+
+(defmacro define-sod-class (name (&rest superclasses) &body body)
+  (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)
+	 (record-sod-class ,classvar)))))
+
+#+test
+(define-sod-class "AbstractStack" ("SodObject")
+  :nick 'abstk
+  (message "emptyp" (fun int))
+  (message "push" (fun void ("item" (* void))))
+  (message "pop" (fun (* void)))
+  (method "abstk" "pop" (fun void) #{
+     assert(!me->_vt.emptyp());
+   }
+   :role :before))
 
 ;;;----- That's all, folks --------------------------------------------------