From a07d8d005f69c0f9f5da2e09c6ee39cb1e1801aa Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Tue, 20 Oct 2009 01:42:17 +0100 Subject: [PATCH] It lives! The module parser is more-or-less done. Output is more-or-less done. Outstanding. Now to remove the bugs... --- builtin.lisp | 21 ++-- chimaera.sod | 51 +++++++++ class-builder.lisp | 2 +- class-layout.lisp | 23 +++-- class-output.lisp | 111 +++++++++++++++++--- codegen.lisp | 1 + examples.lisp | 8 ++ methods.lisp | 20 +++- module-output.lisp | 22 +++- module.lisp | 297 +++++++++++++++++++++++++++++++++++++++++++++++------ parse-c-types.lisp | 5 +- pset.lisp | 3 +- sod.h | 13 +++ sod.tex | 1 + 14 files changed, 503 insertions(+), 75 deletions(-) create mode 100644 chimaera.sod diff --git a/builtin.lisp b/builtin.lisp index 67c04c1..9309581 100644 --- a/builtin.lisp +++ b/builtin.lisp @@ -65,8 +65,7 @@ static void *~A__init(void *p) (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 @@ -75,14 +74,18 @@ static void *~A__init(void *p) (let ((dslot (effective-slot-direct-slot slot)) (init (effective-slot-initializer slot))) (when init + (format stream " ~A =" isl) (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%"))) diff --git a/chimaera.sod b/chimaera.sod new file mode 100644 index 0000000..d5507f8 --- /dev/null +++ b/chimaera.sod @@ -0,0 +1,51 @@ +/* -*-sod-*- + * + * A simple SOD module for testing. + */ + +code c : includes { +#include +#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 7acbeae..59dd4ee 100644 --- a/class-builder.lisp +++ b/class-builder.lisp @@ -129,7 +129,7 @@ ;; 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) diff --git a/class-layout.lisp b/class-layout.lisp index a37852e..8770739 100644 --- a/class-layout.lisp +++ b/class-layout.lisp @@ -232,12 +232,11 @@ (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 @@ -549,10 +548,14 @@ ;; 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 ~ diff --git a/class-output.lisp b/class-output.lisp index ee2daf3..da6531b 100644 --- a/class-output.lisp +++ b/class-output.lisp @@ -93,8 +93,8 @@ ((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)) @@ -106,7 +106,7 @@ (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) @@ -141,9 +141,11 @@ 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)) + (dolist (method effective-methods) + (add-output-hooks method reason sequencer)) (dolist (vtable vtables) (add-output-hooks vtable reason sequencer)))) ;;;-------------------------------------------------------------------------- @@ -166,7 +168,7 @@ (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) @@ -185,13 +187,13 @@ (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%") - (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) @@ -259,7 +261,7 @@ (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) @@ -290,7 +292,7 @@ (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))) @@ -357,7 +359,7 @@ ((: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)) @@ -382,9 +384,6 @@ const struct ~A ~A__classobj = {~%" ;;;-------------------------------------------------------------------------- ;;; 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 @@ -421,6 +420,90 @@ const struct ~A ~A__classobj = {~%" (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. (defmethod add-output-hooks progn diff --git a/codegen.lisp b/codegen.lisp index e941569..fc6a408 100644 --- a/codegen.lisp +++ b/codegen.lisp @@ -248,6 +248,7 @@ (definst function (stream) (name type body) (pprint-logical-block (stream nil) + (princ "static " stream) (pprint-c-type type stream name) (format stream "~:@_~A~:@_~:@_" body))) diff --git a/examples.lisp b/examples.lisp index f91f552..82702a6 100644 --- a/examples.lisp +++ b/examples.lisp @@ -3,6 +3,14 @@ (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| diff --git a/methods.lisp b/methods.lisp index 67033da..b54887a 100644 --- a/methods.lisp +++ b/methods.lisp @@ -382,9 +382,10 @@ (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-chain-head class))) + (sod-class-chain-head class)) + (sod-class-nickname class)) arguments-tail))) (if (varargs-message-p message) (convert-stmts codegen target @@ -533,7 +534,7 @@ 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 @@ -568,7 +569,7 @@ (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) @@ -724,4 +725,15 @@ :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 -------------------------------------------------- diff --git a/module-output.lisp b/module-output.lisp index dedbe97..891ff54 100644 --- a/module-output.lisp +++ b/module-output.lisp @@ -60,7 +60,13 @@ (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""))))) (add-output-hooks module reason sequencer) (invoke-sequencer-items sequencer stream))) @@ -71,6 +77,18 @@ (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. @@ -81,7 +99,7 @@ (:guard :start) (:typedefs :start) :typedefs (:typedefs :end) (:includes :start) :includes (:includes :end) - (:classes :start) (:classes :end) + (:classes :start) :classes (:classes :end) (:guard :end) :epilogue) diff --git a/module.lisp b/module.lisp index 5d05365..6f8aeec 100644 --- a/module.lisp +++ b/module.lisp @@ -166,9 +166,10 @@ 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*))) - (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 @@ -186,46 +187,50 @@ (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) - (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." - ;; A little fancy footwork is required because `class' is a reserved word. (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 () - ((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)) @@ -239,6 +244,82 @@ (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. @@ -281,11 +362,12 @@ (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) + "module-decl ::= `import' string `;'" (let ((name (require-token lexer :string))) (when name (find-file lexer @@ -304,6 +386,7 @@ (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 @@ -318,6 +401,163 @@ (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 ; 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 ; ~ + 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. #+(or) @@ -359,12 +599,7 @@ ;; ;; 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)) diff --git a/parse-c-types.lisp b/parse-c-types.lisp index 3613965..63e8b9b 100644 --- a/parse-c-types.lisp +++ b/parse-c-types.lisp @@ -398,9 +398,8 @@ (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))))) diff --git a/pset.lisp b/pset.lisp index 9db8c4f..a9bbde9 100644 --- a/pset.lisp +++ b/pset.lisp @@ -269,7 +269,8 @@ (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))) ;;;-------------------------------------------------------------------------- diff --git a/sod.h b/sod.h index cb56244..999c30e 100644 --- a/sod.h +++ b/sod.h @@ -84,6 +84,19 @@ struct sod_chain { #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 diff --git a/sod.tex b/sod.tex index 7af3c0f..dfc4a10 100644 --- 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} +\include{sod-protocol} \end{document} -- 2.11.0