,(lambda (class)
(format nil "sizeof(struct ~A)"
(ilayout-struct-tag class))))
- ("imprint" ,(c-type (* (fun (* void) ("p" (* void)))))
+ ("imprint" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
:prepare-function 'output-imprint-function
:initializer-function
,(lambda (class)
(format nil "~A__imprint" class)))
- ("init" ,(c-type (* (fun (* void) ("p" (* void)))))
+ ("init" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
:prepare-function 'output-init-function
:initializer-function
,(lambda (class)
(defun make-builtin-module ()
(let ((module (make-instance 'module
- :name (make-pathname :name "BUILTIN"
+ :name (make-pathname :name "SOD-BASE"
:type "SOD"
:case :common)
:state nil))
(check-method-type method message type)))
;;;--------------------------------------------------------------------------
-;;; Builder macro.
+;;; Builder macros.
(defmacro define-sod-class (name (&rest superclasses) &body body)
(let ((plist nil)
,@plist))))
,@body
(finalize-sod-class ,classvar)
- (record-sod-class ,classvar)))))
-
-#+test
-(define-sod-class "AbstractStack" ("SodObject")
- :nick 'abstk
- (message "emptyp" (fun int))
- (message "push" (fun void ("item" (* void))))
- (message "pop" (fun (* void)))
- (method "abstk" "pop" (fun void) #{
- assert(!me->_vt.emptyp());
- }
- :role :before))
+ (add-to-module *module* ,classvar)))))
;;;----- That's all, folks --------------------------------------------------
(class-precedence-list :type list :accessor sod-class-precedence-list)
+ (type :type c-class-type :accessor sod-class-type)
+
(chain-head :type sod-class :accessor sod-class-chain-head)
(chain :type list :accessor sod-class-chain)
(chains :type list :accessor sod-class-chains)
(t
(setf (c-type-class type) class))))))
-(defun sod-class-type (class)
- "Returns the C type corresponding to CLASS."
- (find-class-type (sod-class-name class)))
-
(define-c-type-syntax class (name &rest quals)
"Returns a type object for the named class."
(if quals
(error "Invalid message name `~A' on class `~A'"
(sod-message-name message) class))))
- ;; Check that the slots and messages have distinct names.
+ ;; Check that the slots and messages have distinct names.
(with-slots (slots messages class-precedence-list) class
(flet ((check-list (list what namefunc)
(let ((table (make-hash-table :test #'equal)))
(error "In `~A~, chain-to class `~A' is not a proper superclass"
class chain-link)))
+ ;; Check for circularity in the superclass graph. Since the superclasses
+ ;; should already be acyclic, it suffices to check that our class is not
+ ;; a superclass of any of its own direct superclasses.
+ (let ((circle (find-if (lambda (super)
+ (sod-subclass-p super class))
+ (sod-class-direct-superclasses class))))
+ (when circle
+ (error "Circularity: ~A is already a superclass of ~A"
+ class circle)))
+
+ ;; Check that the class has a unique root superclass.
+ (find-root-superclass class)
+
;; Check that the metaclass is a subclass of each direct superclass's
;; metaclass.
(with-slots (metaclass direct-superclasses) class
(eq class metaclass))
(finalize-sod-class metaclass)))
+ ;; Stash the class's type.
+ (setf (sod-class-type class)
+ (make-class-type (sod-class-name class)))
+
;; Clobber the lists of items if they've not been set.
(dolist (slot '(slots instance-initializers class-initializers
messages methods))
(defclass vtable-pointer ()
((class :initarg :class :type sod-class :reader vtable-pointer-class)
(chain-head :initarg :chain-head :type sod-class
- :reader vtable-pointer-chain-head))
+ :reader vtable-pointer-chain-head)
+ (chain-tail :initarg :chain-tail :type sod-class
+ :reader vtable-pointer-chain-tail))
(:documentation
"A pointer to the vtable for CLASS corresponding to a particular CHAIN."))
(defclass ichain ()
((class :initarg :class :type sod-class :reader ichain-class)
(chain-head :initarg :chain-head :type sod-class :reader ichain-head)
+ (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail)
(body :initarg :body :type list :reader ichain-body))
(:documentation
"All of the instance layout for CLASS corresponding to a particular CHAIN.
(sod-class-slots class))))
(defmethod compute-ichain ((class sod-class) chain)
- (let* ((head (car chain))
+ (let* ((chain-head (car chain))
+ (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
+ :key #'sod-class-chain-head))
(vtable-pointer (make-instance 'vtable-pointer
:class class
- :chain-head head))
+ :chain-head chain-head
+ :chain-tail chain-tail))
(islots (remove-if-not #'islots-slots
(mapcar (lambda (super)
(compute-islots super class))
chain))))
(make-instance 'ichain
:class class
- :chain-head head
+ :chain-head chain-head
+ :chain-tail chain-tail
:body (cons vtable-pointer islots))))
(defmethod compute-ilayout ((class sod-class))
(defclass method-entry ()
((method :initarg :method :type effective-method
:reader method-entry-effective-method)
- (chain-head :initarg :chain-head
- :type sod-class
- :reader method-entry-chain-head))
+ (chain-head :initarg :chain-head :type sod-class
+ :reader method-entry-chain-head)
+ (chain-tail :initarg :chain-tail :type sod-class
+ :reader method-entry-chain-tail))
(:documentation
"An entry point into an effective method.
(method-entry-effective-method entry)
(sod-class-nickname (method-entry-chain-head entry)))))
-(defgeneric make-method-entry (effective-method chain-head)
+(defgeneric make-method-entry (effective-method chain-head chain-tail)
(:documentation
"Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
(subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
(chain-head :initarg :chain-head :type sod-class
:reader vtmsgs-chain-head)
+ (chain-tail :initarg :chain-tail :type sod-class
+ :reader vtmsgs-chain-tail)
(entries :initarg :entries :type list :reader vtmsgs-entries))
(:documentation
"The message dispatch table for a particular CLASS.
- The BODY contains a list of effective method objects for the messages
- defined on CLASS, customized for calling from the chain headed by
+ The BODY contains a list of effective method entry objects for the
+ messages defined on CLASS, customized for calling from the chain headed by
CHAIN-HEAD."))
(defmethod print-object ((vtmsgs vtmsgs) stream)
(vtmsgs-class vtmsgs)
(vtmsgs-entries vtmsgs))))
-(defgeneric compute-vtmsgs (class subclass chain-head)
+(defgeneric compute-vtmsgs (class subclass chain-head chain-tail)
(:documentation
"Return a VTMSGS object containing method entries for CLASS.
((class :initarg :class :type sod-class :reader vtable-class)
(chain-head :initarg :chain-head :type sod-class
:reader vtable-chain-head)
+ (chain-tail :initarg :chain-tail :type sod-class
+ :reader vtable-chain-tail)
(body :initarg :body :type list :reader vtable-body))
(:documentation
"VTABLEs hold all of the per-chain static information for a class.
(defmethod compute-vtmsgs
((class sod-class)
(subclass sod-class)
- (chain-head sod-class))
+ (chain-head sod-class)
+ (chain-tail sod-class))
(flet ((make-entry (message)
(let ((method (find message
(sod-class-effective-methods subclass)
:key #'effective-method-message)))
- (make-method-entry method chain-head))))
+ (make-method-entry method chain-head chain-tail))))
(make-instance 'vtmsgs
:class class
:subclass subclass
:chain-head chain-head
+ :chain-tail chain-tail
:entries (mapcar #'make-entry
(sod-class-messages class)))))
(defvar *done-metaclass-chains*)
(defvar *done-instance-chains*)
-(defgeneric compute-vtable-items (class super chain-head emit)
+(defgeneric compute-vtable-items (class super chain-head chain-tail emit)
(:documentation
"Emit vtable items for a superclass of CLASS.
(defmethod compute-vtable-items
((class sod-class) (super sod-class) (chain-head sod-class)
- (emit function))
+ (chain-tail sod-class) (emit function))
;; If this class introduces new metaclass chains, then emit pointers to
;; them.
;; Finally, if there are interesting methods, emit those too.
(when (sod-class-messages super)
- (funcall emit (compute-vtmsgs super class chain-head))))
+ (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
+
+(defun find-root-superclass (class)
+ "Returns the `root' superclass of CLASS.
+
+ The root superclass is the superclass which itself has no direct
+ superclasses. In universes not based on the provided builtin module, the
+ root class may not be our beloved SodObject; however, there must be one
+ (otherwise the class graph is cyclic, which should be forbidden), and we
+ instist that it be unique."
+
+ ;; The root superclass must be a chain head since the chains partition the
+ ;; superclasses; the root has no superclasses so it can't have a link and
+ ;; must therefore be a head. This narrows the field down quite a lot.
+ ;;
+ ;; Note! This function gets called from CHECK-SOD-CLASS before the class's
+ ;; chains have been computed. Therefore we iterate over the direct
+ ;; superclass's chains rather than the class's own. This misses a chain
+ ;; only in the case where the class is its own chain head. There are two
+ ;; subcases: if there are no direct superclasses at all, then the class is
+ ;; its own root; otherwise, it clearly can't be the root and the omission
+ ;; is harmless.
+ (let* ((supers (sod-class-direct-superclasses class))
+ (roots (if supers
+ (remove-if #'sod-class-direct-superclasses
+ (mapcar (lambda (super)
+ (sod-class-chain-head super))
+ supers))
+ (list class))))
+ (cond ((null roots) (error "Class ~A has no root class!" class))
+ ((cdr roots) (error "Class ~A has multiple root classes ~
+ ~{~A~#[~; and ~;, ~]~}"
+ class roots))
+ (t (car roots)))))
+
+(defun find-root-metaclass (class)
+ "Returns the `root' metaclass of CLASS.
+
+ The root metaclass is the metaclass of the root superclass -- see
+ FIND-ROOT-SUPERCLASS."
+ (sod-class-metaclass (find-root-superclass class)))
(defmethod compute-vtable ((class sod-class) (chain list))
(let* ((chain-head (car chain))
+ (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
+ :key #'sod-class-chain-head))
(*done-metaclass-chains* nil)
(*done-instance-chains* (list chain-head))
(done-superclasses nil)
;; Find the root chain in the metaclass and write a pointer.
(let* ((metaclass (sod-class-metaclass class))
- (metaclass-chains (sod-class-chains metaclass))
- (metaclass-chain-heads (mapcar (lambda (chain)
- (sod-class-chain-head
- (car chain)))
- metaclass-chains))
- (metaclass-root-chain (find-if-not
- #'sod-class-direct-superclasses
- metaclass-chain-heads)))
- (emit (make-class-pointer class chain-head
- metaclass metaclass-root-chain))
- (push metaclass-root-chain *done-metaclass-chains*))
+ (metaclass-root (find-root-metaclass class))
+ (metaclass-root-head (sod-class-chain-head metaclass-root)))
+ (emit (make-class-pointer class chain-head metaclass
+ metaclass-root-head))
+ (push metaclass-root-head *done-metaclass-chains*))
;; Write an offset to the instance base.
(emit (make-base-offset class chain-head))
(compute-vtable-items class
sub
chain-head
+ chain-tail
#'emit)
(push sub done-superclasses))))
(make-instance 'vtable
:class class
:chain-head chain-head
+ :chain-tail chain-tail
:body (nreverse items)))))
(defgeneric compute-effective-methods (class)
(format nil "~A__islots" class))
(defun ichain-struct-tag (class chain-head)
- (format nil "~A__ichain_~A" class(sod-class-nickname chain-head)))
+ (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))
+
+(defun ichain-union-tag (class chain-head)
+ (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))
(defun ilayout-struct-tag (class)
(format nil "~A__ilayout" class))
(defun vtable-name (class chain-head)
(format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
-;;;--------------------------------------------------------------------------
-;;; Hacks for now.
-
-(defclass hacky-effective-method (effective-method)
- ((direct-methods :initarg :direct-methods)))
-
-(defmethod print-object ((method hacky-effective-method) stream)
- (if *print-escape*
- (print-unreadable-object (method stream :type t)
- (format stream "~A ~_~A ~_~:<~@{~S~^ ~_~}~:>"
- (effective-method-message method)
- (effective-method-class method)
- (slot-value method 'direct-methods)))
- (call-next-method)))
-
-(defmethod message-effective-method-class ((message sod-message))
- 'hacky-effective-method)
-
-(defmethod make-method-entry
- ((method hacky-effective-method) (chain-head sod-class))
- (make-instance 'method-entry
- :method method
- :chain-head chain-head))
-
;;;----- That's all, folks --------------------------------------------------
(class :vtmsgs :start) (class :vtmsgs :end)
(class :vtables :start) (class :vtables :end)
(class :vtable-externs) (class :vtable-externs-after)
- (class :direct-methods)
+ (class :methods :start) (class :methods) (class :methods :end)
(class :ichains :start) (class :ichains :end)
(class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
(class :conversions)
+ (class :object)
(:classes :end))
(:typedefs
((class :banner)
(banner (format nil "Class ~A" class) stream))
((class :vtable-externs-after)
- (terpri stream)))
+ (terpri stream))
+
+ ((class :vtable-externs)
+ (format stream "/* Vtable structures. */~%"))
+
+ ((class :object)
+ (let ((metaclass (sod-class-metaclass class))
+ (metaroot (find-root-metaclass class)))
+ (format stream "/* The class object. */~%~
+ extern struct ~A ~A__classobj;~%~
+ #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
+ (ilayout-struct-tag metaclass) class
+ (sod-class-nickname (sod-class-chain-head metaroot))
+ (sod-class-nickname metaroot)))))
;; Maybe generate an islots structure.
(when (sod-class-slots class)
(add-output-hooks slot 'populate-islots sequencer))
(sequence-output (stream sequencer)
((class :islots :start)
- (format stream "struct ~A {~%" (islots-struct-tag class)))
+ (format stream "/* Instance slots. */~%~
+ struct ~A {~%"
+ (islots-struct-tag class)))
((class :islots :end)
(format stream "};~2%"))))
;; Declare the direct methods.
(when (sod-class-methods class)
- (dolist (method (sod-class-methods class))
- (add-output-hooks method :declare-direct-methods sequencer))
(sequence-output (stream sequencer)
- ((class :direct-methods)
+ ((class :methods :start)
+ (format stream "/* Direct methods. */~%"))
+ ((class :methods :end)
(terpri stream))))
;; Provide upcast macros which do the right thing.
(sequence-output (stream sequencer)
((class :conversions)
(let ((chain-head (sod-class-chain-head class)))
+ (format stream "/* Conversion macros. */~%")
(dolist (super (cdr (sod-class-precedence-list class)))
(let ((super-head (sod-class-chain-head super)))
- (format stream (concatenate 'string "#define "
- "~:@(~A__CONV_~A~)(p) ((~A *)"
- "~:[SOD_XCHAIN(~A, p)~;p~])~%")
+ (format stream "#define ~:@(~A__CONV_~A~)(p) ((~A *)~
+ ~:[SOD_XCHAIN(~A, (p))~;(p)~])~%"
class (sod-class-nickname super) super
(eq chain-head super-head)
- (sod-class-nickname super-head))))))))
+ (sod-class-nickname super-head))))
+ (terpri stream)))))
;; Generate vtmsgs structure for all superclasses.
(add-output-hooks (car (sod-class-vtables class))
sequencer))
(defmethod add-output-hooks progn ((class sod-class) reason sequencer)
- (with-slots (ilayout vtables) class
+ (with-slots (ilayout vtables methods) class
(add-output-hooks ilayout reason sequencer)
+ (dolist (method 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 "struct ~A {~%" (ilayout-struct-tag class)))
+ (format stream "/* Instance layout. */~%~
+ struct ~A {~%"
+ (ilayout-struct-tag class)))
((class :ilayout :end)
(format stream "};~2%")))
(dolist (ichain ichains)
(defmethod add-output-hooks progn
((ichain ichain) (reason (eql :h)) sequencer)
- (with-slots (class chain-head) ichain
- (sequence-output (stream sequencer)
- :constraint ((class :ichains :start)
- (class :ichain chain-head :start)
- (class :ichain chain-head :slots)
- (class :ichain chain-head :end)
- (class :ichains :end))
- ((class :ichain chain-head :start)
- (format stream "struct ~A {~%" (ichain-struct-tag class chain-head)))
- ((class :ichain chain-head :end)
- (format stream "};~2%")))))
+ (with-slots (class chain-head chain-tail) ichain
+ (when (eq class chain-tail)
+ (sequence-output (stream sequencer)
+ :constraint ((class :ichains :start)
+ (class :ichain chain-head :start)
+ (class :ichain chain-head :slots)
+ (class :ichain chain-head :end)
+ (class :ichains :end))
+ ((class :ichain chain-head :start)
+ (format stream "/* Instance chain structure. */~%~
+ struct ~A {~%"
+ (ichain-struct-tag chain-tail chain-head)))
+ ((class :ichain chain-head :end)
+ (format stream "};~2%")
+ (format stream "/* Union of equivalent superclass chains. */~%~
+ union ~A {~%~
+ ~:{ struct ~A ~A;~%~}~
+ };~2%"
+ (ichain-union-tag chain-tail chain-head)
+ (mapcar (lambda (super)
+ (list (ichain-struct-tag super chain-head)
+ (sod-class-nickname super)))
+ (sod-class-chain chain-tail))))))))
(defmethod add-output-hooks progn
((ichain ichain) (reason (eql 'populate-ilayout)) sequencer)
- (with-slots (class chain-head) ichain
+ (with-slots (class chain-head chain-tail) ichain
(sequence-output (stream sequencer)
((class :ilayout :slots)
- (format stream " struct ~A ~A;~%"
- (ichain-struct-tag class chain-head)
+ (format stream " union ~A ~A;~%"
+ (ichain-union-tag chain-tail chain-head)
(sod-class-nickname chain-head))))))
-(defmethod add-output-hooks progn ((ichain ichain) reason sequencer)
- (with-slots (body) ichain
- (dolist (item body) (add-output-hooks item reason sequencer))))
-
(defmethod add-output-hooks progn
((vtptr vtable-pointer) (reason (eql :h)) sequencer)
- (with-slots (class chain-head) vtptr
+ (with-slots (class chain-head chain-tail) vtptr
(sequence-output (stream sequencer)
((class :ichain chain-head :slots)
(format stream " const struct ~A *_vt;~%"
- (vtable-struct-tag class chain-head))))))
+ (vtable-struct-tag chain-tail chain-head))))))
(defmethod add-output-hooks progn
((islots islots) (reason (eql :h)) sequencer)
(dolist (item body) (add-output-hooks item reason sequencer))))
(defmethod add-output-hooks progn
+ ((method sod-method) (reason (eql :h)) sequencer)
+ (with-slots (class) method
+ (sequence-output (stream sequencer)
+ ((class :methods)
+ (let ((type (sod-method-function-type method)))
+ (princ "extern " stream)
+ (pprint-c-type (commentify-function-type type) stream
+ (sod-method-function-name method))
+ (format stream ";~%"))))))
+
+(defmethod add-output-hooks progn
((vtable vtable) (reason (eql :h)) sequencer)
- (with-slots (class chain-head) vtable
+ (with-slots (class chain-head chain-tail) vtable
+ (when (eq class chain-tail)
+ (sequence-output (stream sequencer)
+ :constraint ((class :vtables :start)
+ (class :vtable chain-head :start)
+ (class :vtable chain-head :slots)
+ (class :vtable chain-head :end)
+ (class :vtables :end))
+ ((class :vtable chain-head :start)
+ (format stream "/* Vtable structure. */~%~
+ struct ~A {~%"
+ (vtable-struct-tag chain-tail chain-head)))
+ ((class :vtable chain-head :end)
+ (format stream "};~2%"))))
(sequence-output (stream sequencer)
- :constraint ((class :vtables :start)
- (class :vtable chain-head :start)
- (class :vtable chain-head :slots)
- (class :vtable chain-head :end)
- (class :vtables :end))
- ((class :vtable chain-head :start)
- (format stream "struct ~A {~%" (vtable-struct-tag class chain-head)))
- ((class :vtable chain-head :end)
- (format stream "};~2%"))
((class :vtable-externs)
(format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
- (vtable-struct-tag class chain-head)
+ (vtable-struct-tag chain-tail chain-head)
class (sod-class-nickname chain-head))))))
(defmethod add-output-hooks progn
((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
- (with-slots (class subclass chain-head) vtmsgs
+ (with-slots (class subclass chain-head chain-tail) vtmsgs
(sequence-output (stream sequencer)
((subclass :vtable chain-head :slots)
(format stream " struct ~A ~A;~%"
(subclass :vtmsgs class :end)
(subclass :vtmsgs :end))
((subclass :vtmsgs class :start)
- (format stream "struct ~A {~%" (vtmsgs-struct-tag subclass class)))
+ (format stream "/* Messages protocol from class ~A */~%~
+ struct ~A {~%"
+ class
+ (vtmsgs-struct-tag subclass class)))
((subclass :vtmsgs class :end)
(format stream "};~2%"))))))
(add-output-hooks method reason sequencer)))
(defmethod add-output-hooks progn
- ((method effective-method) (reason (eql 'populate-vtmsgs)) sequencer)
- (let* ((message (effective-method-message method))
+ ((entry method-entry) (reason (eql 'populate-vtmsgs)) sequencer)
+ (let* ((method (method-entry-effective-method entry))
+ (message (effective-method-message method))
(class (effective-method-class method))
- (class-type (find-class-type (sod-class-name class)))
- (raw-type (sod-message-type message))
- (type (c-type (* (fun (lisp (c-type-subtype raw-type))
- ("/*me*/" (* (lisp class-type)))
- . (commentify-argument-names
- (c-function-arguments raw-type)))))))
+ (type (method-entry-function-type entry))
+ (commented-type (commentify-function-type type)))
(sequence-output (stream sequencer)
((class :vtmsgs (sod-message-class message) :slots)
(pprint-logical-block (stream nil :prefix " " :suffix ";")
- (pprint-c-type type stream (sod-message-name message)))
+ (pprint-c-type commented-type stream (sod-message-name message)))
(terpri stream)))))
(defmethod add-output-hooks progn
(set-dispatch-macro-character #\# #\{ 'c-fragment-reader)
-(progn
- (clear-the-decks)
-
- (define-sod-class "Animal" ("SodObject")
- :nick 'nml
- :link '|SodObject|
- (slot "tickles" int)
- (instance-initializer "nml" "tickles" :single #{ 0 })
- (message "tickle" (fun void))
- (method "nml" "tickle" (fun void) #{
- me->tickles++;
- }
- :role :before)
- (method "nml" "tickle" (fun void) #{ }))
-
- (define-sod-class "Lion" ("Animal")
- :nick 'lion
- :link '|Animal|
- (message "bite" (fun void))
- (method "lion" "bite" (fun void) nil)
- (method "nml" "tickle" (fun void) #{
- me->_vt->lion.bite(me);
- CALL_NEXT_METHOD;
- }))
-
- (define-sod-class "Goat" ("Animal")
- :nick 'goat
- (message "butt" (fun void))
- (method "goat" "butt" (fun void) nil)
- (method "nml" "tickle" (fun void) #{
- me->_vt->goat.bite(me);
- CALL_NEXT_METHOD;
- }))
-
- (define-sod-class "Serpent" ("Animal")
- :nick 'serpent
- (message "bite" (fun void))
- (method "serpent" "bite" (fun void) nil)
- (message "hiss" (fun void))
- (method "serpent" "hiss" (fun void) nil)
- (method "nml" "tickle" (fun void) #{
- if (me->tickles < 3) me->_vt->hiss(me);
- else me->_vt->bite(me);
- CALL_NEXT_METHOD;
- }))
-
- (define-sod-class "Chimaera" ("Lion" "Goat" "Serpent")
- :nick 'sir
- :link '|Lion|)
-
- (defparameter *chimaera* (find-sod-class "Chimaera"))
- (defparameter *emeth* (find "tickle"
- (sod-class-effective-methods *chimaera*)
- :key (lambda (method)
- (sod-message-name
- (effective-method-message method)))
- :test #'string=)))
+(defparameter *chimaera-module*
+ (define-module ("chimaera.sod")
+
+ (define-sod-class "Animal" ("SodObject")
+ :nick 'nml
+ :link '|SodObject|
+ (slot "tickles" int)
+ (instance-initializer "nml" "tickles" :single #{ 0 })
+ (message "tickle" (fun void))
+ (method "nml" "tickle" (fun void) #{
+ me->tickles++;
+ }
+ :role :before)
+ (method "nml" "tickle" (fun void) #{ }))
+
+ (define-sod-class "Lion" ("Animal")
+ :nick 'lion
+ :link '|Animal|
+ (message "bite" (fun void))
+ (method "lion" "bite" (fun void) nil)
+ (method "nml" "tickle" (fun void) #{
+ me->_vt->lion.bite(me);
+ CALL_NEXT_METHOD;
+ }))
+
+ (define-sod-class "Goat" ("Animal")
+ :nick 'goat
+ (message "butt" (fun void))
+ (method "goat" "butt" (fun void) nil)
+ (method "nml" "tickle" (fun void) #{
+ me->_vt->goat.bite(me);
+ CALL_NEXT_METHOD;
+ }))
+
+ (define-sod-class "Serpent" ("Animal")
+ :nick 'serpent
+ (message "bite" (fun void))
+ (method "serpent" "bite" (fun void) nil)
+ (message "hiss" (fun void))
+ (method "serpent" "hiss" (fun void) nil)
+ (method "nml" "tickle" (fun void) #{
+ if (me->tickles < 3) me->_vt->hiss(me);
+ else me->_vt->bite(me);
+ CALL_NEXT_METHOD;
+ }))
+
+ (define-sod-class "Chimaera" ("Lion" "Goat" "Serpent")
+ :nick 'sir
+ :link '|Lion|)
+
+ (defparameter *chimaera* (find-sod-class "Chimaera"))
+ (defparameter *emeth* (find "tickle"
+ (sod-class-effective-methods *chimaera*)
+ :key (lambda (method)
+ (sod-message-name
+ (effective-method-message method)))
+ :test #'string=))))
"struct" "union" "enum"))
(defclass sod-lexer (lexer)
- ((keywords :initarg :keywords :initform *sod-keywords*
- :type hash-table :reader lexer-keywords))
+ ()
(:documentation
"Lexical analyser for the SOD lanuage.
(char= ch #\_))))
(return))))))
- ;; Check to see whether we match any keywords.
- (multiple-value-bind (keyword foundp) (gethash id keywords)
- (return (values (if foundp keyword :id) id)))))
+ ;; Done.
+ (return (values :id id))))
;; Pick out numbers. Currently only integers, but we support
;; multiple bases.
However, an :ELLIPSIS is replaced by an argument of type `va_list', named
`sod__ap'."))
-(defgeneric direct-method-function-type (method)
+(defgeneric sod-method-function-type (method)
(:documentation
"Return the C function type for the direct method.
prepends an appropriate `me' argument to the user-provided argument list.
Fancy method classes may need to override this behaviour."))
-(defgeneric direct-method-next-method-type (method)
+(defgeneric sod-method-next-method-type (method)
(:documentation
"Return the C function type for the next-method trampoline.
the right job. Very fancy subclasses might need to do something
different."))
-(defgeneric direct-method-function-name (method)
+(defgeneric sod-method-function-name (method)
(:documentation
"Return the C function name for the direct method."))
+(defgeneric method-entry-function-type (entry)
+ (:documentation
+ "Return the C function type for a method entry."))
+
;;;--------------------------------------------------------------------------
;;; Message classes.
("me" (* (class (sod-method-class method))))
. (c-function-arguments type))))))
-(defmethod direct-method-function-name ((method basic-direct-method))
+(defmethod sod-method-function-name ((method basic-direct-method))
(with-slots (class role message) method
(format nil "~A__~@[~(~A~)_~]method_~A__~A" class role
(sod-class-nickname (sod-message-class message))
(let* ((message (sod-method-message direct-method))
(class (sod-method-class direct-method))
- (function (direct-method-function-name direct-method))
+ (function (sod-method-function-name direct-method))
(arguments (cons (format nil "(~A *)&sod__obj.~A" class
(sod-class-nickname
(sod-class-chain-head class)))
(codegen-pop-function codegen (temporary-function)
(c-type (fun (lisp return-type)
("me" (* (class super)))
- . arguments))))))
+ . arguments)))))
(defun invoke-delegation-chain (codegen target basic-tail chain kernel)
"Invoke a chain of delegating methods.
(setf (slot-value method 'functions)
(compute-method-entry-functions method)))
-(defmethod make-method-entry
- ((method basic-effective-method) (chain-head sod-class))
- (make-instance 'method-entry :method method :chain-head chain-head))
+(defmethod method-entry-function-type ((entry method-entry))
+ (let* ((method (method-entry-effective-method entry))
+ (message (effective-method-message method))
+ (type (sod-message-type message)))
+ (c-type (fun (lisp (c-type-subtype type))
+ ("me" (* (class (method-entry-chain-tail entry))))
+ . (sod-message-argument-tail message)))))
+
+(defmethod make-method-entry ((method basic-effective-method)
+ (chain-head sod-class) (chain-tail sod-class))
+ (make-instance 'method-entry
+ :method method
+ :chain-head chain-head
+ :chain-tail chain-tail))
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Output handling for modules
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun banner (title output &key (blank-line-p t))
+ (format output "~&/*----- ~A ~A*/~%"
+ title
+ (make-string (- 77 2 5 1 (length title) 1 2)
+ :initial-element #\-))
+ (when blank-line-p
+ (terpri output)))
+
+(defun guard-name (filename)
+ "Return a sensible inclusion guard name for FILENAME."
+ (with-output-to-string (guard)
+ (let* ((pathname (make-pathname :name (pathname-name filename)
+ :type (pathname-type filename)))
+ (name (namestring pathname))
+ (uscore t))
+ (dotimes (i (length name))
+ (let ((ch (char name i)))
+ (cond ((alphanumericp ch)
+ (write-char (char-upcase ch) guard)
+ (setf uscore nil))
+ ((not uscore)
+ (write-char #\_ guard)
+ (setf uscore t))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Driving output.
+
+(defun guess-output-file (module type)
+ (merge-pathnames (make-pathname :type type :case :common)
+ (module-name module)))
+
+(defun output-module (module reason stream)
+ (let ((sequencer (make-instance 'sequencer)))
+ (add-output-hooks module reason sequencer)
+ (invoke-sequencer-items sequencer stream)))
+
+;;;--------------------------------------------------------------------------
+;;; Main output protocol implementation.
+
+(defmethod add-output-hooks progn ((module module) reason sequencer)
+ (dolist (item (module-items module))
+ (add-output-hooks item reason sequencer)))
+
+;;;--------------------------------------------------------------------------
+;;; Header output.
+
+(defmethod add-output-hooks progn
+ ((module module) (reason (eql :h)) sequencer)
+ (sequence-output (stream sequencer)
+ :constraint (:prologue
+ (:guard :start)
+ (:typedefs :start) :typedefs (:typedefs :end)
+ (:includes :start) :includes (:includes :end)
+ (:classes :start) (:classes :end)
+ (:guard :end)
+ :epilogue)
+
+ (:prologue
+ (format stream "~
+/* -*-c-*-
+ *
+ * Header file generated by SOD for ~A
+ */~2%"
+ (namestring (module-name module))))
+
+ ((:guard :start)
+ (format stream "~
+#ifndef ~A
+#define ~:*~A
+
+#ifdef __cplusplus
+ extern \"C\" {
+#endif~2%"
+ (or (get-property (module-pset module) :guard :id)
+ (guard-name (or (stream-pathname stream)
+ (guess-output-file module "H"))))))
+ ((:guard :end)
+ (banner "That's all, folks" stream)
+ (format stream "~
+#ifdef __cplusplus
+ }
+#endif
+
+#endif~%"))
+
+ ((:typedefs :start)
+ (banner "Forward type declarations" stream))
+ ((:typedefs :end)
+ (terpri stream))
+
+ ((:includes :start)
+ (banner "External header files" stream))
+ ((:includes :end)
+ (terpri stream))))
+
+;;;----- That's all, folks --------------------------------------------------
;;;--------------------------------------------------------------------------
;;; Module importing.
+(defun build-module
+ (name body-func &key (truename (probe-file name)) location)
+ (let ((*module* (make-instance 'module
+ :name (pathname name)
+ :state (file-location location)))
+ (*type-map* (make-hash-table :test #'equal)))
+ (module-import *builtin-module*)
+ (when truename
+ (setf (gethash truename *module-map*) *module*))
+ (unwind-protect
+ (progn
+ (funcall body-func)
+ (finalize-module *module*))
+ (when (and truename (not (eq (module-state *module*) t)))
+ (remhash truename *module-map*)))))
+
+(defmacro define-module
+ ((name &key (truename nil truenamep) (location nil locationp))
+ &body body)
+ `(build-module ,name
+ (lambda () ,@body)
+ ,@(and truenamep `(:truename ,truename))
+ ,@(and locationp `(:location ,location))))
+
(defun read-module (pathname &key (truename (truename pathname)) location)
"Reads a module.
;; Make a new module. Be careful to remove the module from the map if we
;; didn't succeed in constructing it.
- (let ((*module* (make-instance 'module
- :name pathname
- :state (file-location location)))
- (*type-map* (make-hash-table :test #'equal)))
- (module-import *builtin-module*)
- (setf (gethash truename *module-map*) *module*)
- (unwind-protect
- (with-open-file (f-stream pathname :direction :input)
- (let* ((*module* (make-instance 'module :name pathname))
- (pai-stream (make-instance 'position-aware-input-stream
- :stream f-stream
- :file pathname))
- (lexer (make-instance 'sod-lexer :stream pai-stream)))
- (with-default-error-location (lexer)
- (next-char lexer)
- (next-token lexer)
- (parse-module lexer *module*)
- (finalize-module *module*))))
- (unless (eq (module-state *module*) t)
- (remhash truename *module-map*)))))
+ (define-module (pathname :location location :truename truename)
+ (let ((*readtable* (copy-readtable)))
+ (with-open-file (f-stream pathname :direction :input)
+ (let* ((pai-stream (make-instance 'position-aware-input-stream
+ :stream f-stream
+ :file pathname))
+ (lexer (make-instance 'sod-lexer :stream pai-stream)))
+ (with-default-error-location (lexer)
+ (next-char lexer)
+ (next-token lexer)
+ (parse-module lexer *module*)))))))
;;;--------------------------------------------------------------------------
;;; Module parsing protocol.
;;;--------------------------------------------------------------------------
;;; Utilities.
-(defun banner (title output &key (blank-line-p t))
- (format output "~&~%/*----- ~A ~A*/~%"
- title
- (make-string (- 77 2 5 1 (length title) 1 2)
- :initial-element #\-))
- (when blank-line-p
- (terpri output)))
-
;;;--------------------------------------------------------------------------
;;; Header output.
#endif~%"
(namestring (module-name module))
(or (getf (module-plist module) 'include-guard)
- (with-output-to-string (guard)
- (let ((name (namestring file))
- (uscore t))
- (dotimes (i (length name))
- (let ((ch (char name i)))
- (cond ((alphanumericp ch)
- (write-char (char-upcase ch) guard)
- (setf uscore nil))
- ((not uscore)
- (write-char #\_ guard)
- (setf uscore t)))))))))
+ ))
;; Forward declarations of all the structures and types. Nothing
;; interesting gets said here; this is just so that the user code
;;; groups the other three kinds together and calls them all `type
;;; specifiers' (6.7.2).
+;; Let's not repeat ourselves.
+(macrolet ((define-declaration-specifiers (&rest defs)
+ (let ((mappings nil)
+ (deftypes nil)
+ (hashvar (gensym "HASH"))
+ (keyvar (gensym "KEY"))
+ (valvar (gensym "VAL")))
+ (dolist (def defs)
+ (destructuring-bind (kind &rest clauses) def
+ (let ((maps (mapcar (lambda (clause)
+ (if (consp clause)
+ clause
+ (cons (string-downcase clause)
+ clause)))
+ clauses)))
+ (push `(deftype ,(symbolicate 'decl- kind) ()
+ '(member ,@(mapcar #'cdr maps)))
+ deftypes)
+ (setf mappings (nconc (remove-if-not #'car maps)
+ mappings)))))
+ `(progn
+ ,@(nreverse deftypes)
+ (defparameter *declspec-map*
+ (let ((,hashvar (make-hash-table :test #'equal)))
+ (mapc (lambda (,keyvar ,valvar)
+ (setf (gethash ,keyvar ,hashvar) ,valvar))
+ ',(mapcar #'car mappings)
+ ',(mapcar #'cdr mappings))
+ ,hashvar))))))
+ (define-declaration-specifiers
+ (type :char :int :float :double :void)
+ (size :short :long (nil . :long-long))
+ (sign :signed :unsigned)
+ (qualifier :const :restrict :volatile)
+ (tagged :enum :struct :union)))
+
(defstruct (declspec
(:predicate declspecp))
"Represents a declaration specifier being built."
(qualifiers nil :type list)
- (sign nil :type (member nil :signed :unsigned))
- (size nil :type (member nil :short :long :long-long))
- (type nil :type (or (member nil :int :char :float :double :void) c-type)))
+ (sign nil :type (or decl-sign null))
+ (size nil :type (or decl-size null))
+ (type nil :type (or decl-type c-type null)))
(defun check-declspec (spec)
"Check that the declaration specifiers in SPEC are a valid combination.
(defun declaration-specifier-p (lexer)
"Answer whether the current token might be a declaration specifier."
- (case (token-type lexer)
- ((:const :volatile :restrict
- :signed :unsigned
- :short :long
- :void :char :int :float :double
- :enum :struct :union)
- t)
- (:id
- (gethash (token-value lexer) *type-map*))
- (t
- nil)))
+ (and (eq (token-type lexer) :id)
+ (let ((id (token-value lexer)))
+ (or (gethash id *declspec-map*)
+ (gethash id *type-map*)))))
(defun parse-c-type (lexer)
"Parse declaration specifiers from LEXER and return a C-TYPE."
(let ((spec (make-declspec))
- (found-any nil))
- (loop
- (let ((tok (token-type lexer)))
- (labels ((update (func value)
- (let ((new (funcall func spec value)))
- (cond (new (setf spec new))
- (t (cerror*
- "Invalid declaration specifier ~(~A~) after `~{~A~^ ~}' (ignored)"
- (format-token tok (token-value lexer))
- (declspec-keywords spec t))
- nil))))
- (tagged (class)
- (let ((kind tok))
- (setf tok (next-token lexer))
- (if (eql tok :id)
- (when (update #'update-declspec-type
- (make-instance
- class
- :tag (token-value lexer)))
- (setf found-any t))
- (cerror* "Expected ~(~A~) tag; found ~A"
- kind (format-token lexer))))))
- (case tok
- ((:const :volatile :restrict)
- (update #'update-declspec-qualifiers tok))
- ((:signed :unsigned)
- (when (update #'update-declspec-sign tok)
- (setf found-any t)))
- ((:short :long)
- (when (update #'update-declspec-size tok)
- (setf found-any t)))
- ((:void :char :int :float :double)
- (when (update #'update-declspec-type tok)
- (setf found-any t)))
- (:enum (tagged 'c-enum-type))
- (:struct (tagged 'c-struct-type))
- (:union (tagged 'c-union-type))
- (:id
- (let ((ty (gethash (token-value lexer) *type-map*)))
- (when (or found-any (not ty))
- (return))
- (when (update #'update-declspec-type ty)
- (setf found-any t))))
- (t
- (return))))
- (setf tok (next-token lexer))))
- (unless found-any
- (cerror* "Missing type name (guessing at `int')"))
- (declspec-c-type spec)))
+ (found-any nil)
+ tok)
+ (flet ((token (&optional (ty (next-token lexer)))
+ (setf tok
+ (or (and (eq ty :id)
+ (gethash (token-value lexer) *declspec-map*))
+ ty)))
+ (update (func value)
+ (let ((new (funcall func spec value)))
+ (cond (new (setf spec new))
+ (t (cerror* "Invalid declaration specifier ~(~A~) ~
+ following `~{~A~^ ~}' (ignored)"
+ (format-token tok (token-value lexer))
+ (declspec-keywords spec t))
+ nil)))))
+ (token (token-type lexer))
+ (loop
+ (typecase tok
+ (decl-qualifier (update #'update-declspec-qualifiers tok))
+ (decl-sign (when (update #'update-declspec-sign tok)
+ (setf found-any t)))
+ (decl-size (when (update #'update-declspec-size tok)
+ (setf found-any t)))
+ (decl-type (when (update #'update-declspec-type tok)
+ (setf found-any t)))
+ (decl-tagged (let ((class (ecase tok
+ (:enum 'c-enum-type)
+ (:struct 'c-struct-type)
+ (:union 'c-union-type))))
+ (let ((tag (require-token lexer :id)))
+ (when tag
+ (update #'update-declspec-type
+ (make-instance class :tag tag))))))
+ ((eql :id) (let ((ty (gethash (token-value lexer) *type-map*)))
+ (when (or found-any (not ty))
+ (return))
+ (when (update #'update-declspec-type ty)
+ (setf found-any t))))
+ (t (return)))
+ (token))
+ (unless found-any
+ (cerror* "Missing type name (guessing at `int')"))
+ (declspec-c-type spec))))
;;;--------------------------------------------------------------------------
;;; Parsing declarators.
(with-input-from-string (in "
// int stat(struct stat *st)
// void foo(void)
-// int vsnprintf(size_t n, char *buf, va_list ap)
+ int vsnprintf(size_t n, char *buf, va_list ap)
// size_t size_t;
// int (*signal(int sig, int (*handler)(int s)))(int t)
")
(let* ((stream (make-instance 'position-aware-input-stream
:file "<string>"
:stream in))
- (lex (make-instance 'sod-lexer :stream stream
- :keywords *sod-keywords*)))
+ (lex (make-instance 'sod-lexer :stream stream)))
(next-char lex)
(next-token lex)
(let ((ty (parse-c-type lex)))
/*----- Header files ------------------------------------------------------*/
-#include <sod.h>
+#include "sod.h"
/*----- Main code ---------------------------------------------------------*/
* and we're done. Otherwise it isn't, and we lose. We also lose if no
* matching chain is found.
*/
- for (chain = sub->cls.chains, lim = chain + sub->cls.n_chains;
+ for (chain = sub->cls.chains, limit = chain + sub->cls.n_chains;
chain < limit; chain++) {
if (chain->classes[0] != head)
continue;
#include <stdarg.h>
#include <stddef.h>
-#include <sod-base.h>
+#include "sod-base.h"
/*----- Data structures ---------------------------------------------------*/
~mdw / sod / commitdiff