Lots more has happened.

  * all reserved words are now banished
  * an ilayout now consists of, for each chain, a union of the ichains
    for each class on the chain -- makes referring to the bit which
    represents a superclass instance trivial; not yet hacked the
    effective method codegen to cope
  * unnecessary ichain and vt structures (ones which are copies of a
    superclass's) are suppressed -- we use the original directly
    (must document the new chain-tail tracking stuff); only one new
    ichain and vtable structure per class (though we still need all-new
    vtmsgs for each superclass).
  * header file output is complete and functional

diff --git a/builtin.lisp b/builtin.lisp
index 26d384b0bd6a8b6ebedc25db8f457e4d58d8a17d..21fa1e32d043e2d97cdc92cd85a096b48bfc504f 100644 (file)
--- a/builtin.lisp
+++ b/builtin.lisp
@@ -187,12 +187,12 @@ (defparameter *sod-class-slots*
              ,(lambda (class)
                 (format nil "sizeof(struct ~A)"
                         (ilayout-struct-tag class))))
              ,(lambda (class)
                 (format nil "sizeof(struct ~A)"
                         (ilayout-struct-tag class))))

-    ("imprint" ,(c-type (* (fun (* void) ("p" (* void)))))
+    ("imprint" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))

               :prepare-function 'output-imprint-function
               :initializer-function
               ,(lambda (class)
                  (format nil "~A__imprint" class)))
               :prepare-function 'output-imprint-function
               :initializer-function
               ,(lambda (class)
                  (format nil "~A__imprint" class)))

-    ("init" ,(c-type (* (fun (* void) ("p" (* void)))))
+    ("init" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))

            :prepare-function 'output-init-function
            :initializer-function
            ,(lambda (class)
            :prepare-function 'output-init-function
            :initializer-function
            ,(lambda (class)


@@ -300,7 +300,7 @@ (defun bootstrap-classes (module)
 
 (defun make-builtin-module ()
   (let ((module (make-instance 'module
 
 (defun make-builtin-module ()
   (let ((module (make-instance 'module

-                              :name (make-pathname :name "BUILTIN"
+                              :name (make-pathname :name "SOD-BASE"

                                                    :type "SOD"
                                                    :case :common)
                               :state nil))
                                                    :type "SOD"
                                                    :case :common)
                               :state nil))

diff --git a/class-builder.lisp b/class-builder.lisp
index 2d77d70644ffb32feb50d6278e500ea4d089285a..7acbeaeed22351a3caa6fe9b69b55f56f141112d 100644 (file)
--- a/class-builder.lisp
+++ b/class-builder.lisp
@@ -461,7 +461,7 @@ (defmethod shared-initialize :after
     (check-method-type method message type)))
 
 ;;;--------------------------------------------------------------------------
     (check-method-type method message type)))
 
 ;;;--------------------------------------------------------------------------

-;;; Builder macro.
+;;; Builder macros.

 
 (defmacro define-sod-class (name (&rest superclasses) &body body)
   (let ((plist nil)
 
 (defmacro define-sod-class (name (&rest superclasses) &body body)
   (let ((plist nil)


@@ -500,17 +500,6 @@ (defmacro define-sod-class (name (&rest superclasses) &body body)
                                                  ,@plist))))
         ,@body
         (finalize-sod-class ,classvar)
                                                  ,@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))
+        (add-to-module *module* ,classvar)))))

 
 ;;;----- That's all, folks --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/class-defs.lisp b/class-defs.lisp
index 8640cf5cf27e5d0cede8558d2dab9f51110ebc79..512505b609727cda39c036faa526d6bb7bc1925b 100644 (file)
--- a/class-defs.lisp
+++ b/class-defs.lisp
@@ -53,6 +53,8 @@ (defclass sod-class ()
 
    (class-precedence-list :type list :accessor sod-class-precedence-list)
 
 
    (class-precedence-list :type list :accessor sod-class-precedence-list)
 

+   (type :type c-class-type :accessor sod-class-type)
+

    (chain-head :type sod-class :accessor sod-class-chain-head)
    (chain :type list :accessor sod-class-chain)
    (chains :type list :accessor sod-class-chains)
    (chain-head :type sod-class :accessor sod-class-chain-head)
    (chain :type list :accessor sod-class-chain)
    (chains :type list :accessor sod-class-chains)


@@ -504,10 +506,6 @@ (defun record-sod-class (class &optional (floc class))
            (t
             (setf (c-type-class type) class))))))
 
            (t
             (setf (c-type-class type) class))))))
 

-(defun sod-class-type (class)
-  "Returns the C type corresponding to CLASS."
-  (find-class-type (sod-class-name class)))
-

 (define-c-type-syntax class (name &rest quals)
   "Returns a type object for the named class."
   (if quals
 (define-c-type-syntax class (name &rest quals)
   "Returns a type object for the named class."
   (if quals

diff --git a/class-finalize.lisp b/class-finalize.lisp
index cf1ff73e77815d001b5c3aebd095bc7e4c59a7b2..fa8cc7da2d16bbd778c30f5537732c6a770c099b 100644 (file)
--- a/class-finalize.lisp
+++ b/class-finalize.lisp
@@ -169,7 +169,7 @@ (defmethod check-sod-class ((class sod-class))
          (error "Invalid message name `~A' on class `~A'"
                 (sod-message-name message) class))))
 
          (error "Invalid message name `~A' on class `~A'"
                 (sod-message-name message) class))))
 

