The module parser is more-or-less done. Output is more-or-less done.
Outstanding. Now to remove the bugs...
(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
(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%")))
--- /dev/null
+/* -*-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 {
+}
+
;; 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)
(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
;; 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 ~
((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))
(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)
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))))
;;;--------------------------------------------------------------------------
(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)
(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)
(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)
(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)))
((: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))
;;;--------------------------------------------------------------------------
;;; 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
((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.
(definst function (stream) (name type body)
(pprint-logical-block (stream nil)
+ (princ "static " stream)
(pprint-c-type type stream name)
(format stream "~:@_~A~:@_~:@_" body)))
(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|
(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
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
(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)
: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 --------------------------------------------------
(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)))
(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.
(:guard :start)
(:typedefs :start) :typedefs (:typedefs :end)
(:includes :start) :includes (:includes :end)
- (:classes :start) (:classes :end)
+ (:classes :start) :classes (:classes :end)
(:guard :end)
:epilogue)
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
(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))
(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.
(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
(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
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.
;;
;; 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))
(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)))))
(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)))
;;;--------------------------------------------------------------------------
#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
\subsection{Chains and instance layout}
\include{sod-backg}
+\include{sod-protocol}
\end{document}
\f
~mdw / sod / commitdiff