It lives!

The module parser is more-or-less done.  Output is more-or-less done.
Outstanding.  Now to remove the bugs...

diff --git a/builtin.lisp b/builtin.lisp
index 67c04c1d87d6670f64dd321524cc09aff0833c01..9309581f30b51b2f3afcab7a6f89dd21eb2fd87b 100644 (file)
--- a/builtin.lisp
+++ b/builtin.lisp
@@ -65,8 +65,7 @@ (defun output-init-function (class stream)
        (dolist (item (ichain-body ichain))
          (etypecase item
            (vtable-pointer
        (dolist (item (ichain-body ichain))
          (etypecase item
            (vtable-pointer

-            (format stream "  ~A._vt = &~A;~%"
-                    ich (vtable-name class (ichain-head ichain))))
+            nil)

            (islots
             (let ((isl (format nil "~A.~A"
                                ich
            (islots
             (let ((isl (format nil "~A.~A"
                                ich


@@ -75,14 +74,18 @@ (defun output-init-function (class stream)
                 (let ((dslot (effective-slot-direct-slot slot))
                       (init (effective-slot-initializer slot)))
                   (when init
                 (let ((dslot (effective-slot-direct-slot slot))
                       (init (effective-slot-initializer slot)))
                   (when init

+                    (format stream "  ~A =" isl)

                     (ecase (sod-initializer-value-kind init)
                     (ecase (sod-initializer-value-kind init)

-                      (:single
-                       (format stream "  ~A = ~A;~%"
-                               isl (sod-initializer-value-form init)))
-                      (:compound
-                       (format stream "  ~A = (~A)~A;~%"
-                               isl (sod-slot-type dslot)
-                               (sod-initializer-value-form init)))))))))))))
+                      (:simple (write (sod-initializer-value-form init)
+                                      :stream stream
+                                      :pretty nil :escape nil)
+                               (format stream ";~%"))
+                      (:compound (format stream " (~A) {"
+                                         (sod-slot-type dslot))
+                                 (write (sod-initializer-value-form init)
+                                        :stream stream
+                                        :pretty nil :escape nil)
+                                 (format stream "};~%"))))))))))))

     (format stream "~&~:
   return (p);
 }~2%")))
     (format stream "~&~:
   return (p);
 }~2%")))

diff --git a/chimaera.sod b/chimaera.sod
new file mode 100644 (file)
index 0000000..d5507f8
--- /dev/null
+++ b/chimaera.sod
@@ -0,0 +1,51 @@
+/* -*-sod-*-
+ *
+ * A simple SOD module for testing.
+ */
+
+code c : includes {
+#include <stdio.h>
+#include "chimaera.h"
+}
+
+code h : includes {
+#include "sod.h"
+}
+
+lisp (write-line "Hello, world!") ;
+
+[nick = nml, link = SodObject]
+class Animal : SodObject {
+  int tickles = 0;
+
+  void tickle(void) { }
+
+  [role = before]
+  void nml.tickle(void) { me->nml.tickles++; }
+}
+
+class Lion : Animal {
+  void bite(void) { puts("Munch!"); }
+  void nml.tickle(void) { me->_vt.bite(me); }
+}
+
+class Goat : Animal {
+  void butt(void) { puts("Bonk!"); }
+  void nml.tickle(void) { me->_vt.butt(me); }
+}
+
+class Serpent : Animal {
+  void hiss(void) { puts("Sssss!"); }
+  void bite(void) { puts("Nom!"); }
+  void nml.tickle(void) {
+    if (SERPENT__CONV_NML(me)->nml.tickles > 2)
+      me->_vt.bite();
+    else
+      me->_vt.hiss();
+  }
+}
+
+[nick = sir, link = Animal]
+class Chimaera : Lion, Goat, Serpent {
+}
+

diff --git a/class-builder.lisp b/class-builder.lisp
index 7acbeaeed22351a3caa6fe9b69b55f56f141112d..59dd4eec8c757ec3e14e18aa947adb38f98a3fad 100644 (file)
--- a/class-builder.lisp
+++ b/class-builder.lisp
@@ -129,7 +129,7 @@ (defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
 
   ;; If no nickname, copy the class name.  It won't be pretty, though.
   (default-slot (class 'nickname)
 
   ;; 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)))
+    (get-property pset :nick :id (string-downcase (slot-value class 'name))))

 
   ;; If no metaclass, guess one in a (Lisp) class-specific way.
   (default-slot (class 'metaclass)
 
   ;; If no metaclass, guess one in a (Lisp) class-specific way.
   (default-slot (class 'metaclass)

diff --git a/class-layout.lisp b/class-layout.lisp
index a37852ed365a955a9bef5ee4fddbdce62264adc3..877073992c31175a344f14b1ebc782f64d846063 100644 (file)
--- a/class-layout.lisp
+++ b/class-layout.lisp
@@ -232,12 +232,11 @@ (defgeneric compute-sod-effective-method (message class)
 
 (defmethod compute-sod-effective-method
     ((message sod-message) (class sod-class))
 
 (defmethod compute-sod-effective-method
     ((message sod-message) (class sod-class))

-  (let ((direct-methods (mapcan (lambda (super)
-                                 (let ((method
-                                        (find message
-                                              (sod-class-methods super)
-                                              :key #'sod-method-message)))
-                                   (and method (list method))))
+  (let ((direct-methods (mappend (lambda (super)
+                                  (remove message
+                                          (sod-class-methods super)
+                                          :key #'sod-method-message
+                                          :test-not #'eql))

                                (sod-class-precedence-list class))))
     (make-instance (message-effective-method-class message)
                   :message message
                                (sod-class-precedence-list class))))
     (make-instance (message-effective-method-class message)
                   :message message


@@ -549,10 +548,14 @@ (defun find-root-superclass (class)
   ;; is harmless.
   (let* ((supers (sod-class-direct-superclasses class))
         (roots (if supers
   ;; 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))
+                   (remove-duplicates
+                    (remove-if #'sod-class-direct-superclasses
+                               (mappend (lambda (super)
+                                          (mapcar (lambda (chain)
+                                                    (sod-class-chain-head
+                                                     (car chain)))
+                                                  (sod-class-chains super)))
+                                        supers)))

                    (list class))))
     (cond ((null roots) (error "Class ~A has no root class!" class))
          ((cdr roots) (error "Class ~A has multiple root classes ~
                    (list class))))
     (cond ((null roots) (error "Class ~A has no root class!" class))
          ((cdr roots) (error "Class ~A has multiple root classes ~

diff --git a/class-output.lisp b/class-output.lisp
index ee2daf3f9ddab23b933e8270f160615e9f43b011..da6531b12e4f7dde38b052ea9ae14a829b0d1a6c 100644 (file)
--- a/class-output.lisp
+++ b/class-output.lisp
@@ -93,8 +93,8 @@ (defmethod add-output-hooks progn
     ((class :object)
      (let ((metaclass (sod-class-metaclass class))
           (metaroot (find-root-metaclass class)))
     ((class :object)
      (let ((metaclass (sod-class-metaclass class))
           (metaroot (find-root-metaclass class)))

-       (format stream "/* The class object. */~%~
-                      extern const struct ~A ~A__classobj;~%~
+       (format stream "/* The class object. */~@
+                      extern const 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))
                       #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
               (ilayout-struct-tag metaclass) class
               (sod-class-nickname (sod-class-chain-head metaroot))


@@ -106,7 +106,7 @@ (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 "/* Instance slots. */~%~
+       (format stream "/* Instance slots. */~@

                       struct ~A {~%"
               (islots-struct-tag class)))
       ((class :islots :end)
                       struct ~A {~%"
               (islots-struct-tag class)))
       ((class :islots :end)


@@ -141,9 +141,11 @@ (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 methods) class
+  (with-slots (ilayout vtables methods effective-methods) class

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

+    (dolist (method effective-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))))
 
 ;;;--------------------------------------------------------------------------


@@ -166,7 +168,7 @@ (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 "/* Instance layout. */~%~
+       (format stream "/* Instance layout. */~@

                       struct ~A {~%"
               (ilayout-struct-tag class)))
       ((class :ilayout :end)
                       struct ~A {~%"
               (ilayout-struct-tag class)))
       ((class :ilayout :end)


@@ -185,13 +187,13 @@ (defmethod add-output-hooks progn
                     (class :ichain chain-head :end)
                     (class :ichains :end))
        ((class :ichain chain-head :start)
                     (class :ichain chain-head :end)
                     (class :ichains :end))
        ((class :ichain chain-head :start)

-        (format stream "/* Instance chain structure. */~%~
+        (format stream "/* Instance chain structure. */~@

                         struct ~A {~%"
                 (ichain-struct-tag chain-tail chain-head)))
        ((class :ichain chain-head :end)
         (format stream "};~2%")
                         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 {~%~
+        (format stream "/* Union of equivalent superclass chains. */~@
+                        union ~A {~@

                         ~:{  struct ~A ~A;~%~}~
                         };~2%"
                 (ichain-union-tag chain-tail chain-head)
                         ~:{  struct ~A ~A;~%~}~
                         };~2%"
                 (ichain-union-tag chain-tail chain-head)


@@ -259,7 +261,7 @@ (defmethod add-output-hooks progn
                     (class :vtable chain-head :end)
                     (class :vtables :end))
        ((class :vtable chain-head :start)
                     (class :vtable chain-head :end)
                     (class :vtables :end))
        ((class :vtable chain-head :start)

-        (format stream "/* Vtable structure. */~%~
+        (format stream "/* Vtable structure. */~@

                         struct ~A {~%"
                 (vtable-struct-tag chain-tail chain-head)))
        ((class :vtable chain-head :end)
                         struct ~A {~%"
                 (vtable-struct-tag chain-tail chain-head)))
        ((class :vtable chain-head :end)


@@ -290,7 +292,7 @@ (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 "/* Messages protocol from class ~A */~%~
+        (format stream "/* Messages protocol from class ~A */~@

                         struct ~A {~%"
                 class
                 (vtmsgs-struct-tag subclass class)))
                         struct ~A {~%"
                 class
                 (vtmsgs-struct-tag subclass class)))


@@ -357,7 +359,7 @@ (defmethod add-output-hooks progn
     ((:classes :start)
      (class :banner)
      (class :direct-methods :start) (class :direct-methods :end)
     ((:classes :start)
      (class :banner)
      (class :direct-methods :start) (class :direct-methods :end)

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

      (class :vtables :start) (class :vtables :end)
      (class :object :prepare) (class :object :start) (class :object :end)
      (:classes :end))
      (class :vtables :start) (class :vtables :end)
      (class :object :prepare) (class :object :start) (class :object :end)
      (:classes :end))


@@ -382,9 +384,6 @@ (defmethod add-output-hooks progn
 ;;;--------------------------------------------------------------------------
 ;;; Direct methods.
 
 ;;;--------------------------------------------------------------------------
 ;;; Direct methods.
 

-;; This could well want splitting out into some more elaborate protocol.  We
-;; need a bunch of refactoring anyway.
-

 (defmethod add-output-hooks progn
     ((method delegating-direct-method) (reason (eql :c)) sequencer)
   (with-slots (class body) method
 (defmethod add-output-hooks progn
     ((method delegating-direct-method) (reason (eql :c)) sequencer)
   (with-slots (class body) method


@@ -420,6 +419,90 @@ (defmethod add-output-hooks progn
       ((class :direct-method method :end)
        (terpri stream)))))
 
       ((class :direct-method method :end)
        (terpri stream)))))
 

+;;;--------------------------------------------------------------------------
+;;; Vtables.
+
+(defmethod add-output-hooks progn
+    ((vtable vtable) (reason (eql :c)) sequencer)
+  (with-slots (class chain-head chain-tail) vtable
+    (sequence-output (stream sequencer)
+      :constraint ((class :vtables :start)
+                  (class :vtable chain-head :start)
+                  (class :vtable chain-head :end)
+                  (class :vtables :end))
+      ((class :vtable chain-head :start)
+       (format stream "/* Vtable for ~A chain. */~@
+                      static const struct ~A ~A = {~%"
+              chain-head
+              (vtable-struct-tag chain-tail chain-head)
+              (vtable-name chain-tail chain-head)))
+      ((class :vtable chain-head :end)
+       (format stream "};~2%")))))
+
+(defmethod add-output-hooks progn
+    ((cptr class-pointer) (reason (eql :c)) sequencer)
+  (with-slots (class chain-head metaclass meta-chain-head) cptr
+    (sequence-output (stream sequencer)
+      :constraint ((class :vtable chain-head :start)
+                  (class :vtable chain-head :class-pointer metaclass)
+                  (class :vtable chain-head :end))
+      ((class :vtable chain-head :class-pointer metaclass)
+       (format stream "  &~A__classobj.~A.~A,~%"
+              (sod-class-metaclass class)
+              (sod-class-nickname meta-chain-head)
+              (sod-class-nickname metaclass))))))
+
+(defmethod add-output-hooks progn
+    ((boff base-offset) (reason (eql :c)) sequencer)
+  (with-slots (class chain-head) boff
+    (sequence-output (stream sequencer)
+      :constraint ((class :vtable chain-head :start)
+                  (class :vtable chain-head :base-offset)
+                  (class :vtable chain-head :end))
+      ((class :vtable chain-head :base-offset)
+       (format stream "  offsetof(struct ~A, ~A),~%"
+              (ilayout-struct-tag class)
+              (sod-class-nickname chain-head))))))
+
+(defmethod add-output-hooks progn
+    ((choff chain-offset) (reason (eql :c)) sequencer)
+  (with-slots (class chain-head target-head) choff
+    (sequence-output (stream sequencer)
+      :constraint ((class :vtable chain-head :start)
+                  (class :vtable chain-head :chain-offset target-head)
+                  (class :vtable chain-head :end))
+      ((class :vtable chain-head :chain-offset target-head)
+       (format stream "  SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
+              (ilayout-struct-tag class)
+              (sod-class-nickname chain-head)
+              (sod-class-nickname target-head))))))
+
+(defmethod add-output-hooks progn
+    ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
+  (with-slots (class subclass chain-head) vtmsgs
+    (sequence-output (stream sequencer)
+      :constraint ((subclass :vtable chain-head :start)
+                  (subclass :vtable chain-head :vtmsgs class :start)
+                  (subclass :vtable chain-head :vtmsgs class :slots)
+                  (subclass :vtable chain-head :vtmsgs class :end)
+                  (subclass :vtable chain-head :end))
+      ((subclass :vtable chain-head :vtmsgs class :start)
+       (format stream "  { /* Method entries for ~A messages. */~%"
+              class))
+      ((subclass :vtable chain-head :vtmsgs class :end)
+       (format stream "  },~%")))))
+
+(defmethod add-output-hooks progn
+    ((entry method-entry) (reason (eql :c)) sequencer)
+  (with-slots (method chain-head chain-tail) entry
+    (let* ((message (effective-method-message method))
+          (class (effective-method-class method))
+          (super (sod-message-class message)))
+      (sequence-output (stream sequencer)
+       ((class :vtable chain-head :vtmsgs super :slots)
+        (format stream "    ~A,~%"
+                (method-entry-function-name method chain-head)))))))
+

 ;;;--------------------------------------------------------------------------
 ;;; Filling in the class object.
 
 ;;;--------------------------------------------------------------------------
 ;;; Filling in the class object.
 

diff --git a/codegen.lisp b/codegen.lisp
index e9415690d4672fcba1e3ef668ff2a5bba21b9b9a..fc6a4088e37147de18c38374dc500d6a6ab32de4 100644 (file)
--- a/codegen.lisp
+++ b/codegen.lisp
@@ -248,6 +248,7 @@ (definst call (stream) (func args)
 
 (definst function (stream) (name type body)
   (pprint-logical-block (stream nil)
 
 (definst function (stream) (name type body)
   (pprint-logical-block (stream nil)

+    (princ "static " stream)

     (pprint-c-type type stream name)
     (format stream "~:@_~A~:@_~:@_" body)))
 
     (pprint-c-type type stream name)
     (format stream "~:@_~A~:@_~:@_" body)))
 

diff --git a/examples.lisp b/examples.lisp
index f91f5521ce60d7ed28667d534c240b535c083aee..82702a6c2946162907fefbb6d4cf2acc75c07d7e 100644 (file)
--- a/examples.lisp
+++ b/examples.lisp
@@ -3,6 +3,14 @@ (set-dispatch-macro-character #\# #\{ 'c-fragment-reader)
 (defparameter *chimaera-module*
   (define-module ("chimaera.sod")
 
 (defparameter *chimaera-module*
   (define-module ("chimaera.sod")
 

+    (define-fragment (:c :includes) #{
+       #include "chimaera.h"
+     })
+
+    (define-fragment (:h :includes) #{
+       #include "sod.h"
+     })
+

     (define-sod-class "Animal" ("SodObject")
       :nick 'nml
       :link '|SodObject|
     (define-sod-class "Animal" ("SodObject")
       :nick 'nml
       :link '|SodObject|

diff --git a/methods.lisp b/methods.lisp
index 67033daf159ce65baee02c85f6809fb121f447f8..b54887a311b9faf222e0f7fca66f0d2a72634958 100644 (file)
--- a/methods.lisp
+++ b/methods.lisp
@@ -382,9 +382,10 @@ (defun invoke-method (codegen target arguments-tail direct-method)
   (let* ((message (sod-method-message direct-method))
         (class (sod-method-class direct-method))
         (function (sod-method-function-name direct-method))
   (let* ((message (sod-method-message direct-method))
         (class (sod-method-class direct-method))
         (function (sod-method-function-name direct-method))

-        (arguments (cons (format nil "(~A *)&sod__obj.~A" class
+        (arguments (cons (format nil "&sod__obj.~A.~A"

                                  (sod-class-nickname
                                  (sod-class-nickname

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

                          arguments-tail)))
     (if (varargs-message-p message)
        (convert-stmts codegen target
                          arguments-tail)))
     (if (varargs-message-p message)
        (convert-stmts codegen target


@@ -533,7 +534,7 @@ (defgeneric compute-method-entry-functions (method)
    method entries.  Returns a list of functions (i.e., FUNCTION-INST objects)
    which need to be defined in the generated source code."))
 
    method entries.  Returns a list of functions (i.e., FUNCTION-INST objects)
    which need to be defined in the generated source code."))
 

-(defparameter *method-entry-inline-threshold* 20
+(defparameter *method-entry-inline-threshold* 200

   "Threshold below which effective method bodies are inlined into entries.
 
    After the effective method body has been computed, we calculate its
   "Threshold below which effective method bodies are inlined into entries.
 
    After the effective method body has been computed, we calculate its


@@ -568,7 +569,7 @@ (defmethod method-entry-function-name
   (let* ((class (effective-method-class method))
         (message (effective-method-message method))
         (message-class (sod-message-class message)))
   (let* ((class (effective-method-class method))
         (message (effective-method-message method))
         (message-class (sod-message-class message)))

-    (format nil "~A__mentry_~A__~A__~A"
+    (format nil "~A__mentry_~A__~A__chain_~A"

            class
            (sod-class-nickname message-class)
            (sod-message-name message)
            class
            (sod-class-nickname message-class)
            (sod-message-name message)


@@ -724,4 +725,15 @@ (defmethod make-method-entry ((method basic-effective-method)
                 :chain-head chain-head
                 :chain-tail chain-tail))
 
                 :chain-head chain-head
                 :chain-tail chain-tail))
 

+;;;--------------------------------------------------------------------------
+;;; Output.
+
+(defmethod add-output-hooks progn
+    ((method basic-effective-method) (reason (eql :c)) sequencer)
+  (with-slots (class functions) method
+    (sequence-output (stream sequencer)
+      ((class :effective-methods)
+       (dolist (func functions)
+        (write func :stream stream :escape nil :circle nil))))))
+

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

diff --git a/module-output.lisp b/module-output.lisp
index dedbe97c02599e4274f4f207385beb23327771d0..891ff54fc379d9fbab7d1f422963bce3637e077b 100644 (file)
--- a/module-output.lisp
+++ b/module-output.lisp
@@ -60,7 +60,13 @@ (defun guess-output-file (module type)
                   (module-name module)))
 
 (defun output-module (module reason stream)
                   (module-name module)))
 
 (defun output-module (module reason stream)

-  (let ((sequencer (make-instance 'sequencer)))
+  (let ((sequencer (make-instance 'sequencer))
+       (stream (if (typep stream 'position-aware-output-stream)
+                   stream
+                   (make-instance 'position-aware-output-stream
+                                  :stream stream
+                                  :file (or (stream-pathname stream)
+                                            #p"<unnamed>")))))

     (add-output-hooks module reason sequencer)
     (invoke-sequencer-items sequencer stream)))
 
     (add-output-hooks module reason sequencer)
     (invoke-sequencer-items sequencer stream)))
 


@@ -71,6 +77,18 @@ (defmethod add-output-hooks progn ((module module) reason sequencer)
   (dolist (item (module-items module))
     (add-output-hooks item reason sequencer)))
 
   (dolist (item (module-items module))
     (add-output-hooks item reason sequencer)))
 

+(defmethod add-output-hooks progn
+    ((frag code-fragment-item) reason sequencer)
+  (when (eq reason (code-fragment-reason frag))
+    (dolist (constraint (code-fragment-constraints frag))
+      (add-sequencer-constraint sequencer constraint))
+    (add-sequencer-item-function sequencer (code-fragment-name frag)
+                                (lambda (stream)
+                                  (write (code-fragment frag)
+                                         :stream stream
+                                         :pretty nil
+                                         :escape nil)))))
+

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


@@ -81,7 +99,7 @@ (defmethod add-output-hooks progn
                 (:guard :start)
                 (:typedefs :start) :typedefs (:typedefs :end)
                 (:includes :start) :includes (:includes :end)
                 (:guard :start)
                 (:typedefs :start) :typedefs (:typedefs :end)
                 (:includes :start) :includes (:includes :end)

-                (:classes :start) (:classes :end)
+                (:classes :start) :classes (:classes :end)

                 (:guard :end)
                 :epilogue)
 
                 (:guard :end)
                 :epilogue)
 

diff --git a/module.lisp b/module.lisp
index 5d05365f2ccdbabb194646edc7854ddf0e4dbe8e..6f8aeecc48548f5088c0f326cd6ac63e545c81cf 100644 (file)
--- a/module.lisp
+++ b/module.lisp
@@ -166,9 +166,10 @@ (defun read-module (pathname &key (truename (truename pathname)) location)
    PROBE-FILE or similar, which drops the truename into your lap."
 
   ;; Deal with a module which is already in the map.  If its state is a
    PROBE-FILE or similar, which drops the truename into your lap."
 
   ;; Deal with a module which is already in the map.  If its state is a

-  ;; file-location then it's in progress and we have a cyclic dependency.
+  ;; FILE-LOCATION then it's in progress and we have a cyclic dependency.

   (let ((module (gethash truename *module-map*)))
   (let ((module (gethash truename *module-map*)))

-    (cond ((typep (module-state module) 'file-location)
+    (cond ((null module))
+         ((typep (module-state module) 'file-location)

           (error "Module ~A already being imported at ~A"
                  pathname (module-state module)))
          (module
           (error "Module ~A already being imported at ~A"
                  pathname (module-state module)))
          (module


@@ -186,46 +187,50 @@   (define-module (pathname :location location :truename truename)
          (with-default-error-location (lexer)
            (next-char lexer)
            (next-token lexer)
          (with-default-error-location (lexer)
            (next-char lexer)
            (next-token lexer)

-           (parse-module lexer *module*)))))))
+           (parse-module lexer)))))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Module parsing protocol.
 
 (defgeneric parse-module-declaration (tag lexer pset)
   (:method (tag lexer pset)
 
 ;;;--------------------------------------------------------------------------
 ;;; Module parsing protocol.
 
 (defgeneric parse-module-declaration (tag lexer pset)
   (:method (tag lexer pset)

-    (error "Unexpected module declaration ~(~A~)" tag)))
+    (error "Unexpected module declaration ~(~A~)" tag))
+  (:method :before (tag lexer pset)
+    (next-token lexer)))

 
 (defun parse-module (lexer)
   "Main dispatching for module parser.
 
    Calls PARSE-MODULE-DECLARATION for the identifiable declarations."
 
 
 (defun parse-module (lexer)
   "Main dispatching for module parser.
 
    Calls PARSE-MODULE-DECLARATION for the identifiable declarations."
 

-  ;; A little fancy footwork is required because `class' is a reserved word.

   (loop
   (loop

-    (flet ((dispatch (tag pset)
-            (next-token lexer)
-            (parse-module-declaration tag lexer pset)
-            (check-unused-properties pset)))
-      (restart-case
-         (case (token-type lexer)
-           (:eof (return))
-           (#\; (next-token lexer))
-           (t (let ((pset (parse-property-set lexer)))
-                (case (token-type lexer)
-                  (:id (dispatch (string-to-symbol (token-value lexer)
-                                                   :keyword)
-                                 pset))
-                  (t (error "Unexpected token ~A: ignoring"
-                            (format-token lexer)))))))
-       (continue ()
-         :report "Ignore the error and continue parsing."
-         nil)))))
+    (restart-case
+       (case (token-type lexer)
+         (:eof (return))
+         (#\; (next-token lexer))
+         (t (let ((pset (parse-property-set lexer)))
+              (case (token-type lexer)
+                (:id (let ((tag (intern (frob-case (token-value lexer))
+                                        :keyword)))
+                       (parse-module-declaration tag lexer pset)
+                       (check-unused-properties pset)))
+                (t (error "Unexpected token ~A: ignoring"
+                          (format-token lexer)))))))
+      (continue ()
+       :report "Ignore the error and continue parsing."
+       nil))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Type definitions.
 
 (defclass type-item ()
 
 ;;;--------------------------------------------------------------------------
 ;;; Type definitions.
 
 (defclass type-item ()

-  ((name :initarg :name :type string :reader type-name)))
+  ((name :initarg :name :type string :reader type-name))
+  (:documentation
+   "A note that a module exports a type.
+
+   We can only export simple types, so we only need to remember the name.
+   The magic simple-type cache will ensure that we get the same type object
+   when we do the import."))

 
 (defmethod module-import ((item type-item))
   (let* ((name (type-name item))
 
 (defmethod module-import ((item type-item))
   (let* ((name (type-name item))


@@ -239,6 +244,82 @@     (def (gethash name *type-map*))
 (defmethod module-import ((class sod-class))
   (record-sod-class class))
 
 (defmethod module-import ((class sod-class))
   (record-sod-class class))
 

+(defmethod parse-module-declaration ((tag (eql :typename)) lexer pset)
+  "module-decl ::= `typename' id-list `;'"
+  (loop (let ((name (require-token lexer :id)))
+         (unless name (return))
+         (if (gethash name *type-map*)
+             (cerror* "Type `~A' already defined" name)
+             (add-to-module *module* (make-instance 'type-item :name name)))
+         (unless (require-token lexer #\, :errorp nil) (return))))
+  (require-token lexer #\;))
+
+;;;--------------------------------------------------------------------------
+;;; Fragments.
+
+(defclass code-fragment-item ()
+  ((fragment :initarg :fragment :type c-fragment :reader code-fragment)
+   (reason :initarg :reason :type keyword :reader code-fragment-reason)
+   (name :initarg :name :type t :reader code-fragment-name)
+   (constraints :initarg :constraints :type list
+               :reader code-fragment-constraints))
+  (:documentation
+   "A plain fragment of C to be dropped in at top-level."))
+
+(defmacro define-fragment ((reason name) &body things)
+  (categorize (thing things)
+      ((constraints (listp thing))
+       (frags (typep thing '(or string c-fragment))))
+    (when (null frags)
+      (error "Missing code fragment"))
+    (when (cdr frags)
+      (error "Multiple code fragments"))
+    `(add-to-module
+      *module*
+      (make-instance 'code-fragment-item
+                    :fragment ',(car frags)
+                    :name ,name
+                    :reason ,reason
+                    :constraints (list ,@(mapcar (lambda (constraint)
+                                                   (cons 'list constraint))
+                                                 constraints))))))
+
+(defmethod parse-module-declaration ((tag (eql :code)) lexer pset)
+  "module-decl ::= `code' id `:' id [constraint-list] `{' c-fragment `}'
+   constraint ::= id*"
+  (labels ((parse-constraint ()
+            (let ((list nil))
+              (loop (let ((id (require-token lexer :id
+                                             :errorp (null list))))
+                      (unless id (return))
+                      (push id list)))
+              (nreverse list)))
+          (parse-constraints ()
+            (let ((list nil))
+              (when (require-token lexer #\[ :errorp nil)
+                (loop (let ((constraint (parse-constraint)))
+                        (push constraint list)
+                        (unless (require-token lexer #\, :errorp nil)
+                          (return))))
+                (require-token lexer #\]))
+              (nreverse list)))
+          (keywordify (id)
+            (and id (intern (substitute #\- #\_ (frob-case id)) :keyword))))
+    (let* ((reason (prog1 (keywordify (require-token lexer :id))
+                  (require-token lexer #\:)))
+          (name (keywordify (require-token lexer :id)))
+          (constraints (parse-constraints)))
+      (when (require-token lexer #\{ :consumep nil)
+       (let ((frag (scan-c-fragment lexer '(#\}))))
+         (next-token lexer)
+         (require-token lexer #\})
+         (add-to-module *module*
+                        (make-instance 'code-fragment-item
+                                       :name name
+                                       :reason reason
+                                       :constraints constraints
+                                       :fragment frag)))))))
+

 ;;;--------------------------------------------------------------------------
 ;;; File searching.
 
 ;;;--------------------------------------------------------------------------
 ;;; File searching.
 


@@ -281,11 +362,12 @@ (defun find-file (lexer name what thunk)
       (error "Error searching for ~A ~S: ~A" what (namestring name) error))
     (:no-error (path probe)
       (cond ((null path)
       (error "Error searching for ~A ~S: ~A" what (namestring name) error))
     (:no-error (path probe)
       (cond ((null path)

-            (error "Failed to find ~A ~S" what name))
+            (error "Failed to find ~A ~S" what (namestring name)))

            (t
             (funcall thunk path probe))))))
 
 (defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
            (t
             (funcall thunk path probe))))))
 
 (defmethod parse-module-declaration ((tag (eql :import)) lexer pset)

+  "module-decl ::= `import' string `;'"

   (let ((name (require-token lexer :string)))
     (when name
       (find-file lexer
   (let ((name (require-token lexer :string)))
     (when name
       (find-file lexer


@@ -304,6 +386,7 @@ (defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
       (require-token lexer #\;))))
 
 (defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
       (require-token lexer #\;))))
 
 (defmethod parse-module-declaration ((tag (eql :load)) lexer pset)

+  "module-decl ::= `load' string `;'"

   (let ((name (require-token lexer :string)))
     (when name
       (find-file lexer
   (let ((name (require-token lexer :string)))
     (when name
       (find-file lexer


@@ -317,6 +400,163 @@ (defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
                                path error)))))
       (require-token lexer #\;))))
 
                                path error)))))
       (require-token lexer #\;))))
 

+;;;--------------------------------------------------------------------------
+;;; Lisp escapes.
+
+(defmethod parse-module-declaration :around ((tag (eql :lisp)) lexer pset)
+  "module-decl ::= `lisp' s-expression `;'"
+  (let ((form (with-lexer-stream (stream lexer) (read stream t))))
+    (eval form))
+  (next-token lexer)
+  (require-token lexer #\;))
+
+;;;--------------------------------------------------------------------------
+;;; Class declarations.
+
+(defmethod parse-module-declaration ((tag (eql :class)) lexer pset)
+  "module-decl ::= `class' id [`:' id-list] `{' class-item* `}'"
+  (let* ((location (file-location lexer))
+        (name (let ((name (require-token lexer :id)))
+                (make-class-type name location)
+                (when (require-token lexer #\; :errorp nil)
+                  (return-from parse-module-declaration))
+                name))
+        (supers (when (require-token lexer #\: :errorp nil)
+                  (let ((list nil))
+                    (loop (let ((id (require-token lexer :id)))
+                            (unless id (return))
+                            (push id list)
+                            (unless (require-token lexer #\, :errorp nil)
+                              (return))))
+                    (nreverse list))))
+        (class (make-sod-class name (mapcar #'find-sod-class supers)
+                               pset location))
+        (nick (sod-class-nickname class)))
+    (require-token lexer #\{)
+
+    (labels ((parse-item ()
+              "Try to work out what kind of item this is.  Messy."
+              (let* ((pset (parse-property-set lexer))
+                     (location (file-location lexer)))
+                (cond ((declaration-specifier-p lexer)
+                       (let ((declspec (parse-c-type lexer)))
+                         (multiple-value-bind (type name)
+                             (parse-c-declarator lexer declspec :dottedp t)
+                           (cond ((null type)
+                                  nil)
+                                 ((consp name)
+                                  (parse-method type (car name) (cdr name)
+                                                pset location))
+                                 ((typep type 'c-function-type)
+                                  (parse-message type name pset location))
+                                 (t
+                                  (parse-slots declspec type name
+                                               pset location))))))
+                      ((not (eq (token-type lexer) :id))
+                       (cerror* "Expected <class-item>; found ~A (skipped)"
+                                (format-token lexer))
+                       (next-token lexer))
+                      ((string= (token-value lexer) "class")
+                       (next-token lexer)
+                       (parse-initializers #'make-sod-class-initializer
+                                           pset location))
+                      (t
+                       (parse-initializers #'make-sod-instance-initializer
+                                           pset location)))))
+
+            (parse-method (type nick name pset location)
+              "class-item ::= declspec+ dotted-declarator -!- method-body
+
+               method-body ::= `{' c-fragment `}' | `extern' `;'
+
+               The dotted-declarator must describe a function type."
+              (let ((body (cond ((eq (token-type lexer) #\{)
+                                 (prog1 (scan-c-fragment lexer '(#\}))
+                                   (next-token lexer)
+                                   (require-token lexer #\})))
+                                ((and (eq (token-type lexer) :id)
+                                      (string= (token-value lexer)
+                                               "extern"))
+                                 (next-token lexer)
+                                 (require-token lexer #\;)
+                                 nil)
+                                (t
+                                 (cerror* "Expected <method-body>; ~
+                                           found ~A"
+                                          (format-token lexer))))))
+                (make-sod-method class nick name type body pset location)))
+
+            (parse-message (type name pset location)
+              "class-item ::= declspec+ declarator -!- (method-body | `;')
+
+               The declarator must describe a function type."
+              (make-sod-message class name type pset location)
+              (unless (require-token lexer #\; :errorp nil)
+                (parse-method type nick name nil location)))
+
+            (parse-initializer-body ()
+              "initializer ::= `=' `{' c-fragment `}' | `=' c-fragment"
+              (let ((char (lexer-char lexer)))
+                (loop
+                  (when (or (null char) (not (whitespace-char-p char)))
+                    (return))
+                  (setf char (next-char lexer)))
+                (cond ((eql char #\{)
+                       (next-char lexer)
+                       (let ((frag (scan-c-fragment lexer '(#\}))))
+                         (next-token lexer)
+                         (require-token lexer #\})
+                         (values :compound frag)))
+                      (t
+                       (let ((frag (scan-c-fragment lexer '(#\, #\;))))
+                         (next-token lexer)
+                         (values :simple frag))))))
+
+            (parse-slots (declspec type name pset location)
+              "class-item ::=
+                 declspec+ init-declarator [`,' init-declarator-list] `;'
+
+               init-declarator ::= declarator -!- [initializer]"
+              (loop
+                (make-sod-slot class name type pset location)
+                (when (eql (token-type lexer) #\=)
+                  (multiple-value-bind (kind form) (parse-initializer-body)
+                    (make-sod-instance-initializer class nick name
+                                                   kind form nil
+                                                   location)))
+                (unless (require-token lexer #\, :errorp nil)
+                  (return))
+                (setf (values type name)
+                      (parse-c-declarator lexer declspec)
+                      location (file-location lexer)))
+              (require-token lexer #\;))
+
+            (parse-initializers (constructor pset location)
+              "class-item ::= [`class'] -!- slot-initializer-list `;'
+
+               slot-initializer ::= id `.' id initializer"
+              (loop
+                (let ((nick (prog1 (require-token lexer :id)
+                              (require-token lexer #\.)))
+                      (name (require-token lexer :id)))
+                  (require-token lexer #\=)
+                  (multiple-value-bind (kind form)
+                      (parse-initializer-body)
+                    (funcall constructor class nick name kind form
+                             pset location)))
+                (unless (require-token lexer #\, :errorp nil)
+                  (return))
+                (setf location (file-location lexer)))
+              (require-token lexer #\;)))
+
+      (loop
+       (when (require-token lexer #\} :errorp nil)
+         (return))
+       (parse-item)))
+
+    (finalize-sod-class class)
+    (add-to-module *module* class)))
+

 ;;;--------------------------------------------------------------------------
 ;;; Modules.
 
 ;;;--------------------------------------------------------------------------
 ;;; Modules.
 


@@ -359,12 +599,7 @@ (defun parse-module (lexer)
           ;;
           ;; Process an in-line Lisp form immediately.
           (:lisp
           ;;
           ;; Process an in-line Lisp form immediately.
           (:lisp

-           (let ((form (with-lexer-stream (stream lexer)
-                         (read stream t))))
-             (handler-case
-                 (eval form)
-               (error (error)
-                 (cerror* "Error in Lisp form: ~A" error))))
+           

            (next-token lexer)
            (go top))
 
            (next-token lexer)
            (go top))
 

diff --git a/parse-c-types.lisp b/parse-c-types.lisp
index 361396500165bbe3272448a9e34de3461fb3a12d..63e8b9b277a04c7486dab45af6ed4883148bbd69 100644 (file)
--- a/parse-c-types.lisp
+++ b/parse-c-types.lisp
@@ -398,9 +398,8 @@ (defun parse-c-declarator (lexer type &key abstractp dottedp)
               (eq (token-type lexer) :id))
       (let ((name (token-value lexer)))
        (next-token lexer)
               (eq (token-type lexer) :id))
       (let ((name (token-value lexer)))
        (next-token lexer)

-       (cond ((and dottedp
-                   (eq (token-type lexer) #\.))
-              (let ((sub (require-token :id :default (gensym))))
+       (cond ((and dottedp (require-token lexer #\. :errorp nil))
+              (let ((sub (require-token lexer :id :default (gensym))))

                 (setf item (cons name sub))))
              (t
               (setf item name)))))
                 (setf item (cons name sub))))
              (t
               (setf item name)))))

diff --git a/pset.lisp b/pset.lisp
index 9db8c4ffee40f0899b18a8f45dabc5e801ce3cb3..a9bbde90dc83551b138a30894be42712894dbce6 100644 (file)
--- a/pset.lisp
+++ b/pset.lisp
@@ -269,7 +269,8 @@ (defun check-unused-properties (pset)
                (unless (p-seenp prop)
                  (cerror*-with-location (p-location prop)
                                         "Unknown property `~A'"
                (unless (p-seenp prop)
                  (cerror*-with-location (p-location prop)
                                         "Unknown property `~A'"

-                                        (p-name prop))))
+                                        (p-name prop))
+                 (setf (p-seenp prop) t)))

              pset)))
 
 ;;;--------------------------------------------------------------------------
              pset)))
 
 ;;;--------------------------------------------------------------------------

diff --git a/sod.h b/sod.h
index cb562444a3f79c964bcb1576c46e0967221aeada..999c30ed34b19428414f7dc0742c561d3f8a7d6d 100644 (file)
--- a/sod.h
+++ b/sod.h
@@ -84,6 +84,19 @@ struct sod_chain {
 
 #define SOD_XCHAIN(chead, p) ((char *)(p) + (p)->_vt->_off_##chead)
 
 
 #define SOD_XCHAIN(chead, p) ((char *)(p) + (p)->_vt->_off_##chead)
 

+/* --- @SOD_OFFSETDIFF@ --- *
+ *
+ * Arguments:  @type@ = a simple (i.e., declaratorless) type name
+ *             @mema, memb@ = members of @type@
+ *
+ * Returns:    The relative offset from @mema@ to @memb@, as a @ptrdiff_t@.
+ *
+ * Use:                Computes a signed offset between structure members.
+ */
+
+#define SOD_OFFSETDIFF(type, mema, memb)                               \
+  ((ptrdiff_t)offsetof(type, memb) - (ptrdiff_t)offsetof(type, mema))
+

 /* --- @SOD_ILAYOUT@ --- *
  *
  * Arguments:  @cls@ = name of a class
 /* --- @SOD_ILAYOUT@ --- *
  *
  * Arguments:  @cls@ = name of a class

diff --git a/sod.tex b/sod.tex
index 7af3c0f0ba1e8bd915d1ac2492325adb20a1243a..dfc4a10260a0f45cd11ce75cd9ca6ff0a141e53f 100644 (file)
--- a/sod.tex
+++ b/sod.tex
@@ -933,6 +933,7 @@ the applicable methods are invoked are described fully in
 \subsection{Chains and instance layout}
 
 \include{sod-backg}
 \subsection{Chains and instance layout}
 
 \include{sod-backg}

+\include{sod-protocol}

 
 \end{document}
 \f
 
 \end{document}
 \f