-      ;; Check that the slots and messages have distinct names.
+    ;; Check that the slots and messages have distinct names.

     (with-slots (slots messages class-precedence-list) class
       (flet ((check-list (list what namefunc)
               (let ((table (make-hash-table :test #'equal)))
     (with-slots (slots messages class-precedence-list) class
       (flet ((check-list (list what namefunc)
               (let ((table (make-hash-table :test #'equal)))


@@ -191,6 +191,19 @@ (defmethod check-sod-class ((class sod-class))
        (error "In `~A~, chain-to class `~A' is not a proper superclass"
               class chain-link)))
 
        (error "In `~A~, chain-to class `~A' is not a proper superclass"
               class chain-link)))
 

+    ;; Check for circularity in the superclass graph.  Since the superclasses
+    ;; should already be acyclic, it suffices to check that our class is not
+    ;; a superclass of any of its own direct superclasses.
+    (let ((circle (find-if (lambda (super)
+                            (sod-subclass-p super class))
+                          (sod-class-direct-superclasses class))))
+      (when circle
+       (error "Circularity: ~A is already a superclass of ~A"
+              class circle)))
+
+    ;; Check that the class has a unique root superclass.
+    (find-root-superclass class)
+

     ;; Check that the metaclass is a subclass of each direct superclass's
     ;; metaclass.
     (with-slots (metaclass direct-superclasses) class
     ;; Check that the metaclass is a subclass of each direct superclass's
     ;; metaclass.
     (with-slots (metaclass direct-superclasses) class


@@ -226,6 +239,10 @@ (defmethod finalize-sod-class ((class sod-class))
                     (eq class metaclass))
           (finalize-sod-class metaclass)))
 
                     (eq class metaclass))
           (finalize-sod-class metaclass)))
 

+       ;; Stash the class's type.
+       (setf (sod-class-type class)
+            (make-class-type (sod-class-name class)))
+

        ;; Clobber the lists of items if they've not been set.
        (dolist (slot '(slots instance-initializers class-initializers
                       messages methods))
        ;; Clobber the lists of items if they've not been set.
        (dolist (slot '(slots instance-initializers class-initializers
                       messages methods))

diff --git a/class-layout.lisp b/class-layout.lisp
index df068ed3eeee9ab5b2f472630f747c20a5782b4f..a37852ed365a955a9bef5ee4fddbdce62264adc3 100644 (file)
--- a/class-layout.lisp
+++ b/class-layout.lisp
@@ -99,7 +99,9 @@ (defgeneric compute-islots (class subclass)
 (defclass vtable-pointer ()
   ((class :initarg :class :type sod-class :reader vtable-pointer-class)
    (chain-head :initarg :chain-head :type sod-class
 (defclass vtable-pointer ()
   ((class :initarg :class :type sod-class :reader vtable-pointer-class)
    (chain-head :initarg :chain-head :type sod-class

-              :reader vtable-pointer-chain-head))
+              :reader vtable-pointer-chain-head)
+   (chain-tail :initarg :chain-tail :type sod-class
+              :reader vtable-pointer-chain-tail))

   (:documentation
    "A pointer to the vtable for CLASS corresponding to a particular CHAIN."))
 
   (:documentation
    "A pointer to the vtable for CLASS corresponding to a particular CHAIN."))
 


@@ -114,6 +116,7 @@ (defmethod print-object ((vtp vtable-pointer) stream)
 (defclass ichain ()
   ((class :initarg :class :type sod-class :reader ichain-class)
    (chain-head :initarg :chain-head :type sod-class :reader ichain-head)
 (defclass ichain ()
   ((class :initarg :class :type sod-class :reader ichain-class)
    (chain-head :initarg :chain-head :type sod-class :reader ichain-head)

+   (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail)

    (body :initarg :body :type list :reader ichain-body))
   (:documentation
    "All of the instance layout for CLASS corresponding to a particular CHAIN.
    (body :initarg :body :type list :reader ichain-body))
   (:documentation
    "All of the instance layout for CLASS corresponding to a particular CHAIN.


@@ -167,17 +170,21 @@ (defmethod compute-islots ((class sod-class) (subclass sod-class))
                                (sod-class-slots class))))
 
 (defmethod compute-ichain ((class sod-class) chain)
                                (sod-class-slots class))))
 
 (defmethod compute-ichain ((class sod-class) chain)

-  (let* ((head (car chain))
+  (let* ((chain-head (car chain))
+        (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
+                          :key #'sod-class-chain-head))

         (vtable-pointer (make-instance 'vtable-pointer
                                        :class class
         (vtable-pointer (make-instance 'vtable-pointer
                                        :class class

-                                       :chain-head head))
+                                       :chain-head chain-head
+                                       :chain-tail chain-tail))

         (islots (remove-if-not #'islots-slots
                                (mapcar (lambda (super)
                                          (compute-islots super class))
                                        chain))))
     (make-instance 'ichain
                   :class class
         (islots (remove-if-not #'islots-slots
                                (mapcar (lambda (super)
                                          (compute-islots super class))
                                        chain))))
     (make-instance 'ichain
                   :class class

-                  :chain-head head
+                  :chain-head chain-head
+                  :chain-tail chain-tail

                   :body (cons vtable-pointer islots))))
 
 (defmethod compute-ilayout ((class sod-class))
                   :body (cons vtable-pointer islots))))
 
 (defmethod compute-ilayout ((class sod-class))


@@ -245,9 +252,10 @@ (defmethod compute-sod-effective-method
 (defclass method-entry ()
   ((method :initarg :method :type effective-method
           :reader method-entry-effective-method)
 (defclass method-entry ()
   ((method :initarg :method :type effective-method
           :reader method-entry-effective-method)

-   (chain-head :initarg :chain-head
-              :type sod-class
-              :reader method-entry-chain-head))
+   (chain-head :initarg :chain-head :type sod-class
+              :reader method-entry-chain-head)
+   (chain-tail :initarg :chain-tail :type sod-class
+              :reader method-entry-chain-tail))

   (:documentation
    "An entry point into an effective method.
 
   (:documentation
    "An entry point into an effective method.
 


@@ -265,7 +273,7 @@ (defmethod print-object ((entry method-entry) stream)
            (method-entry-effective-method entry)
            (sod-class-nickname (method-entry-chain-head entry)))))
 
            (method-entry-effective-method entry)
            (sod-class-nickname (method-entry-chain-head entry)))))
 

-(defgeneric make-method-entry (effective-method chain-head)
+(defgeneric make-method-entry (effective-method chain-head chain-tail)

   (:documentation
    "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
 
   (:documentation
    "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
 


@@ -280,12 +288,14 @@ (defclass vtmsgs ()
    (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
    (chain-head :initarg :chain-head :type sod-class
               :reader vtmsgs-chain-head)
    (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
    (chain-head :initarg :chain-head :type sod-class
               :reader vtmsgs-chain-head)

+   (chain-tail :initarg :chain-tail :type sod-class
+              :reader vtmsgs-chain-tail)

    (entries :initarg :entries :type list :reader vtmsgs-entries))
   (:documentation
    "The message dispatch table for a particular CLASS.
 
    (entries :initarg :entries :type list :reader vtmsgs-entries))
   (:documentation
    "The message dispatch table for a particular CLASS.
 

-   The BODY contains a list of effective method objects for the messages
-   defined on CLASS, customized for calling from the chain headed by
+   The BODY contains a list of effective method entry objects for the
+   messages defined on CLASS, customized for calling from the chain headed by

    CHAIN-HEAD."))
 
 (defmethod print-object ((vtmsgs vtmsgs) stream)
    CHAIN-HEAD."))
 
 (defmethod print-object ((vtmsgs vtmsgs) stream)


@@ -295,7 +305,7 @@ (defmethod print-object ((vtmsgs vtmsgs) stream)
            (vtmsgs-class vtmsgs)
            (vtmsgs-entries vtmsgs))))
 
            (vtmsgs-class vtmsgs)
            (vtmsgs-entries vtmsgs))))
 

-(defgeneric compute-vtmsgs (class subclass chain-head)
+(defgeneric compute-vtmsgs (class subclass chain-head chain-tail)

   (:documentation
    "Return a VTMSGS object containing method entries for CLASS.
 
   (:documentation
    "Return a VTMSGS object containing method entries for CLASS.
 


@@ -382,6 +392,8 @@ (defclass vtable ()
   ((class :initarg :class :type sod-class :reader vtable-class)
    (chain-head :initarg :chain-head :type sod-class
               :reader vtable-chain-head)
   ((class :initarg :class :type sod-class :reader vtable-class)
    (chain-head :initarg :chain-head :type sod-class
               :reader vtable-chain-head)

+   (chain-tail :initarg :chain-tail :type sod-class
+              :reader vtable-chain-tail)

    (body :initarg :body :type list :reader vtable-body))
   (:documentation
    "VTABLEs hold all of the per-chain static information for a class.
    (body :initarg :body :type list :reader vtable-body))
   (:documentation
    "VTABLEs hold all of the per-chain static information for a class.


@@ -416,16 +428,18 @@ (defgeneric compute-vtables (class)
 (defmethod compute-vtmsgs
     ((class sod-class)
      (subclass sod-class)
 (defmethod compute-vtmsgs
     ((class sod-class)
      (subclass sod-class)

-     (chain-head sod-class))
+     (chain-head sod-class)
+     (chain-tail sod-class))

   (flet ((make-entry (message)
           (let ((method (find message
                               (sod-class-effective-methods subclass)
                               :key #'effective-method-message)))
   (flet ((make-entry (message)
           (let ((method (find message
                               (sod-class-effective-methods subclass)
                               :key #'effective-method-message)))

-            (make-method-entry method chain-head))))
+            (make-method-entry method chain-head chain-tail))))

     (make-instance 'vtmsgs
                   :class class
                   :subclass subclass
                   :chain-head chain-head
     (make-instance 'vtmsgs
                   :class class
                   :subclass subclass
                   :chain-head chain-head

+                  :chain-tail chain-tail

                   :entries (mapcar #'make-entry
                                    (sod-class-messages class)))))
 
                   :entries (mapcar #'make-entry
                                    (sod-class-messages class)))))
 


@@ -462,7 +476,7 @@ (defmethod make-chain-offset
 (defvar *done-metaclass-chains*)
 (defvar *done-instance-chains*)
 
 (defvar *done-metaclass-chains*)
 (defvar *done-instance-chains*)
 

-(defgeneric compute-vtable-items (class super chain-head emit)
+(defgeneric compute-vtable-items (class super chain-head chain-tail emit)

   (:documentation
    "Emit vtable items for a superclass of CLASS.
 
   (:documentation
    "Emit vtable items for a superclass of CLASS.
 


@@ -482,7 +496,7 @@ (defgeneric compute-vtable-items (class super chain-head emit)
 
 (defmethod compute-vtable-items
     ((class sod-class) (super sod-class) (chain-head sod-class)
 
 (defmethod compute-vtable-items
     ((class sod-class) (super sod-class) (chain-head sod-class)

-     (emit function))
+     (chain-tail sod-class) (emit function))

 
   ;; If this class introduces new metaclass chains, then emit pointers to
   ;; them.
 
   ;; If this class introduces new metaclass chains, then emit pointers to
   ;; them.


@@ -511,10 +525,52 @@ (defmethod compute-vtable-items
 
   ;; Finally, if there are interesting methods, emit those too.
   (when (sod-class-messages super)
 
   ;; Finally, if there are interesting methods, emit those too.
   (when (sod-class-messages super)

-    (funcall emit (compute-vtmsgs super class chain-head))))
+    (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
+
+(defun find-root-superclass (class)
+  "Returns the `root' superclass of CLASS.
+
+   The root superclass is the superclass which itself has no direct
+   superclasses.  In universes not based on the provided builtin module, the
+   root class may not be our beloved SodObject; however, there must be one
+   (otherwise the class graph is cyclic, which should be forbidden), and we
+   instist that it be unique."
+
+  ;; The root superclass must be a chain head since the chains partition the
+  ;; superclasses; the root has no superclasses so it can't have a link and
+  ;; must therefore be a head.  This narrows the field down quite a lot.
+  ;;
+  ;; Note!  This function gets called from CHECK-SOD-CLASS before the class's
+  ;; chains have been computed.  Therefore we iterate over the direct
+  ;; superclass's chains rather than the class's own.  This misses a chain
+  ;; only in the case where the class is its own chain head.  There are two
+  ;; subcases: if there are no direct superclasses at all, then the class is
+  ;; its own root; otherwise, it clearly can't be the root and the omission
+  ;; is harmless.
+  (let* ((supers (sod-class-direct-superclasses class))
+        (roots (if supers
+                   (remove-if #'sod-class-direct-superclasses
+                              (mapcar (lambda (super)
+                                        (sod-class-chain-head super))
+                                      supers))
+                   (list class))))
+    (cond ((null roots) (error "Class ~A has no root class!" class))
+         ((cdr roots) (error "Class ~A has multiple root classes ~
+                              ~{~A~#[~; and ~;, ~]~}"
+                             class roots))
+         (t (car roots)))))
+
+(defun find-root-metaclass (class)
+  "Returns the `root' metaclass of CLASS.
+
+   The root metaclass is the metaclass of the root superclass -- see
+   FIND-ROOT-SUPERCLASS."
+  (sod-class-metaclass (find-root-superclass class)))

 
 (defmethod compute-vtable ((class sod-class) (chain list))
   (let* ((chain-head (car chain))
 
 (defmethod compute-vtable ((class sod-class) (chain list))
   (let* ((chain-head (car chain))

+        (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
+                          :key #'sod-class-chain-head))

         (*done-metaclass-chains* nil)
         (*done-instance-chains* (list chain-head))
         (done-superclasses nil)
         (*done-metaclass-chains* nil)
         (*done-instance-chains* (list chain-head))
         (done-superclasses nil)


@@ -524,17 +580,11 @@ (defmethod compute-vtable ((class sod-class) (chain list))
 
       ;; Find the root chain in the metaclass and write a pointer.
       (let* ((metaclass (sod-class-metaclass class))
 
       ;; Find the root chain in the metaclass and write a pointer.
       (let* ((metaclass (sod-class-metaclass class))

-            (metaclass-chains (sod-class-chains metaclass))
-            (metaclass-chain-heads (mapcar (lambda (chain)
-                                             (sod-class-chain-head
-                                              (car chain)))
-                                           metaclass-chains))
-            (metaclass-root-chain (find-if-not
-                                   #'sod-class-direct-superclasses
-                                   metaclass-chain-heads)))
-       (emit (make-class-pointer class chain-head
-                                 metaclass metaclass-root-chain))
-       (push metaclass-root-chain *done-metaclass-chains*))
+            (metaclass-root (find-root-metaclass class))
+            (metaclass-root-head (sod-class-chain-head metaclass-root)))
+       (emit (make-class-pointer class chain-head metaclass
+                                 metaclass-root-head))
+       (push metaclass-root-head *done-metaclass-chains*))

 
       ;; Write an offset to the instance base.
       (emit (make-base-offset class chain-head))
 
       ;; Write an offset to the instance base.
       (emit (make-base-offset class chain-head))


@@ -548,6 +598,7 @@ (defmethod compute-vtable ((class sod-class) (chain list))
            (compute-vtable-items class
                                  sub
                                  chain-head
            (compute-vtable-items class
                                  sub
                                  chain-head

+                                 chain-tail

                                  #'emit)
            (push sub done-superclasses))))
 
                                  #'emit)
            (push sub done-superclasses))))
 


@@ -555,6 +606,7 @@ (defmethod compute-vtable ((class sod-class) (chain list))
       (make-instance 'vtable
                     :class class
                     :chain-head chain-head
       (make-instance 'vtable
                     :class class
                     :chain-head chain-head

+                    :chain-tail chain-tail

                     :body (nreverse items)))))
 
 (defgeneric compute-effective-methods (class)
                     :body (nreverse items)))))
 
 (defgeneric compute-effective-methods (class)


@@ -582,7 +634,10 @@ (defun islots-struct-tag (class)
   (format nil "~A__islots" class))
 
 (defun ichain-struct-tag (class chain-head)
   (format nil "~A__islots" class))
 
 (defun ichain-struct-tag (class chain-head)

-  (format nil "~A__ichain_~A" class(sod-class-nickname chain-head)))
+  (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))
+
+(defun ichain-union-tag (class chain-head)
+  (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))

 
 (defun ilayout-struct-tag (class)
   (format nil "~A__ilayout" class))
 
 (defun ilayout-struct-tag (class)
   (format nil "~A__ilayout" class))


@@ -596,28 +651,4 @@ (defun vtable-struct-tag (class chain-head)
 (defun vtable-name (class chain-head)
   (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
 
 (defun vtable-name (class chain-head)
   (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
 

-;;;--------------------------------------------------------------------------
-;;; Hacks for now.
-
-(defclass hacky-effective-method (effective-method)
-  ((direct-methods :initarg :direct-methods)))
-
-(defmethod print-object ((method hacky-effective-method) stream)
-  (if *print-escape*
-      (print-unreadable-object (method stream :type t)
-       (format stream "~A ~_~A ~_~:<~@{~S~^ ~_~}~:>"
-               (effective-method-message method)
-               (effective-method-class method)
-               (slot-value method 'direct-methods)))
-      (call-next-method)))
-
-(defmethod message-effective-method-class ((message sod-message))
-  'hacky-effective-method)
-
-(defmethod make-method-entry
-    ((method hacky-effective-method) (chain-head sod-class))
-  (make-instance 'method-entry
-                :method method
-                :chain-head chain-head))
-

 ;;;----- That's all, folks --------------------------------------------------
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/class-output.lisp b/class-output.lisp
index 8fdcc822ad2bfda24450e3e58dfb784dbf468df6..dc07665e5511615409d0506c584366fbc3f734f5 100644 (file)
--- a/class-output.lisp
+++ b/class-output.lisp
@@ -74,10 +74,11 @@ (defmethod add-output-hooks progn
      (class :vtmsgs :start) (class :vtmsgs :end)
      (class :vtables :start) (class :vtables :end)
      (class :vtable-externs) (class :vtable-externs-after)
      (class :vtmsgs :start) (class :vtmsgs :end)
      (class :vtables :start) (class :vtables :end)
      (class :vtable-externs) (class :vtable-externs-after)

-     (class :direct-methods)
+     (class :methods :start) (class :methods) (class :methods :end)

      (class :ichains :start) (class :ichains :end)
      (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
      (class :conversions)
      (class :ichains :start) (class :ichains :end)
      (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
      (class :conversions)

+     (class :object)

      (:classes :end))
 
     (:typedefs
      (:classes :end))
 
     (:typedefs


@@ -87,7 +88,20 @@ (defmethod add-output-hooks progn
     ((class :banner)
      (banner (format nil "Class ~A" class) stream))
     ((class :vtable-externs-after)
     ((class :banner)
      (banner (format nil "Class ~A" class) stream))
     ((class :vtable-externs-after)

-     (terpri stream)))
+     (terpri stream))
+
+    ((class :vtable-externs)
+     (format stream "/* Vtable structures. */~%"))
+
+    ((class :object)
+     (let ((metaclass (sod-class-metaclass class))
+          (metaroot (find-root-metaclass class)))
+       (format stream "/* The class object. */~%~
+                      extern struct ~A ~A__classobj;~%~
+                      #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
+              (ilayout-struct-tag metaclass) class
+              (sod-class-nickname (sod-class-chain-head metaroot))
+              (sod-class-nickname metaroot)))))

 
   ;; Maybe generate an islots structure.
   (when (sod-class-slots class)
 
   ;; Maybe generate an islots structure.
   (when (sod-class-slots class)


@@ -95,16 +109,18 @@ (defmethod add-output-hooks progn
       (add-output-hooks slot 'populate-islots sequencer))
     (sequence-output (stream sequencer)
       ((class :islots :start)
       (add-output-hooks slot 'populate-islots sequencer))
     (sequence-output (stream sequencer)
       ((class :islots :start)

-       (format stream "struct ~A {~%" (islots-struct-tag class)))
+       (format stream "/* Instance slots. */~%~
+                      struct ~A {~%"
+              (islots-struct-tag class)))

       ((class :islots :end)
        (format stream "};~2%"))))
 
   ;; Declare the direct methods.
   (when (sod-class-methods class)
       ((class :islots :end)
        (format stream "};~2%"))))
 
   ;; Declare the direct methods.
   (when (sod-class-methods class)

-    (dolist (method (sod-class-methods class))
-      (add-output-hooks method :declare-direct-methods sequencer))

     (sequence-output (stream sequencer)
     (sequence-output (stream sequencer)

-      ((class :direct-methods)
+      ((class :methods :start)
+       (format stream "/* Direct methods. */~%"))
+      ((class :methods :end)

        (terpri stream))))
 
   ;; Provide upcast macros which do the right thing.
        (terpri stream))))
 
   ;; Provide upcast macros which do the right thing.


@@ -112,14 +128,15 @@ (defmethod add-output-hooks progn
     (sequence-output (stream sequencer)
       ((class :conversions)
        (let ((chain-head (sod-class-chain-head class)))
     (sequence-output (stream sequencer)
       ((class :conversions)
        (let ((chain-head (sod-class-chain-head class)))

+        (format stream "/* Conversion macros. */~%")

         (dolist (super (cdr (sod-class-precedence-list class)))
           (let ((super-head (sod-class-chain-head super)))
         (dolist (super (cdr (sod-class-precedence-list class)))
           (let ((super-head (sod-class-chain-head super)))

-            (format stream (concatenate 'string "#define "
-                                        "~:@(~A__CONV_~A~)(p) ((~A *)"
-                                        "~:[SOD_XCHAIN(~A, p)~;p~])~%")
+            (format stream "#define ~:@(~A__CONV_~A~)(p) ((~A *)~
+                                    ~:[SOD_XCHAIN(~A, (p))~;(p)~])~%"

                     class (sod-class-nickname super) super
                     (eq chain-head super-head)
                     class (sod-class-nickname super) super
                     (eq chain-head super-head)

-                    (sod-class-nickname super-head))))))))
+                    (sod-class-nickname super-head))))
+        (terpri stream)))))

 
   ;; Generate vtmsgs structure for all superclasses.
   (add-output-hooks (car (sod-class-vtables class))
 
   ;; Generate vtmsgs structure for all superclasses.
   (add-output-hooks (car (sod-class-vtables class))


@@ -127,8 +144,9 @@ (defmethod add-output-hooks progn
                    sequencer))
 
 (defmethod add-output-hooks progn ((class sod-class) reason sequencer)
                    sequencer))
 
 (defmethod add-output-hooks progn ((class sod-class) reason sequencer)

-  (with-slots (ilayout vtables) class
+  (with-slots (ilayout vtables methods) class

     (add-output-hooks ilayout reason sequencer)
     (add-output-hooks ilayout reason sequencer)

+    (dolist (method methods) (add-output-hooks method reason sequencer))

     (dolist (vtable vtables) (add-output-hooks vtable reason sequencer))))
 
 ;;;--------------------------------------------------------------------------
     (dolist (vtable vtables) (add-output-hooks vtable reason sequencer))))
 
 ;;;--------------------------------------------------------------------------


@@ -151,7 +169,9 @@ (defmethod add-output-hooks progn
   (with-slots (class ichains) ilayout
     (sequence-output (stream sequencer)
       ((class :ilayout :start)
   (with-slots (class ichains) ilayout
     (sequence-output (stream sequencer)
       ((class :ilayout :start)

-       (format stream "struct ~A {~%" (ilayout-struct-tag class)))
+       (format stream "/* Instance layout. */~%~
+                      struct ~A {~%"
+              (ilayout-struct-tag class)))

       ((class :ilayout :end)
        (format stream "};~2%")))
     (dolist (ichain ichains)
       ((class :ilayout :end)
        (format stream "};~2%")))
     (dolist (ichain ichains)


@@ -159,38 +179,46 @@ (defmethod add-output-hooks progn
 
 (defmethod add-output-hooks progn
     ((ichain ichain) (reason (eql :h)) sequencer)
 
 (defmethod add-output-hooks progn
     ((ichain ichain) (reason (eql :h)) sequencer)

-  (with-slots (class chain-head) ichain
-    (sequence-output (stream sequencer)
-      :constraint ((class :ichains :start)
-                  (class :ichain chain-head :start)
-                  (class :ichain chain-head :slots)
-                  (class :ichain chain-head :end)
-                  (class :ichains :end))
-      ((class :ichain chain-head :start)
-       (format stream "struct ~A {~%" (ichain-struct-tag class chain-head)))
-      ((class :ichain chain-head :end)
-       (format stream "};~2%")))))
+  (with-slots (class chain-head chain-tail) ichain
+    (when (eq class chain-tail)
+      (sequence-output (stream sequencer)
+       :constraint ((class :ichains :start)
+                    (class :ichain chain-head :start)
+                    (class :ichain chain-head :slots)
+                    (class :ichain chain-head :end)
+                    (class :ichains :end))
+       ((class :ichain chain-head :start)
+        (format stream "/* Instance chain structure. */~%~
+                        struct ~A {~%"
+                (ichain-struct-tag chain-tail chain-head)))
+       ((class :ichain chain-head :end)
+        (format stream "};~2%")
+        (format stream "/* Union of equivalent superclass chains. */~%~
+                        union ~A {~%~
+                        ~:{  struct ~A ~A;~%~}~
+                        };~2%"
+                (ichain-union-tag chain-tail chain-head)
+                (mapcar (lambda (super)
+                          (list (ichain-struct-tag super chain-head)
+                                (sod-class-nickname super)))
+                        (sod-class-chain chain-tail))))))))

 
 (defmethod add-output-hooks progn
     ((ichain ichain) (reason (eql 'populate-ilayout)) sequencer)
 
 (defmethod add-output-hooks progn
     ((ichain ichain) (reason (eql 'populate-ilayout)) sequencer)

-  (with-slots (class chain-head) ichain
+  (with-slots (class chain-head chain-tail) ichain

     (sequence-output (stream sequencer)
       ((class :ilayout :slots)
     (sequence-output (stream sequencer)
       ((class :ilayout :slots)

-       (format stream "  struct ~A ~A;~%"
-              (ichain-struct-tag class chain-head)
+       (format stream "  union ~A ~A;~%"
+              (ichain-union-tag chain-tail chain-head)

               (sod-class-nickname chain-head))))))
 
               (sod-class-nickname chain-head))))))
 

-(defmethod add-output-hooks progn ((ichain ichain) reason sequencer)
-  (with-slots (body) ichain
-    (dolist (item body) (add-output-hooks item reason sequencer))))
-

 (defmethod add-output-hooks progn
     ((vtptr vtable-pointer) (reason (eql :h)) sequencer)
 (defmethod add-output-hooks progn
     ((vtptr vtable-pointer) (reason (eql :h)) sequencer)

-  (with-slots (class chain-head) vtptr
+  (with-slots (class chain-head chain-tail) vtptr

     (sequence-output (stream sequencer)
       ((class :ichain chain-head :slots)
        (format stream "  const struct ~A *_vt;~%"
     (sequence-output (stream sequencer)
       ((class :ichain chain-head :slots)
        (format stream "  const struct ~A *_vt;~%"

-              (vtable-struct-tag class chain-head))))))
+              (vtable-struct-tag chain-tail chain-head))))))

 
 (defmethod add-output-hooks progn
     ((islots islots) (reason (eql :h)) sequencer)
 
 (defmethod add-output-hooks progn
     ((islots islots) (reason (eql :h)) sequencer)


@@ -208,27 +236,42 @@ (defmethod add-output-hooks progn ((vtable vtable) reason sequencer)
   (with-slots (body) vtable
     (dolist (item body) (add-output-hooks item reason sequencer))))
 
   (with-slots (body) vtable
     (dolist (item body) (add-output-hooks item reason sequencer))))
 

+(defmethod add-output-hooks progn
+    ((method sod-method) (reason (eql :h)) sequencer)
+  (with-slots (class) method
+    (sequence-output (stream sequencer)
+      ((class :methods)
+       (let ((type (sod-method-function-type method)))
+        (princ "extern " stream)
+        (pprint-c-type (commentify-function-type type) stream
+                       (sod-method-function-name method))
+        (format stream ";~%"))))))
+

 (defmethod add-output-hooks progn
     ((vtable vtable) (reason (eql :h)) sequencer)
 (defmethod add-output-hooks progn
     ((vtable vtable) (reason (eql :h)) sequencer)

-  (with-slots (class chain-head) vtable
+  (with-slots (class chain-head chain-tail) vtable
+    (when (eq class chain-tail)
+      (sequence-output (stream sequencer)
+       :constraint ((class :vtables :start)
+                    (class :vtable chain-head :start)
+                    (class :vtable chain-head :slots)
+                    (class :vtable chain-head :end)
+                    (class :vtables :end))
+       ((class :vtable chain-head :start)
+        (format stream "/* Vtable structure. */~%~
+                        struct ~A {~%"
+                (vtable-struct-tag chain-tail chain-head)))
+       ((class :vtable chain-head :end)
+        (format stream "};~2%"))))

     (sequence-output (stream sequencer)
     (sequence-output (stream sequencer)

-      :constraint ((class :vtables :start)
-                  (class :vtable chain-head :start)
-                  (class :vtable chain-head :slots)
-                  (class :vtable chain-head :end)
-                  (class :vtables :end))
-      ((class :vtable chain-head :start)
-       (format stream "struct ~A {~%" (vtable-struct-tag class chain-head)))
-      ((class :vtable chain-head :end)
-       (format stream "};~2%"))

       ((class :vtable-externs)
        (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
       ((class :vtable-externs)
        (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"

-              (vtable-struct-tag class chain-head)
+              (vtable-struct-tag chain-tail chain-head)

               class (sod-class-nickname chain-head))))))
 
 (defmethod add-output-hooks progn
     ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
               class (sod-class-nickname chain-head))))))
 
 (defmethod add-output-hooks progn
     ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)

-  (with-slots (class subclass chain-head) vtmsgs
+  (with-slots (class subclass chain-head chain-tail) vtmsgs

     (sequence-output (stream sequencer)
       ((subclass :vtable chain-head :slots)
        (format stream "  struct ~A ~A;~%"
     (sequence-output (stream sequencer)
       ((subclass :vtable chain-head :slots)
        (format stream "  struct ~A ~A;~%"


@@ -246,7 +289,10 @@ (defmethod add-output-hooks progn
                     (subclass :vtmsgs class :end)
                     (subclass :vtmsgs :end))
        ((subclass :vtmsgs class :start)
                     (subclass :vtmsgs class :end)
                     (subclass :vtmsgs :end))
        ((subclass :vtmsgs class :start)

-        (format stream "struct ~A {~%" (vtmsgs-struct-tag subclass class)))
+        (format stream "/* Messages protocol from class ~A */~%~
+                        struct ~A {~%"
+                class
+                (vtmsgs-struct-tag subclass class)))

        ((subclass :vtmsgs class :end)
         (format stream "};~2%"))))))
 
        ((subclass :vtmsgs class :end)
         (format stream "};~2%"))))))
 


@@ -259,19 +305,16 @@ (defmethod add-output-hooks progn ((entry method-entry) reason sequencer)
     (add-output-hooks method reason sequencer)))
 
 (defmethod add-output-hooks progn
     (add-output-hooks method reason sequencer)))
 
 (defmethod add-output-hooks progn

-    ((method effective-method) (reason (eql 'populate-vtmsgs)) sequencer)
-  (let* ((message (effective-method-message method))
+    ((entry method-entry) (reason (eql 'populate-vtmsgs)) sequencer)
+  (let* ((method (method-entry-effective-method entry))
+        (message (effective-method-message method))

         (class (effective-method-class method))
         (class (effective-method-class method))

-        (class-type (find-class-type (sod-class-name class)))
-        (raw-type (sod-message-type message))
-        (type (c-type (* (fun (lisp (c-type-subtype raw-type))
-                              ("/*me*/" (* (lisp class-type)))
-                              . (commentify-argument-names
-                                 (c-function-arguments raw-type)))))))
+        (type (method-entry-function-type entry))
+        (commented-type (commentify-function-type type)))

     (sequence-output (stream sequencer)
       ((class :vtmsgs (sod-message-class message) :slots)
        (pprint-logical-block (stream nil :prefix "  " :suffix ";")
     (sequence-output (stream sequencer)
       ((class :vtmsgs (sod-message-class message) :slots)
        (pprint-logical-block (stream nil :prefix "  " :suffix ";")

-        (pprint-c-type type stream (sod-message-name message)))
+        (pprint-c-type commented-type stream (sod-message-name message)))

        (terpri stream)))))
 
 (defmethod add-output-hooks progn
        (terpri stream)))))
 
 (defmethod add-output-hooks progn

diff --git a/examples.lisp b/examples.lisp
index 92489dd45c80181dac92dccba61f088025b6dc9f..cda6bcf56c521fdec852e6299d12d7efadc67361 100644 (file)
--- a/examples.lisp
+++ b/examples.lisp
@@ -1,60 +1,60 @@
 (set-dispatch-macro-character #\# #\{ 'c-fragment-reader)
 
 (set-dispatch-macro-character #\# #\{ 'c-fragment-reader)
 

-(progn
-  (clear-the-decks)
-
-  (define-sod-class "Animal" ("SodObject")
-    :nick 'nml
-    :link '|SodObject|
-    (slot "tickles" int)
-    (instance-initializer "nml" "tickles" :single #{ 0 })
-    (message "tickle" (fun void))
-    (method "nml" "tickle" (fun void) #{
-       me->tickles++;
-     }
-     :role :before)
-    (method "nml" "tickle" (fun void) #{ }))
-
-  (define-sod-class "Lion" ("Animal")
-    :nick 'lion
-    :link '|Animal|
-    (message "bite" (fun void))
-    (method "lion" "bite" (fun void) nil)
-    (method "nml" "tickle" (fun void) #{
-       me->_vt->lion.bite(me);
-       CALL_NEXT_METHOD;
-     }))
-
-  (define-sod-class "Goat" ("Animal")
-    :nick 'goat
-    (message "butt" (fun void))
-    (method "goat" "butt" (fun void) nil)
-    (method "nml" "tickle" (fun void) #{
-       me->_vt->goat.bite(me);
-       CALL_NEXT_METHOD;
-     }))
-
-  (define-sod-class "Serpent" ("Animal")
-    :nick 'serpent
-    (message "bite" (fun void))
-    (method "serpent" "bite" (fun void) nil)
-    (message "hiss" (fun void))
-    (method "serpent" "hiss" (fun void) nil)
-    (method "nml" "tickle" (fun void) #{
-       if (me->tickles < 3) me->_vt->hiss(me);
-       else me->_vt->bite(me);
-       CALL_NEXT_METHOD;
-     }))
-
-  (define-sod-class "Chimaera" ("Lion" "Goat" "Serpent")
-    :nick 'sir
-    :link '|Lion|)
-
-  (defparameter *chimaera* (find-sod-class "Chimaera"))
-  (defparameter *emeth* (find "tickle"
-                             (sod-class-effective-methods *chimaera*)
-                             :key (lambda (method)
-                                    (sod-message-name
-                                     (effective-method-message method)))
-                             :test #'string=)))
+(defparameter *chimaera-module*
+  (define-module ("chimaera.sod")
+
+    (define-sod-class "Animal" ("SodObject")
+      :nick 'nml
+      :link '|SodObject|
+      (slot "tickles" int)
+      (instance-initializer "nml" "tickles" :single #{ 0 })
+      (message "tickle" (fun void))
+      (method "nml" "tickle" (fun void) #{
+        me->tickles++;
+       }
+       :role :before)
+      (method "nml" "tickle" (fun void) #{ }))
+
+    (define-sod-class "Lion" ("Animal")
+      :nick 'lion
+      :link '|Animal|
+      (message "bite" (fun void))
+      (method "lion" "bite" (fun void) nil)
+      (method "nml" "tickle" (fun void) #{
+        me->_vt->lion.bite(me);
+        CALL_NEXT_METHOD;
+       }))
+
+    (define-sod-class "Goat" ("Animal")
+      :nick 'goat
+      (message "butt" (fun void))
+      (method "goat" "butt" (fun void) nil)
+      (method "nml" "tickle" (fun void) #{
+        me->_vt->goat.bite(me);
+        CALL_NEXT_METHOD;
+       }))
+
+    (define-sod-class "Serpent" ("Animal")
+      :nick 'serpent
+      (message "bite" (fun void))
+      (method "serpent" "bite" (fun void) nil)
+      (message "hiss" (fun void))
+      (method "serpent" "hiss" (fun void) nil)
+      (method "nml" "tickle" (fun void) #{
+        if (me->tickles < 3) me->_vt->hiss(me);
+        else me->_vt->bite(me);
+        CALL_NEXT_METHOD;
+       }))
+
+    (define-sod-class "Chimaera" ("Lion" "Goat" "Serpent")
+      :nick 'sir
+      :link '|Lion|)
+
+    (defparameter *chimaera* (find-sod-class "Chimaera"))
+    (defparameter *emeth* (find "tickle"
+                               (sod-class-effective-methods *chimaera*)
+                               :key (lambda (method)
+                                      (sod-message-name
+                                       (effective-method-message method)))
+                               :test #'string=))))

 
 

diff --git a/lex.lisp b/lex.lisp
index 1583b1180c0417eaacc7e9797a426b2953693416..2d1c4de2e5b352df4efd63d35dccb2cab9d9ac33 100644 (file)
--- a/lex.lisp
+++ b/lex.lisp
@@ -231,8 +231,7 @@ (defparameter *sod-keywords*
    "struct" "union" "enum"))
 
 (defclass sod-lexer (lexer)
    "struct" "union" "enum"))
 
 (defclass sod-lexer (lexer)

-  ((keywords :initarg :keywords :initform *sod-keywords*
-            :type hash-table :reader lexer-keywords))
+  ()

   (:documentation
    "Lexical analyser for the SOD lanuage.
 
   (:documentation
    "Lexical analyser for the SOD lanuage.
 


@@ -310,9 +309,8 @@ (defmethod scan-token ((lexer sod-lexer))
                                           (char= ch #\_))))
                          (return))))))
 
                                           (char= ch #\_))))
                          (return))))))
 

-           ;; Check to see whether we match any keywords.
-           (multiple-value-bind (keyword foundp) (gethash id keywords)
-             (return (values (if foundp keyword :id) id)))))
+           ;; Done.
+           (return (values :id id))))

 
         ;; Pick out numbers.  Currently only integers, but we support
         ;; multiple bases.
 
         ;; Pick out numbers.  Currently only integers, but we support
         ;; multiple bases.

diff --git a/methods.lisp b/methods.lisp
index 0fbb3f07e514ca7349f9422e1f30d5fa18137305..67033daf159ce65baee02c85f6809fb121f447f8 100644 (file)
--- a/methods.lisp
+++ b/methods.lisp
@@ -42,7 +42,7 @@ (defgeneric sod-message-no-varargs-tail (message)
    However, an :ELLIPSIS is replaced by an argument of type `va_list', named
    `sod__ap'."))
 
    However, an :ELLIPSIS is replaced by an argument of type `va_list', named
    `sod__ap'."))
 

-(defgeneric direct-method-function-type (method)
+(defgeneric sod-method-function-type (method)

   (:documentation
    "Return the C function type for the direct method.
 
   (:documentation
    "Return the C function type for the direct method.
 


@@ -53,7 +53,7 @@ (defgeneric direct-method-function-type (method)
    prepends an appropriate `me' argument to the user-provided argument list.
    Fancy method classes may need to override this behaviour."))
 
    prepends an appropriate `me' argument to the user-provided argument list.
    Fancy method classes may need to override this behaviour."))
 

-(defgeneric direct-method-next-method-type (method)
+(defgeneric sod-method-next-method-type (method)

   (:documentation
    "Return the C function type for the next-method trampoline.
 
   (:documentation
    "Return the C function type for the next-method trampoline.
 


@@ -64,10 +64,14 @@ (defgeneric direct-method-next-method-type (method)
    the right job.  Very fancy subclasses might need to do something
    different."))
 
    the right job.  Very fancy subclasses might need to do something
    different."))
 

-(defgeneric direct-method-function-name (method)
+(defgeneric sod-method-function-name (method)

   (:documentation
    "Return the C function name for the direct method."))
 
   (:documentation
    "Return the C function name for the direct method."))
 

+(defgeneric method-entry-function-type (entry)
+  (:documentation
+   "Return the C function type for a method entry."))
+

 ;;;--------------------------------------------------------------------------
 ;;; Message classes.
 
 ;;;--------------------------------------------------------------------------
 ;;; Message classes.
 


@@ -162,7 +166,7 @@ (defmethod slot-unbound
                       ("me" (* (class (sod-method-class method))))
                       . (c-function-arguments type))))))
 
                       ("me" (* (class (sod-method-class method))))
                       . (c-function-arguments type))))))
 

-(defmethod direct-method-function-name ((method basic-direct-method))
+(defmethod sod-method-function-name ((method basic-direct-method))

   (with-slots (class role message) method
     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
            (sod-class-nickname (sod-message-class message))
   (with-slots (class role message) method
     (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
            (sod-class-nickname (sod-message-class message))


@@ -377,7 +381,7 @@ (defun invoke-method (codegen target arguments-tail direct-method)
 
   (let* ((message (sod-method-message direct-method))
         (class (sod-method-class direct-method))
 
   (let* ((message (sod-method-message direct-method))
         (class (sod-method-class direct-method))

-        (function (direct-method-function-name direct-method))
+        (function (sod-method-function-name direct-method))

         (arguments (cons (format nil "(~A *)&sod__obj.~A" class
                                  (sod-class-nickname
                                   (sod-class-chain-head class)))
         (arguments (cons (format nil "(~A *)&sod__obj.~A" class
                                  (sod-class-nickname
                                   (sod-class-chain-head class)))


@@ -444,7 +448,7 @@ (defun make-trampoline (codegen super body)
     (codegen-pop-function codegen (temporary-function)
                          (c-type (fun (lisp return-type)
                                       ("me" (* (class super)))
     (codegen-pop-function codegen (temporary-function)
                          (c-type (fun (lisp return-type)
                                       ("me" (* (class super)))

-                                      . arguments))))))
+                                      . arguments)))))

 
 (defun invoke-delegation-chain (codegen target basic-tail chain kernel)
   "Invoke a chain of delegating methods.
 
 (defun invoke-delegation-chain (codegen target basic-tail chain kernel)
   "Invoke a chain of delegating methods.


@@ -705,8 +709,19 @@ (defmethod slot-unbound
   (setf (slot-value method 'functions)
        (compute-method-entry-functions method)))
 
   (setf (slot-value method 'functions)
        (compute-method-entry-functions method)))
 

-(defmethod make-method-entry
-    ((method basic-effective-method) (chain-head sod-class))
-  (make-instance 'method-entry :method method :chain-head chain-head))
+(defmethod method-entry-function-type ((entry method-entry))
+  (let* ((method (method-entry-effective-method entry))
+        (message (effective-method-message method))
+        (type (sod-message-type message)))
+    (c-type (fun (lisp (c-type-subtype type))
+                ("me" (* (class (method-entry-chain-tail entry))))
+                . (sod-message-argument-tail message)))))
+
+(defmethod make-method-entry ((method basic-effective-method)
+                             (chain-head sod-class) (chain-tail sod-class))
+  (make-instance 'method-entry
+                :method method
+                :chain-head chain-head
+                :chain-tail chain-tail))

 
 ;;;----- That's all, folks --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/module-output.lisp b/module-output.lisp
new file mode 100644 (file)
index 0000000..3ec6aee
--- /dev/null
+++ b/module-output.lisp
@@ -0,0 +1,126 @@
+;;; -*-lisp-*-
+;;;
+;;; Output handling for modules
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun banner (title output &key (blank-line-p t))
+  (format output "~&/*----- ~A ~A*/~%"
+         title
+         (make-string (- 77 2 5 1 (length title) 1 2)
+                      :initial-element #\-))
+  (when blank-line-p
+    (terpri output)))
+
+(defun guard-name (filename)
+  "Return a sensible inclusion guard name for FILENAME."
+  (with-output-to-string (guard)
+    (let* ((pathname (make-pathname :name (pathname-name filename)
+                                   :type (pathname-type filename)))
+          (name (namestring pathname))
+          (uscore t))
+      (dotimes (i (length name))
+       (let ((ch (char name i)))
+         (cond ((alphanumericp ch)
+                (write-char (char-upcase ch) guard)
+                (setf uscore nil))
+               ((not uscore)
+                (write-char #\_ guard)
+                (setf uscore t))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Driving output.
+
+(defun guess-output-file (module type)
+  (merge-pathnames (make-pathname :type type :case :common)
+                  (module-name module)))
+
+(defun output-module (module reason stream)
+  (let ((sequencer (make-instance 'sequencer)))
+    (add-output-hooks module reason sequencer)
+    (invoke-sequencer-items sequencer stream)))
+
+;;;--------------------------------------------------------------------------
+;;; Main output protocol implementation.
+
+(defmethod add-output-hooks progn ((module module) reason sequencer)
+  (dolist (item (module-items module))
+    (add-output-hooks item reason sequencer)))
+
+;;;--------------------------------------------------------------------------
+;;; Header output.
+
+(defmethod add-output-hooks progn
+    ((module module) (reason (eql :h)) sequencer)
+  (sequence-output (stream sequencer)
+    :constraint (:prologue
+                (:guard :start)
+                (:typedefs :start) :typedefs (:typedefs :end)
+                (:includes :start) :includes (:includes :end)
+                (:classes :start) (:classes :end)
+                (:guard :end)
+                :epilogue)
+
+    (:prologue
+     (format stream "~
+/* -*-c-*-
+ *
+ * Header file generated by SOD for ~A
+ */~2%"
+            (namestring (module-name module))))
+
+    ((:guard :start)
+     (format stream "~
+#ifndef ~A
+#define ~:*~A
+
+#ifdef __cplusplus
+  extern \"C\" {
+#endif~2%"
+            (or (get-property (module-pset module) :guard :id)
+                (guard-name (or (stream-pathname stream)
+                                (guess-output-file module "H"))))))
+    ((:guard :end)
+     (banner "That's all, folks" stream)
+     (format stream "~
+#ifdef __cplusplus
+  }
+#endif
+
+#endif~%"))
+
+    ((:typedefs :start)
+     (banner "Forward type declarations" stream))
+    ((:typedefs :end)
+     (terpri stream))
+
+    ((:includes :start)
+     (banner "External header files" stream))
+    ((:includes :end)
+     (terpri stream))))
+
+;;;----- That's all, folks --------------------------------------------------

diff --git a/module.lisp b/module.lisp
index 36b2c85853415509feb55fb12e2dbd57cdba75a2..5d05365f2ccdbabb194646edc7854ddf0e4dbe8e 100644 (file)
--- a/module.lisp
+++ b/module.lisp
@@ -131,6 +131,30 @@ (defmethod finalize-module ((module module))
 ;;;--------------------------------------------------------------------------
 ;;; Module importing.
 
 ;;;--------------------------------------------------------------------------
 ;;; Module importing.
 

+(defun build-module
+    (name body-func &key (truename (probe-file name)) location)
+  (let ((*module* (make-instance 'module
+                                :name (pathname name)
+                                :state (file-location location)))
+       (*type-map* (make-hash-table :test #'equal)))
+    (module-import *builtin-module*)
+    (when truename
+      (setf (gethash truename *module-map*) *module*))
+    (unwind-protect
+        (progn
+          (funcall body-func)
+          (finalize-module *module*))
+      (when (and truename (not (eq (module-state *module*) t)))
+       (remhash truename *module-map*)))))
+
+(defmacro define-module
+    ((name &key (truename nil truenamep) (location nil locationp))
+     &body body)
+  `(build-module ,name
+                (lambda () ,@body)
+                ,@(and truenamep `(:truename ,truename))
+                ,@(and locationp `(:location ,location))))
+

 (defun read-module (pathname &key (truename (truename pathname)) location)
   "Reads a module.
 
 (defun read-module (pathname &key (truename (truename pathname)) location)
   "Reads a module.
 


@@ -152,26 +176,17 @@ (defun read-module (pathname &key (truename (truename pathname)) location)
 
   ;; Make a new module.  Be careful to remove the module from the map if we
   ;; didn't succeed in constructing it.
 
   ;; Make a new module.  Be careful to remove the module from the map if we
   ;; didn't succeed in constructing it.

-  (let ((*module* (make-instance 'module
-                                :name pathname
-                                :state (file-location location)))
-       (*type-map* (make-hash-table :test #'equal)))
-    (module-import *builtin-module*)
-    (setf (gethash truename *module-map*) *module*)
-    (unwind-protect
-        (with-open-file (f-stream pathname :direction :input)
-          (let* ((*module* (make-instance 'module :name pathname))
-                 (pai-stream (make-instance 'position-aware-input-stream
-                                            :stream f-stream
-                                            :file pathname))
-                 (lexer (make-instance 'sod-lexer :stream pai-stream)))
-            (with-default-error-location (lexer)
-              (next-char lexer)
-              (next-token lexer)
-              (parse-module lexer *module*)
-              (finalize-module *module*))))
-      (unless (eq (module-state *module*) t)
-       (remhash truename *module-map*)))))
+  (define-module (pathname :location location :truename truename)
+    (let ((*readtable* (copy-readtable)))
+      (with-open-file (f-stream pathname :direction :input)
+       (let* ((pai-stream (make-instance 'position-aware-input-stream
+                                         :stream f-stream
+                                         :file pathname))
+              (lexer (make-instance 'sod-lexer :stream pai-stream)))
+         (with-default-error-location (lexer)
+           (next-char lexer)
+           (next-token lexer)
+           (parse-module lexer *module*)))))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Module parsing protocol.
 
 ;;;--------------------------------------------------------------------------
 ;;; Module parsing protocol.

diff --git a/output.lisp b/output.lisp
index 05be7f84afa5f9586452639437a2d63dfa41d98b..b0df32bfb8758df1d95bacca0963bd570adcc456 100644 (file)
--- a/output.lisp
+++ b/output.lisp
@@ -152,14 +152,6 @@ (defmethod add-output-hooks :around (object reason sequencer &rest stuff)
 ;;;--------------------------------------------------------------------------
 ;;; Utilities.
 
 ;;;--------------------------------------------------------------------------
 ;;; Utilities.
 

-(defun banner (title output &key (blank-line-p t))
-  (format output "~&~%/*----- ~A ~A*/~%"
-         title
-         (make-string (- 77 2 5 1 (length title) 1 2)
-                      :initial-element #\-))
-  (when blank-line-p
-    (terpri output)))
-

 ;;;--------------------------------------------------------------------------
 ;;; Header output.
 
 ;;;--------------------------------------------------------------------------
 ;;; Header output.
 


@@ -191,17 +183,7 @@ (defun write-module-header (module)
 #endif~%"
                (namestring (module-name module))
                (or (getf (module-plist module) 'include-guard)
 #endif~%"
                (namestring (module-name module))
                (or (getf (module-plist module) 'include-guard)

-                   (with-output-to-string (guard)
-                     (let ((name (namestring file))
-                           (uscore t))
-                       (dotimes (i (length name))
-                         (let ((ch (char name i)))
-                           (cond ((alphanumericp ch)
-                                  (write-char (char-upcase ch) guard)
-                                  (setf uscore nil))
-                                 ((not uscore)
-                                  (write-char #\_ guard)
-                                  (setf uscore t)))))))))
+                   ))

 
          ;; Forward declarations of all the structures and types.  Nothing
          ;; interesting gets said here; this is just so that the user code
 
          ;; Forward declarations of all the structures and types.  Nothing
          ;; interesting gets said here; this is just so that the user code

diff --git a/parse-c-types.lisp b/parse-c-types.lisp
index d27304598756633d7ad3f641ebf97cc433ac0b6a..361396500165bbe3272448a9e34de3461fb3a12d 100644 (file)
--- a/parse-c-types.lisp
+++ b/parse-c-types.lisp
@@ -45,13 +45,49 @@ (cl:in-package #:sod)
 ;;; groups the other three kinds together and calls them all `type
 ;;; specifiers' (6.7.2).
 
 ;;; groups the other three kinds together and calls them all `type
 ;;; specifiers' (6.7.2).
 

+;; Let's not repeat ourselves.
+(macrolet ((define-declaration-specifiers (&rest defs)
+            (let ((mappings nil)
+                  (deftypes nil)
+                  (hashvar (gensym "HASH"))
+                  (keyvar (gensym "KEY"))
+                  (valvar (gensym "VAL")))
+              (dolist (def defs)
+                (destructuring-bind (kind &rest clauses) def
+                  (let ((maps (mapcar (lambda (clause)
+                                        (if (consp clause)
+                                            clause
+                                            (cons (string-downcase clause)
+                                                  clause)))
+                                      clauses)))
+                    (push `(deftype ,(symbolicate 'decl- kind) ()
+                             '(member ,@(mapcar #'cdr maps)))
+                          deftypes)
+                    (setf mappings (nconc (remove-if-not #'car maps)
+                                          mappings)))))
+              `(progn
+                 ,@(nreverse deftypes)
+                 (defparameter *declspec-map*
+                   (let ((,hashvar (make-hash-table :test #'equal)))
+                     (mapc (lambda (,keyvar ,valvar)
+                             (setf (gethash ,keyvar ,hashvar) ,valvar))
+                           ',(mapcar #'car mappings)
+                           ',(mapcar #'cdr mappings))
+                     ,hashvar))))))
+  (define-declaration-specifiers
+    (type :char :int :float :double :void)
+    (size :short :long (nil . :long-long))
+    (sign :signed :unsigned)
+    (qualifier :const :restrict :volatile)
+    (tagged :enum :struct :union)))
+

 (defstruct (declspec
             (:predicate declspecp))
   "Represents a declaration specifier being built."
   (qualifiers nil :type list)
 (defstruct (declspec
             (:predicate declspecp))
   "Represents a declaration specifier being built."
   (qualifiers nil :type list)

-  (sign nil :type (member nil :signed :unsigned))
-  (size nil :type (member nil :short :long :long-long))
-  (type nil :type (or (member nil :int :char :float :double :void) c-type)))
+  (sign nil :type (or decl-sign null))
+  (size nil :type (or decl-size null))
+  (type nil :type (or decl-type c-type null)))

 
 (defun check-declspec (spec)
   "Check that the declaration specifiers in SPEC are a valid combination.
 
 (defun check-declspec (spec)
   "Check that the declaration specifiers in SPEC are a valid combination.


@@ -204,71 +240,58 @@ (defun declspec-c-type (spec)
 
 (defun declaration-specifier-p (lexer)
   "Answer whether the current token might be a declaration specifier."
 
 (defun declaration-specifier-p (lexer)
   "Answer whether the current token might be a declaration specifier."

-  (case (token-type lexer)
-    ((:const :volatile :restrict
-      :signed :unsigned
-      :short :long
-      :void :char :int :float :double
-      :enum :struct :union)
-     t)
-    (:id
-     (gethash (token-value lexer) *type-map*))
-    (t
-     nil)))
+  (and (eq (token-type lexer) :id)
+       (let ((id (token-value lexer)))
+        (or (gethash id *declspec-map*)
+            (gethash id *type-map*)))))

 
 (defun parse-c-type (lexer)
   "Parse declaration specifiers from LEXER and return a C-TYPE."
 
   (let ((spec (make-declspec))
 
 (defun parse-c-type (lexer)
   "Parse declaration specifiers from LEXER and return a C-TYPE."
 
   (let ((spec (make-declspec))

-       (found-any nil))
-    (loop
-      (let ((tok (token-type lexer)))
-       (labels ((update (func value)
-                  (let ((new (funcall func spec value)))
-                    (cond (new (setf spec new))
-                          (t (cerror*
-          "Invalid declaration specifier ~(~A~) after `~{~A~^ ~}' (ignored)"
-                              (format-token tok (token-value lexer))
-                              (declspec-keywords spec t))
-                             nil))))
-                (tagged (class)
-                  (let ((kind tok))
-                    (setf tok (next-token lexer))
-                    (if (eql tok :id)
-                        (when (update #'update-declspec-type
-                                      (make-instance
-                                       class
-                                       :tag (token-value lexer)))
-                          (setf found-any t))
-                        (cerror* "Expected ~(~A~) tag; found ~A"
-                                 kind (format-token lexer))))))
-         (case tok
-           ((:const :volatile :restrict)
-            (update #'update-declspec-qualifiers tok))
-           ((:signed :unsigned)
-            (when (update #'update-declspec-sign tok)
-              (setf found-any t)))
-           ((:short :long)
-            (when (update #'update-declspec-size tok)
-              (setf found-any t)))
-           ((:void :char :int :float :double)
-            (when (update #'update-declspec-type tok)
-              (setf found-any t)))
-           (:enum (tagged 'c-enum-type))
-           (:struct (tagged 'c-struct-type))
-           (:union (tagged 'c-union-type))
-           (:id
-            (let ((ty (gethash (token-value lexer) *type-map*)))
-              (when (or found-any (not ty))
-                (return))
-              (when (update #'update-declspec-type ty)
-                (setf found-any t))))
-           (t
-            (return))))
-       (setf tok (next-token lexer))))
-    (unless found-any
-      (cerror* "Missing type name (guessing at `int')"))
-    (declspec-c-type spec)))
+       (found-any nil)
+       tok)
+    (flet ((token (&optional (ty (next-token lexer)))
+            (setf tok
+                  (or (and (eq ty :id)
+                           (gethash (token-value lexer) *declspec-map*))
+                      ty)))
+          (update (func value)
+            (let ((new (funcall func spec value)))
+              (cond (new (setf spec new))
+                    (t (cerror* "Invalid declaration specifier ~(~A~) ~
+                                 following `~{~A~^ ~}' (ignored)"
+                                (format-token tok (token-value lexer))
+                                (declspec-keywords spec t))
+                       nil)))))
+      (token (token-type lexer))
+      (loop
+       (typecase tok
+         (decl-qualifier (update #'update-declspec-qualifiers tok))
+         (decl-sign (when (update #'update-declspec-sign tok)
+                      (setf found-any t)))
+         (decl-size (when (update #'update-declspec-size tok)
+                      (setf found-any t)))
+         (decl-type (when (update #'update-declspec-type tok)
+                      (setf found-any t)))
+         (decl-tagged (let ((class (ecase tok
+                                     (:enum 'c-enum-type)
+                                     (:struct 'c-struct-type)
+                                     (:union 'c-union-type))))
+                        (let ((tag (require-token lexer :id)))
+                          (when tag
+                            (update #'update-declspec-type
+                                    (make-instance class :tag tag))))))
+         ((eql :id) (let ((ty (gethash (token-value lexer) *type-map*)))
+                      (when (or found-any (not ty))
+                        (return))
+                      (when (update #'update-declspec-type ty)
+                        (setf found-any t))))
+         (t (return)))
+       (token))
+      (unless found-any
+       (cerror* "Missing type name (guessing at `int')"))
+      (declspec-c-type spec))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing declarators.
 
 ;;;--------------------------------------------------------------------------
 ;;; Parsing declarators.


@@ -491,15 +514,14 @@ (defun parse-c-declarator (lexer type &key abstractp dottedp)
 (with-input-from-string (in "
 //  int stat(struct stat *st)
 //  void foo(void)
 (with-input-from-string (in "
 //  int stat(struct stat *st)
 //  void foo(void)

-//  int vsnprintf(size_t n, char *buf, va_list ap)
+  int vsnprintf(size_t n, char *buf, va_list ap)

 //  size_t size_t;
 //  int (*signal(int sig, int (*handler)(int s)))(int t)
 ")
   (let* ((stream (make-instance 'position-aware-input-stream
                                :file "<string>"
                                :stream in))
 //  size_t size_t;
 //  int (*signal(int sig, int (*handler)(int s)))(int t)
 ")
   (let* ((stream (make-instance 'position-aware-input-stream
                                :file "<string>"
                                :stream in))

-        (lex (make-instance 'sod-lexer :stream stream
-                            :keywords *sod-keywords*)))
+        (lex (make-instance 'sod-lexer :stream stream)))

     (next-char lex)
     (next-token lex)
     (let ((ty (parse-c-type lex)))
     (next-char lex)
     (next-token lex)
     (let ((ty (parse-c-type lex)))

diff --git a/sod.c b/sod.c
index ad209747af8c8752d07b12e2a34294f2fcc825ca..24a64298dcdf3e4f659480f496910bb00b3470de 100644 (file)
--- a/sod.c
+++ b/sod.c
@@ -26,7 +26,7 @@
 
 /*----- Header files ------------------------------------------------------*/
 
 
 /*----- Header files ------------------------------------------------------*/
 

-#include <sod.h>
+#include "sod.h"

 
 /*----- Main code ---------------------------------------------------------*/
 
 
 /*----- Main code ---------------------------------------------------------*/
 


@@ -60,7 +60,7 @@ static const struct sod_chain *find_chain(const SodClass *sub,
    * and we're done.  Otherwise it isn't, and we lose.  We also lose if no
    * matching chain is found.
    */
    * and we're done.  Otherwise it isn't, and we lose.  We also lose if no
    * matching chain is found.
    */

-  for (chain = sub->cls.chains, lim = chain + sub->cls.n_chains;
+  for (chain = sub->cls.chains, limit = chain + sub->cls.n_chains;

        chain < limit; chain++) {
     if (chain->classes[0] != head)
       continue;
        chain < limit; chain++) {
     if (chain->classes[0] != head)
       continue;

diff --git a/sod.h b/sod.h
index 9fa972d51624dff9114b68e5a99752cb1779b41b..cb562444a3f79c964bcb1576c46e0967221aeada 100644 (file)
--- a/sod.h
+++ b/sod.h
@@ -36,7 +36,7 @@
 #include <stdarg.h>
 #include <stddef.h>
 
 #include <stdarg.h>
 #include <stddef.h>
 

-#include <sod-base.h>
+#include "sod-base.h"

 
 /*----- Data structures ---------------------------------------------------*/
 
 
 /*----- Data structures ---------------------------------------------------*/