(defun find-superclass-by-nick (class nick)
"Returns the superclass of CLASS with nickname NICK, or signals an error."
- (or (find nick (sod-class-precedence-list class)
- :key #'sod-class-nickname
- :test #'string=)
- (error "No superclass of `~A' with nickname `~A'"
- (sod-class-name class) nick)))
+
+ ;; Slightly tricky. The class almost certainly hasn't been finalized, so
+ ;; trundle through its superclasses and hope for the best.
+ (if (string= nick (sod-class-nickname class))
+ class
+ (or (some (lambda (super)
+ (find nick (sod-class-precedence-list super)
+ :key #'sod-class-nickname
+ :test #'string=))
+ (sod-class-direct-superclasses class))
+ (error "No superclass of `~A' with nickname `~A'" class nick))))
(flet ((find-item-by-name (what class list name key)
(or (find name list :key key :test #'string=)
- (error "No ~A in class `~A' with name `~A'"
- what (sod-class-name class) name))))
+ (error "No ~A in class `~A' with name `~A'" what class name))))
(defun find-instance-slot-by-name (class super-nick slot-name)
(let ((super (find-superclass-by-nick class super-nick)))
((sod-subclass-p meta candidate) meta)
((sod-subclass-p candidate meta) candidate)
(t (error "Unable to choose metaclass for `~A'"
- (sod-class-name class)))))))
+ class))))))
((endp supers) meta)))
(defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
(the class's name, forced to lowercase) will be chosen in
FINALIZE-SOD-CLASS.
- * :CHAIN names the chained superclass. If unspecified, this class will
+ * :LINK names the chained superclass. If unspecified, this class will
be left at the head of its chain."
- (macrolet ((default-slot (slot value)
- `(unless (slot-boundp class ',slot)
- (setf (slot-value class ',slot) ,value))))
-
- ;; If no nickname, copy the class name. It won't be pretty, though.
- (default-slot nickname
- (get-property pset :nick :id (slot-value class 'name)))
+ ;; 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)))
- ;; If no metaclass, guess one in a (Lisp) class-specific way.
- (default-slot metaclass
- (multiple-value-bind (name floc) (get-property pset :metaclass :id)
- (if floc
- (find-sod-class name floc)
- (guess-metaclass class))))
+ ;; If no metaclass, guess one in a (Lisp) class-specific way.
+ (default-slot (class 'metaclass)
+ (multiple-value-bind (name floc) (get-property pset :metaclass :id)
+ (if floc
+ (find-sod-class name floc)
+ (guess-metaclass class))))
- ;; If no chained-superclass, then start a new chain here.
- (default-slot chained-superclass
- (multiple-value-bind (name floc) (get-property pset :chain :id)
- (if floc
- (find-sod-class name floc)
- nil)))))
+ ;; If no chain-link, then start a new chain here.
+ (default-slot (class 'chain-link)
+ (multiple-value-bind (name floc) (get-property pset :link :id)
+ (if floc
+ (find-sod-class name floc)
+ nil))))
;;;--------------------------------------------------------------------------
;;; Slot construction.
(defmethod make-sod-message
((class sod-class) name type pset &optional location)
(with-default-error-location (location)
- (let ((slot (make-instance (get-property pset :lisp-class :symbol
- 'sod-slot)
+ (let ((message (make-instance (get-property pset :lisp-class :symbol
+ 'standard-message)
:class class
:name name
:type type
:location (file-location location)
:pset pset)))
- (with-slots (slots) class
- (setf slots (append slots (list slot))))
+ (with-slots (messages) class
+ (setf messages (append messages (list message))))
(check-unused-properties pset))))
(defmethod check-message-type ((message sod-message) (type c-function-type))
This is a generic function so that it can be specialized according to both
a class and -- more particularly -- a message. The default method uses
- the :LISP-CLASS property (defaulting to calling CHOOSE-SOD-METHOD-CLASS)
+ the :LISP-CLASS property (defaulting to calling SOD-MESSAGE-METHOD-CLASS)
to choose a (CLOS) class to instantiate. The method is then constructed
by MAKE-INSTANCE passing the arguments as initargs; further behaviour is
left to the standard CLOS instance construction protocol; for example,
((method sod-method) (message sod-message) (type c-type))
(error "Methods must have function type, not ~A" type))
-(defun arguments-lists-compatible-p (message-args method-args)
+(defun argument-lists-compatible-p (message-args method-args)
"Compare argument lists for compatibility.
Return true if METHOD-ARGS is a suitable method argument list
(defmethod check-method-type
((method sod-method) (message sod-message) (type c-function-type))
-
- ;; Check compatibility.
(with-slots ((msgtype type)) message
- (unless (c-type-equal-p type msgtype)
- (error "Method type ~A doesn't match message type ~A" type msgtype)))
+ (unless (c-type-equal-p (c-type-subtype msgtype)
+ (c-type-subtype type))
+ (error "Method return type ~A doesn't match message ~A"
+ (c-type-subtype msgtype) (c-type-subtype type)))
+ (unless (argument-lists-compatible-p (c-function-arguments msgtype)
+ (c-function-arguments type))
+ (error "Method arguments ~A don't match message ~A" type msgtype))))
+
+(defmethod shared-initialize :after
+ ((method sod-method) slot-names &key pset)
+ (declare (ignore slot-names pset))
;; Check that the arguments are named if we have a method body.
- (with-slots (body) method
+ (with-slots (body type) method
(unless (or (not body)
(every #'argument-name (c-function-arguments type)))
- (error "Abstract declarators not permitted in method definitions"))))
+ (error "Abstract declarators not permitted in method definitions")))
-(defmethod shared-initialize :after
- ((method sod-method) slot-names &key pset)
- (declare (ignore slot-names pset))
+ ;; Check the method type.
(with-slots (message type) method
(check-method-type method message type)))
;;;--------------------------------------------------------------------------
;;; Bootstrapping the class graph.
+;;;
+;;; FIXME: This is a daft place for this function. It's also accumulating
+;;; all of the magic associated with initializing class instances.
+
+(defun output-imprint-function (class stream)
+ (let ((ilayout (sod-class-ilayout class)))
+ (format stream "~&~:
+static void *~A__imprint(void *p)
+{
+ struct ~A *sod__obj = p;
+
+ ~:{sod__obj.~A._vt = &~A;~:^~% ~}
+ return (p);
+}~2%"
+ class
+ (ilayout-struct-tag class)
+ (mapcar (lambda (ichain)
+ (list (sod-class-nickname (ichain-head ichain))
+ (vtable-name class (ichain-head ichain))))
+ (ilayout-ichains ilayout)))))
+
+(defun output-init-function (class stream)
+ ;; FIXME this needs a metaobject protocol
+ (let ((ilayout (sod-class-ilayout class)))
+ (format stream "~&~:
+static void *~A__init(void *p)
+{
+ struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
+ class
+ (ilayout-struct-tag class))
+ (dolist (ichain (ilayout-ichains ilayout))
+ (let ((ich (format nil "sod__obj.~A"
+ (sod-class-nickname (ichain-head ichain)))))
+ (dolist (item (ichain-body ichain))
+ (etypecase item
+ (vtable-pointer
+ (format stream " ~A._vt = &~A;~%"
+ ich (vtable-name class (ichain-head ichain))))
+ (islots
+ (let ((isl (format nil "~A.~A"
+ ich
+ (sod-class-nickname (islots-class item)))))
+ (dolist (slot (islots-slots item))
+ (let ((dslot (effective-slot-direct-slot slot))
+ (init (effective-slot-initializer slot)))
+ (when init
+ (ecase (sod-initializer-value-kind init)
+ (:single
+ (format stream " ~A = ~A;~%"
+ isl (sod-initializer-value-form slot)))
+ (:compound
+ (format stream " ~A = (~A)~A;~%"
+ isl (sod-slot-type dslot)
+ (sod-initializer-value-form slot)))))))))))))
+ (format stream "~&~:
+ return (p);
+}~2%")))
+
+(defun output-supers-vector (class stream)
+ (let ((supers (sod-class-direct-superclasses class)))
+ (when supers
+ (format stream "~&~:
+static const SodClass *const ~A__supers[] = {
+ ~{~A__class~^,~% ~}
+};~2%"
+ class supers))))
+
+(defun output-cpl-vector (class stream)
+ (format stream "~&~:
+static const SodClass *const ~A__cpl[] = {
+ ~{~A__class~^,~% ~}
+};~2%"
+ class (sod-class-precedence-list class)))
+
+(defun output-chains-vector (class stream)
+ (let ((chains (sod-class-chains class)))
+ (format stream "~&~:
+~1@*~:{static const SodClass *const ~A__chain_~A[] = {
+~{ ~A__class~^,~%~}
+};~:^~2%~}
+
+~0@*static const struct sod_chain ~A__chains[] = {
+~:{ { ~3@*~A,
+ ~0@*&~A__chain_~A,
+ ~4@*offsetof(struct ~A, ~A),
+ (const struct sod_vtable *)&~A,
+ sizeof(struct ~A) }~:^,~%~}
+};~2%"
+ class ;0
+ (mapcar (lambda (chain) ;1
+ (let* ((head (sod-class-chain-head (car chain)))
+ (chain-nick (sod-class-nickname head)))
+ (list class chain-nick ;0 1
+ (reverse chain) ;2
+ (length chain) ;3
+ (ilayout-struct-tag class) chain-nick ;4 5
+ (vtable-name class head) ;6
+ (ichain-struct-tag class head)))) ;7
+ chains))))
+
+(defparameter *sod-class-slots*
+ `(
+
+ ;; Basic informtion.
+ ("name" ,(c-type const-string)
+ :initializer-function
+ ,(lambda (class)
+ (prin1-to-string (sod-class-name class))))
+ ("nick" ,(c-type const-string)
+ :initializer-function
+ ,(lambda (class)
+ (prin1-to-string (sod-class-nickname class))))
+
+ ;; Instance allocation and initialization.
+ ("instsz" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (format nil "sizeof(struct ~A)"
+ (ilayout-struct-tag class))))
+ ("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)))))
+ :prepare-function 'output-init-function
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__init" class)))
+
+ ;; Superclass structure.
+ ("n_supers" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (length (sod-class-direct-superclasses class))))
+ ("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
+ :prepare-function 'output-supers-vector
+ :initializer-function
+ ,(lambda (class)
+ (if (sod-class-direct-superclasses class)
+ (format nil "~A__supers" class)
+ 0)))
+ ("n_cpl" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (length (sod-class-precedence-list class))))
+ ("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
+ :prepare-function 'output-cpl-vector
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__cpl" class)))
+
+ ;; Chain structure.
+ ("link" ,(c-type (* (class "SodClass" :const)))
+ :initializer-function
+ ,(lambda (class)
+ (let ((link (sod-class-chain-link class)))
+ (if link
+ (format nil "~A__class" link)
+ 0))))
+ ("head" ,(c-type (* (class "SodClass" :const)))
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__class" (sod-class-chain-head class))))
+ ("level" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (position class (reverse (sod-class-chain class)))))
+ ("n_chains" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (length (sod-class-chains class))))
+ ("chains" ,(c-type (* (struct "sod_chain" :const)))
+ :prepare-function 'output-chains-vector
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__chains" class)))
+
+ ;; Class-specific layout.
+ ("off_islots" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (format nil "offsetof(struct ~A, ~A)"
+ (ichain-struct-tag class
+ (sod-class-chain-head class))
+ (sod-class-nickname class))))
+ ("islotsz" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (format nil "sizeof(struct ~A)"
+ (islots-struct-tag class))))))
+
+(defclass sod-class-slot (sod-slot)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader sod-slot-initializer-function)
+ (prepare-function :initarg :prepare-function
+ :type (or symbol function)
+ :reader sod-slot-prepare-function))
+ (:documentation
+ "Special class for slots defined on sod_object.
+
+ These slots need class-specific initialization. It's easier to keep all
+ of the information (name, type, and how to initialize them) about these
+ slots in one place, so that's what we do here."))
+
+(defmethod shared-initialize :after
+ ((slot sod-class-slot) slot-names &key pset)
+ (declare (ignore slot-names))
+ (default-slot (slot 'initializer-function)
+ (get-property pset :initializer-function t nil))
+ (default-slot (slot 'prepare-function)
+ (get-property pset :prepare-function t nil)))
+
+(defclass sod-class-effective-slot (effective-slot)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader effective-slot-initializer-function)
+ (prepare-function :initarg :prepare-function
+ :type (or symbol function)
+ :reader effective-slot-prepare-function))
+ (:documentation
+ "Special class for slots defined on slot_object.
+
+ This class ignores any explicit initializers and computes initializer
+ values using the slot's INIT-FUNC slot and a magical protocol during
+ metaclass instance construction."))
+
+(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
+ (make-instance 'sod-class-effective-slot
+ :slot slot
+ :initializer-function (sod-slot-initializer-function slot)
+ :prepare-function (sod-slot-prepare-function slot)
+ :initializer (find-slot-initializer class slot)))
(defun bootstrap-classes ()
- (let* ((sod-object (make-sod-class "sod_object" nil
+ (let* ((sod-object (make-sod-class "SodObject" nil
(make-property-set :nick 'obj)))
- (sod-class (make-sod-class "sod_class" (list sod-object)
+ (sod-class (make-sod-class "SodClass" (list sod-object)
(make-property-set :nick 'cls)))
(classes (list sod-object sod-class)))
- (setf (slot-value sod-class 'chained-superclass) sod-object)
+
+ ;; Sort out the recursion.
+ (setf (slot-value sod-class 'chain-link) sod-object)
(dolist (class classes)
(setf (slot-value class 'metaclass) sod-class))
+
+ ;; Predeclare the class types.
+ (dolist (class classes)
+ (make-class-type (sod-class-name class)))
+
+ ;; Attach the class slots.
+ (loop for (name type . plist) in *sod-class-slots*
+ do (make-sod-slot sod-class name type
+ (apply #'make-property-set
+ :lisp-class 'sod-class-slot
+ plist)))
+
+ ;; These classes are too closely intertwined. We must partially finalize
+ ;; them together by hand. This is cloned from FINALIZE-SOD-CLASS.
+ (dolist (class classes)
+ (with-slots (class-precedence-list chain-head chain chains) class
+ (setf class-precedence-list (compute-cpl class))
+ (setf (values chain-head chain chains) (compute-chains class))))
+
+ ;; Done.
(dolist (class classes)
(finalize-sod-class class)
(record-sod-class class))))
-#|
- (defmacro define-sod-class (name superclasses &body body-and-options)
- "FIXME. This probably needs the docstring from hell."
-
- (let ((class-var (gensym "CLASS"))
- (slots-var (gensym "SLOTS"))
- (inst-inits-var (gensym "INST-INITS"))
- (class-inits-var (gensym "CLASS-INITS"))
- (messages-var (gensym "MESSAGES"))
- (methods-var (gensym "METHODS")))
-|#
+;;;--------------------------------------------------------------------------
+;;; Builder macro.
+
+(defmacro define-sod-class (name (&rest superclasses) &body body)
+ (let ((plist nil)
+ (classvar (gensym "CLASS")))
+ (loop
+ (when (or (null body)
+ (not (keywordp (car body))))
+ (return))
+ (push (pop body) plist)
+ (push (pop body) plist))
+ `(let ((,classvar (make-sod-class ,name
+ (mapcar #'find-sod-class
+ (list ,@superclasses))
+ (make-property-set
+ ,@(nreverse plist)))))
+ (macrolet ((message (name type &rest plist)
+ `(make-sod-message ,',classvar ,name (c-type ,type)
+ (make-property-set ,@plist)))
+ (method (nick name type body &rest plist)
+ `(make-sod-method ,',classvar ,nick ,name (c-type ,type)
+ ,body (make-property-set ,@plist)))
+ (slot (name type &rest plist)
+ `(make-sod-slot ,',classvar ,name (c-type ,type)
+ (make-property-set ,@plist)))
+ (instance-initializer
+ (nick name value-kind value-form &rest plist)
+ `(make-sod-instance-initializer ,',classvar ,nick ,name
+ ,value-kind ,value-form
+ (make-property-set
+ ,@plist)))
+ (class-initializer
+ (nick name value-kind value-form &rest plist)
+ `(make-sod-class-initializer ,',classvar ,nick ,name
+ ,value-kind ,value-form
+ (make-property-set
+ ,@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))
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff