(defun output-imprint-function (class stream)
(let ((ilayout (sod-class-ilayout class)))
(format stream "~&~:
+/* Imprint raw memory with instance structure. */
static void *~A__imprint(void *p)
{
struct ~A *sod__obj = p;
- ~:{sod__obj.~A._vt = &~A;~:^~% ~}
+ ~:{sod__obj.~A.~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))))
+ (let* ((head (ichain-head ichain))
+ (tail (ichain-tail ichain)))
+ (list (sod-class-nickname head)
+ (sod-class-nickname tail)
+ (vtable-name class head))))
(ilayout-ichains ilayout)))))
(defun output-init-function (class stream)
class
(ilayout-struct-tag class))
(dolist (ichain (ilayout-ichains ilayout))
- (let ((ich (format nil "sod__obj.~A"
- (sod-class-nickname (ichain-head ichain)))))
+ (let ((ich (format nil "sod__obj.~A.~A"
+ (sod-class-nickname (ichain-head ichain))
+ (sod-class-nickname (ichain-tail ichain)))))
(dolist (item (ichain-body ichain))
(etypecase item
(vtable-pointer
(ecase (sod-initializer-value-kind init)
(:single
(format stream " ~A = ~A;~%"
- isl (sod-initializer-value-form slot)))
+ isl (sod-initializer-value-form init)))
(:compound
(format stream " ~A = (~A)~A;~%"
isl (sod-slot-type dslot)
- (sod-initializer-value-form slot)))))))))))))
+ (sod-initializer-value-form init)))))))))))))
(format stream "~&~:
return (p);
}~2%")))
(let ((supers (sod-class-direct-superclasses class)))
(when supers
(format stream "~&~:
+/* Direct superclasses. */
static const SodClass *const ~A__supers[] = {
~{~A__class~^,~% ~}
};~2%"
(defun output-cpl-vector (class stream)
(format stream "~&~:
+/* Class precedence list. */
static const SodClass *const ~A__cpl[] = {
~{~A__class~^,~% ~}
};~2%"
(defun output-chains-vector (class stream)
(let ((chains (sod-class-chains class)))
(format stream "~&~:
+/* Chain structure. */
~1@*~:{static const SodClass *const ~A__chain_~A[] = {
-~{ ~A__class~^,~%~}
+ ~{~A__class~^,~% ~}
};~:^~2%~}
~0@*static const struct sod_chain ~A__chains[] = {
of the information (name, type, and how to initialize them) about these
slots in one place, so that's what we do here."))
+(defclass sod-magic-class-initializer (sod-class-initializer)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader sod-initializer-function)
+ (prepare-function :initarg :prepare-function
+ :type (or symbol function)
+ :reader sod-initializer-prepare-function)))
+
(defmethod shared-initialize :after
((slot sod-class-slot) slot-names &key pset)
(declare (ignore slot-names))
(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
(make-instance 'sod-class-effective-slot
- :slot slot
+ :class class :slot slot
:initializer-function (sod-slot-initializer-function slot)
:prepare-function (sod-slot-prepare-function slot)
:initializer (find-slot-initializer class slot)))
(format nil "sizeof(struct ~A)"
(ilayout-struct-tag class))))
("imprint" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
- :prepare-function 'output-imprint-function
+ :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
+ :prepare-function output-init-function
:initializer-function
,(lambda (class)
(format nil "~A__init" class)))
,(lambda (class)
(length (sod-class-direct-superclasses class))))
("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
- :prepare-function 'output-supers-vector
+ :prepare-function output-supers-vector
:initializer-function
,(lambda (class)
(if (sod-class-direct-superclasses class)
,(lambda (class)
(length (sod-class-precedence-list class))))
("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
- :prepare-function 'output-cpl-vector
+ :prepare-function output-cpl-vector
:initializer-function
,(lambda (class)
(format nil "~A__cpl" class)))
,(lambda (class)
(length (sod-class-chains class))))
("chains" ,(c-type (* (struct "sod_chain" :const)))
- :prepare-function 'output-chains-vector
+ :prepare-function output-chains-vector
:initializer-function
,(lambda (class)
(format nil "~A__chains" class)))
((slot :initarg :slot :type sod-slot :reader sod-initializer-slot)
(location :initarg :location :initform (file-location nil)
:type file-location :reader file-location)
- (class :initarg :class :type sod-class :reader sod-initializer-clas)
+ (class :initarg :class :type sod-class :reader sod-initializer-class)
(value-kind :initarg :value-kind :type keyword
:reader sod-initializer-value-kind)
(value-form :initarg :value-form :type c-fragment
(sequence-output (stream sequencer)
:constraint
- (:typedefs)
-
- :constraint
((:classes :start)
(class :banner)
(class :islots :start) (class :islots :slots) (class :islots :end)
(let ((metaclass (sod-class-metaclass class))
(metaroot (find-root-metaclass class)))
(format stream "/* The class object. */~%~
- extern struct ~A ~A__classobj;~%~
+ 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))
(format stream " const struct ~A *_vt;~%"
(vtable-struct-tag chain-tail chain-head))))))
+(defmethod add-output-hooks progn ((islots islots) reason sequencer)
+ (dolist (slot (islots-slots islots))
+ (add-output-hooks slot reason sequencer)))
+
(defmethod add-output-hooks progn
((islots islots) (reason (eql :h)) sequencer)
(with-slots (class subclass slots) islots
(sod-class-nickname target-head))))))
;;;--------------------------------------------------------------------------
+;;; Implementation output.
+
+(defvar *instance-class*)
+
+(defmethod add-output-hooks progn
+ ((class sod-class) (reason (eql :c)) sequencer)
+ (sequence-output (stream sequencer)
+
+ :constraint
+ ((:classes :start)
+ (class :banner)
+ (class :direct-methods :start) (class :direct-methods :end)
+ (class :effective-methods :start) (class :effective-methods :end)
+ (class :vtables :start) (class :vtables :end)
+ (class :object :prepare) (class :object :start) (class :object :end)
+ (:classes :end))
+
+ ((class :banner)
+ (banner (format nil "Class ~A" class) stream))
+
+ ((class :object :start)
+ (format stream "~
+/* The class object. */
+const struct ~A ~A__classobj = {~%"
+ (ilayout-struct-tag (sod-class-metaclass class))
+ class))
+ ((class :object :end)
+ (format stream "};~2%")))
+
+ (let ((*instance-class* class))
+ (add-output-hooks (sod-class-ilayout (sod-class-metaclass class))
+ 'populate-class
+ sequencer)))
+
+;;;--------------------------------------------------------------------------
+;;; 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
+ (unless body
+ (return-from add-output-hooks))
+ (sequence-output (stream sequencer)
+ ((class :direct-method method :start)
+ (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
+ (mapcar #'argument-name
+ (c-function-arguments (sod-method-next-method-type
+ method)))))
+ ((class :direct-method method :end)
+ (format stream "#undef CALL_NEXT_METHOD~%")))))
+
+(defmethod add-output-hooks progn
+ ((method sod-method) (reason (eql :c)) sequencer)
+ (with-slots (class body) method
+ (unless body
+ (return-from add-output-hooks))
+ (sequence-output (stream sequencer)
+ :constraint ((class :direct-methods :start)
+ (class :direct-method method :start)
+ (class :direct-method method :body)
+ (class :direct-method method :end)
+ (class :direct-methods :end))
+ ((class :direct-method method :body)
+ (pprint-c-type (sod-method-function-type method)
+ stream
+ (sod-method-function-name method))
+ (format stream "~&{~%")
+ (write body :stream stream :pretty nil :escape nil)
+ (format stream "~&}~%"))
+ ((class :direct-method method :end)
+ (terpri stream)))))
+
+;;;--------------------------------------------------------------------------
+;;; Filling in the class object.
+
+(defmethod add-output-hooks progn
+ ((ichain ichain) (reason (eql 'populate-class)) sequencer)
+ (with-slots (class chain-head) ichain
+ (sequence-output (stream sequencer)
+ :constraint ((*instance-class* :object :start)
+ (*instance-class* :object chain-head :ichain :start)
+ (*instance-class* :object chain-head :ichain :end)
+ (*instance-class* :object :end))
+ ((*instance-class* :object chain-head :ichain :start)
+ (format stream " { { /* ~A ichain */~%"
+ (sod-class-nickname chain-head)))
+ ((*instance-class* :object chain-head :ichain :end)
+ (format stream " } },~%")))))
+
+(defmethod add-output-hooks progn
+ ((islots islots) (reason (eql 'populate-class)) sequencer)
+ (with-slots (class) islots
+ (let ((chain-head (sod-class-chain-head class)))
+ (sequence-output (stream sequencer)
+ :constraint ((*instance-class* :object chain-head :ichain :start)
+ (*instance-class* :object class :slots :start)
+ (*instance-class* :object class :slots)
+ (*instance-class* :object class :slots :end)
+ (*instance-class* :object chain-head :ichain :end))
+ ((*instance-class* :object class :slots :start)
+ (format stream " { /* Class ~A */~%" class))
+ ((*instance-class* :object class :slots :end)
+ (format stream " },~%"))))))
+
+(defmethod add-output-hooks progn
+ ((vtptr vtable-pointer) (reason (eql 'populate-class)) sequencer)
+ (with-slots (class chain-head chain-tail) vtptr
+ (sequence-output (stream sequencer)
+ :constraint ((*instance-class* :object chain-head :ichain :start)
+ (*instance-class* :object chain-head :vtable)
+ (*instance-class* :object chain-head :ichain :end))
+ ((*instance-class* :object chain-head :vtable)
+ (format stream " &~A__vtable_~A,~%"
+ class (sod-class-nickname chain-head))))))
+
+(defgeneric find-class-initializer (slot class)
+ (:method ((slot effective-slot) (class sod-class))
+ (let ((dslot (effective-slot-direct-slot slot)))
+ (or (some (lambda (super)
+ (find dslot (sod-class-class-initializers super)
+ :test #'sod-initializer-slot))
+ (sod-class-precedence-list class))
+ (effective-slot-initializer slot)))))
+
+(defgeneric output-class-initializer (slot instance stream)
+ (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
+ (let ((func (effective-slot-initializer-function slot)))
+ (if func
+ (format stream " ~A,~%" (funcall func instance))
+ (call-next-method))))
+ (:method ((slot effective-slot) (instance sod-class) stream)
+ (let ((init (find-class-initializer slot instance)))
+ (ecase (sod-initializer-value-kind init)
+ (:simple (format stream " ~A,~%"
+ (sod-initializer-value-form init)))
+ (:compound (format stream " ~@<{ ~;~A~; },~:>~%"
+ (sod-initializer-value-form init)))))))
+
+(defmethod add-output-hooks progn ((slot sod-class-effective-slot)
+ (reason (eql 'populate-class))
+ sequencer)
+ (let ((instance *instance-class*)
+ (func (effective-slot-prepare-function slot)))
+ (when func
+ (sequence-output (stream sequencer)
+ ((instance :object :prepare)
+ (funcall func instance stream))))))
+
+(defmethod add-output-hooks progn
+ ((slot effective-slot) (reason (eql 'populate-class)) sequencer)
+ (with-slots (class (dslot slot)) slot
+ (let ((instance *instance-class*)
+ (super (sod-slot-class dslot)))
+ (sequence-output (stream sequencer)
+ ((instance :object super :slots)
+ (output-class-initializer slot instance stream))))))
+
+;;;--------------------------------------------------------------------------
;;; Testing.
#+test
:nick 'lion
:link '|Animal|
(message "bite" (fun void))
- (method "lion" "bite" (fun void) nil)
+ (method "lion" "bite" (fun void) #{
+ puts("Munch!");
+ })
(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 "goat" "butt" (fun void) #{
+ puts("Whack!");
+ })
(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)
+ (method "serpent" "bite" (fun void) #{
+ puts("Nom!");
+ })
(message "hiss" (fun void))
- (method "serpent" "hiss" (fun void) nil)
+ (method "serpent" "hiss" (fun void) #{
+ puts("Ssss!");
+ })
(method "nml" "tickle" (fun void) #{
if (me->tickles < 3) me->_vt->hiss(me);
else me->_vt->bite(me);
(sod-message-name
(effective-method-message method)))
:test #'string=))))
-
;; Something else. Eat it and continue.
(t (getch)))))
- ;; Return the fragment we've collected.
- (make-instance 'c-fragment
- :location start-floc
- :text (get-output-stream-string output)))))
+ (let* ((string (get-output-stream-string output))
+ (end (position-if (lambda (char)
+ (or (char= char #\newline)
+ (not (whitespace-char-p char))))
+ string
+ :from-end t))
+ (trimmed (if end
+ (subseq string 0 (1+ end))
+ "")))
+
+ ;; Return the fragment we've collected.
+ (make-instance 'c-fragment
+ :location start-floc
+ :text trimmed)))))
(defun c-fragment-reader (stream char arg)
"Reader for C-fragment syntax #{ ... stuff ... }."
((:includes :end)
(terpri stream))))
+;;;--------------------------------------------------------------------------
+;;; Source output.
+
+(defmethod add-output-hooks progn
+ ((module module) (reason (eql :c)) sequencer)
+ (sequence-output (stream sequencer)
+ :constraint (:prologue
+ (:includes :start) :includes (:includes :end)
+ (:classes :start) (:classes :end)
+ :epilogue)
+
+ (:prologue
+ (format stream "~
+/* -*-c-*-
+ *
+ * Implementation file generated by SOD for ~A
+ */~2%"
+ (namestring (module-name module))))
+
+ (:epilogue
+ (banner "That's all, folks" stream :blank-line-p nil))
+
+ ((:includes :start)
+ (banner "External header files" stream))
+ ((:includes :end)
+ (terpri stream))))
+
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+%%% -*-latex-*-
+%%%
+%%% Background philosophy
+%%%
+%%% (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.
+
+\chapter{Philosophical background}
+
+%%%--------------------------------------------------------------------------
+\section{Superclass linearization}
+
+Before making any decisions about relationships between superclasses, Sod
+\emph{linearizes} them, i.e., imposes a total order consistent with the
+direct-subclass/superclass partial order.
+
+In the vague hope that we don't be completely bogged down in formalism by the
+end of this, let's introduce some notation. We'll fix some class $z$ and
+consider its set of superclasses $S(z) = \{ a, b, \dots \}$. We can define a
+relation $c \prec_1 d$ if $c$ is a direct subclass of $d$, and extend it by
+taking the reflexive, transitive closure: $c \preceq d$ if and only if
+\begin{itemize}
+\item $c = d$, or
+\item there exists some class $x$ such that $c \prec_1 x$ and $x \preceq d$.
+\end{itemize}
+This is the `is-subclass-of' relation we've been using so far.\footnote{%
+ In some object systems, notably Flavors, this relation is allowed to fail
+ to be a partial order because of cycles in the class graph. I haven't
+ given a great deal of thought to how well Sod would cope with a cyclic
+ class graph.} %
+
+The problem comes when we try to resolve inheritance questions. A class
+should inherit behaviour from its superclasses; but, in a world of multiple
+inheritance, which one do we choose? We get a simple version of this problem
+when we try to resolve inheritance of slot initializers: only one initializer
+can be inherited.
+
+We start by collecting into a set~$I$ the classes which define an initializer
+for the slot. If $I$ contains both a class $x$ and one of $x$'s superclasses
+then we should prefer $x$ and consider the superclass to be overridden. So
+we should confine our attention to \emph{least} classes: a member $x$ of a
+set $I$ is least, with respect to a particular partial order, if $y \preceq
+x$ only when $x = y$. If there is a single least class in our set the we
+have a winner. Otherwise we want some way to choose among them.
+
+This is not uncontroversial. Languages such as \Cplusplus\ refuse to choose
+among least classes; instead, any program in which such a choice must be made
+is simply declared erroneous.
+
+Simply throwing up our hands in horror at this situation is satisfactory when
+we only wanted to pick one `winner', as we do for slot initializers.
+However, method combination is a much more complicated business. We don't
+want to pick just one winner: we want to order all of the applicable methods
+in some way. Insisting that there is a clear winner at every step along the
+chain is too much of an imposition. Instead, we \emph{linearize} the
+classes.
+
+%%%--------------------------------------------------------------------------
+\section{Invariance, covariance, contravariance}
+
+In Sod, at least with regard to the existing method combinations, method
+types are \emph{invariant}. This is not an accident, and it's not due to
+ignorance.
+
+The \emph{signature} of a function, method or message describes its argument
+and return-value types. If a method's arguments are an integer and a string,
+and it returns a character, we might write its signature as
+\[ (@|int|, @|string|) \to @|char| \]
+In Sod, a method's arguments have to match its message's arguments precisely,
+and the return type must either be @|void| -- for a dæmon method -- or again
+match the message's return type. This is argument and return-type
+\emph{invariance}.
+
+Some object systems allow methods with subtly different signatures to be
+defined on a single message. In particular, since the idea is that instances
+of a subclass ought to be broadly compatible~(see \xref{sec:phil.lsp}) with
+existing code which expects instances of a superclass, we might be able to
+get away with bending method signatures one way or another to permit this.
+
+\Cplusplus\ permits \emph{return-type covariance}, where a method's return
+type can be a subclass of the return type specified by a less-specific
+method. Eiffel allows \emph{argument covariance}, where a method's arguments
+can be subclasses of the arguments specified by a less-specific
+method.\footnote{%
+ Attentive readers will note that I ought to be talking about pointers to
+ instances throughout. I'm trying to limit the weight of the notation.
+ Besides, I prefer data models as found in Lisp and Python where all values
+ are held by reference.} %
+
+Eiffel's argument covariance is unsafe.\footnote{%
+ Argument covariance is correct if you're doing runtime dispatch based on
+ argument types. Eiffel isn't: it's single dispatch, like Sod is.} %
+Suppose that we have two pairs of classes, $a \prec_1 b$ and $c \prec_1 d$.
+Class $b$ defines a message $m$ with signature $d \to @|int|$; class $a$
+defines a method with signature $c \to @|int|$. This means that it's wrong
+to send $m$ to an instance $a$ carrying an argument of type $d$. But of
+course, we can treat an instance of $a$ as if it's an instance of $b$,
+whereupon it appears that we are permitted to pass a~$c$ in our message. The
+result is a well-known hole in the type system. Oops.
+
+\Cplusplus's return-type covariance is fine. Also fine is argument
+\emph{contravariance}. If $b$ defined its message to have signature $c \to
+@|int|$, and $a$ were to broaden its method to $d \to @|int|$, there'd be no
+problem. All $c$s are $d$s, so viewing an $a$ as a $b$ does no harm.
+
+All of this fiddling with types is fine as long as method inheritance or
+overriding is an all-or-nothing thing. But Sod has method combinations,
+where applicable methods are taken from the instance's class and all its
+superclasses and combined. And this makes everything very messy.
+
+It's possible to sort all of the mess out in the generated effective method
+-- we'd just have to convert the arguments to the types that were expected by
+the direct methods. This would require expensive run-time conversions of all
+of the non-invariant arguments and return values. And we'd need some
+complicated rule so that we could choose sensible types for the method
+entries in our vtables. Something like this:
+\begin{quote} \itshape
+ For each named argument of a message, there must be a unique greatest type
+ among the types given for that argument by the applicable methods; and
+ there must be a unique least type among all of the return types of the
+ applicable methods.
+\end{quote}
+I have visions of people wanting to write special no-effect methods whose
+only purpose is to guide the translator around the class graph properly.
+Let's not.
+
+%% things to talk about:
+%% Liskov substitution principle and why it's mad
+
+%%%----- That's all, folks --------------------------------------------------
+
+%%% Local variables:
+%%% mode: LaTeX
+%%% TeX-master: "sod.tex"
+%%% TeX-PDF-mode: t
+%%% End:
\subsection{Chains and instance layout}
-
+\include{sod-backg}
\end{document}
\f
~mdw / sod / commitdiff