Most parts are in place. Much rearrangement is needed.
*~
*.fasl
+*.pdf
+*.out
+*.log
+*.dvi
+*.aux
;; Important protocol.
-(defgeneric c-declaration (type decl)
- (:documentation
- "Computes a declaration for a C type.
-
- Returns two strings, a type and a declarator, suitable for declaring an
- object with the inner declarator DECL."))
-
(defgeneric c-type-subtype (type)
(:documentation
"For compound types, return the base type."))
(:method and (type-a type-b)
(eql (class-of type-a) (class-of type-b))))
-(defgeneric c-declarator-priority (type)
+(defgeneric pprint-c-type (type stream kernel)
(:documentation
- "Returns the priority for the declarator of TYPE.
-
- Used to decide when to insert parentheses into the C representation.")
-
- (:method ((type c-type))
- 0))
+ "Pretty-printer for C types.
+
+ Print TYPE to STREAM. In the middle of the declarator, call the function
+ KERNEL with one argument: whether it needs a leading space.")
+ (:method :around (type stream kernel)
+ (typecase kernel
+ (function (call-next-method))
+ (null (pprint-c-type type stream
+ (lambda (stream prio spacep)
+ (declare (ignore stream prio spacep))
+ nil)))
+ (t (pprint-c-type type stream
+ (lambda (stream prio spacep)
+ (declare (ignore prio))
+ (when spacep
+ (c-type-space stream))
+ (princ kernel stream)))))))
(defgeneric print-c-type (stream type &optional colon atsign)
(:documentation
(defmethod print-object ((object c-type) stream)
(if *print-escape*
(format stream "~:@<C-TYPE ~/sod::print-c-type/~:>" object)
- (multiple-value-bind (base decl) (c-declaration object "")
- (format stream "~A~:[~; ~A~]" base (plusp (length decl)) decl))))
+ (pprint-c-type object stream nil)))
-;; Utility functions.
+;; Utility functions and macros.
-(defun maybe-parenthesize (decl me him)
- "Wrap parens around DECL, maybe, according to priorities of ME and HIM.
+(defun c-type-space (stream)
+ "Print a space and a miser-mode newline to STREAM.
- If the declarator for HIM has a higher priority than that of ME (as C
- types) then return DECL with parens wrapped around it; otherwise just
- return DECL."
- (if (<= (c-declarator-priority him)
- (c-declarator-priority me))
- decl
- (format nil "(~A)" decl)))
+ This is the right function to call in a PPRINT-C-TYPE kernel function when
+ the SPACEP argument is true."
+ (pprint-indent :block 2 stream)
+ (write-char #\space stream)
+ (pprint-newline :miser stream))
-(defun compound-type-declaration (type format-control &rest format-args)
- "Convenience function for implementating compound types.
+(defun maybe-in-parens* (stream condition thunk)
+ "Helper function for the MAYBE-IN-PARENS macro."
+ (pprint-logical-block
+ (stream nil
+ :prefix (if condition "(" "")
+ :suffix (if condition ")" ""))
+ (funcall thunk stream)))
- The declaration is formed from the type's subtype and by processing the
- given format string."
- (let ((subty (c-type-subtype type))
- (subdecl (format nil "~?" format-control format-args)))
- (c-declaration subty (maybe-parenthesize subdecl type subty))))
+(defmacro maybe-in-parens ((stream condition) &body body)
+ "Evaluate BODY; if CONDITION, write parens to STREAM around it.
+
+ This macro is useful for implementing the PPRINT-C-TYPE method on compound
+ types. The BODY is evaluated in the context of a logical block printing
+ to STREAM. If CONDITION is non-nil, then the block will have open/close
+ parens as its prefix and suffix; otherwise they will be empty.
+
+ The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol."
+ `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body)))
;; S-expression syntax machinery.
(error "Bad character in C name ~S." name))))))
(t name)))
-(defun expand-c-type (spec)
- "Parse SPEC as a C type and return the result.
-
- The SPEC can be one of the following.
-
- * A C-TYPE object, which is returned immediately.
-
- * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
- function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
- or some other means is invoked on the ARGUMENTS, and the result is
- returned.
-
- * A symbol, which is treated the same way as a singleton list would be."
-
- (flet ((interp (sym)
- (or (get sym 'c-type)
- (error "Unknown C type operator ~S." sym))))
- (etypecase spec
- (c-type spec)
- (symbol (funcall (interp spec)))
- (list (apply (interp (car spec)) (cdr spec))))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defgeneric expand-c-type-spec (spec)
+ (:documentation
+ "Expand SPEC into Lisp code to construct a C type.")
+ (:method ((spec list))
+ (expand-c-type-form (car spec) (cdr spec))))
+ (defgeneric expand-c-type-form (head tail)
+ (:documentation
+ "Expand a C type list beginning with HEAD.")
+ (:method ((name (eql 'lisp)) tail)
+ `(progn ,@tail))))
(defmacro c-type (spec)
- "Evaluates to the type that EXPAND-C-TYPE would return.
-
- Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime. Maybe
- later it will do something more clever."
- `(expand-c-type ',spec))
+ "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC."
+ (expand-c-type-spec spec))
(defmacro define-c-type-syntax (name bvl &rest body)
"Define a C-type syntax function.
A function defined by BODY and with lambda-list BVL is associated with the
NAME. When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this
function with the argument list STUFF."
- `(progn
- (setf (get ',name 'c-type) (lambda ,bvl ,@body))
- ',name))
+ (let ((headvar (gensym "HEAD"))
+ (tailvar (gensym "TAIL")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmethod expand-c-type-form ((,headvar (eql ',name)) ,tailvar)
+ (destructuring-bind ,bvl ,tailvar
+ ,@body)))))
(defmacro c-type-alias (original &rest aliases)
"Make ALIASES behave the same way as the ORIGINAL type."
- (let ((i (gensym)) (orig (gensym)))
- `(let ((,orig (get ',original 'c-type)))
- (dolist (,i ',aliases)
- (setf (get ,i 'c-type) ,orig)))))
+ (let ((headvar (gensym "HEAD"))
+ (tailvar (gensym "TAIL")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@(mapcar (lambda (alias)
+ `(defmethod expand-c-type-form
+ ((,headvar (eql ',alias)) ,tailvar)
+ (expand-c-type-form ',original ,tailvar)))
+ aliases))))
(defmacro defctype (names value)
"Define NAMES all to describe the C-type VALUE.
NAMES can be a symbol (treated as a singleton list), or a list of symbols.
The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE. It will
be expanded once at run-time."
- (unless (listp names)
- (setf names (list names)))
- (let ((ty (gensym)))
- `(let ((,ty (expand-c-type ',value)))
- (setf (get ',(car names) 'c-type) (lambda () ,ty))
- ,@(and (cdr names)
- `((c-type-alias ,(car names) ,@(cdr names)))))))
+ (let* ((names (if (listp names) names (list names)))
+ (namevar (gensym "NAME"))
+ (typevar (symbolicate 'c-type- (car names))))
+ `(progn
+ (defparameter ,typevar ,(expand-c-type-spec value))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@(mapcar (lambda (name)
+ `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
+ ',typevar))
+ names)))))
;;;--------------------------------------------------------------------------
;;; Types which can accept qualifiers.
(sort (copy-list (c-type-qualifiers type)) #'string<)))
(equal (fix type-a) (fix type-b))))
-(defmethod print-c-type :around
- (stream (type qualifiable-c-type) &optional colon atsign)
- (if (c-type-qualifiers type)
- (pprint-logical-block (stream nil :prefix "(" :suffix ")")
- (format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
- (c-type-qualifiers type))
- (call-next-method stream type colon atsign))
- (call-next-method)))
-
;; A handy utility.
(let ((cache (make-hash-table :test #'equal)))
(setf (gethash key cache)
(copy-instance c-type :qualifiers qualifiers)))))))
-;; S-expression machinery. Qualifiers have hairy syntax and need to be
-;; implemented by hand.
-
-(defun qualifier (qual &rest args)
- "Parse a qualified C type.
-
- The ARGS consist of a number of qualifiers and exactly one C-type
- S-expression. The result is a qualified version of this type, with the
- given qualifiers attached."
- (if (null args)
- qual
- (let* ((things (mapcar #'expand-c-type args))
- (quals (delete-duplicates
- (sort (cons qual (remove-if-not #'keywordp things))
- #'string<)))
- (types (remove-if-not (lambda (thing) (typep thing 'c-type))
- things)))
- (when (or (null types)
- (not (null (cdr types))))
- (error "Only one proper type expected in ~S." args))
- (qualify-type (car types) quals))))
-(setf (get 'qualifier 'c-type) #'qualifier)
-
-(defun declare-qualifier (qual)
- "Defines QUAL as being a type qualifier.
-
- When used as a C-type operator, it applies that qualifier to the type that
- is its argument."
- (let ((kw (intern (string qual) :keyword)))
- (setf (get qual 'c-type)
- (lambda (&rest args)
- (apply #'qualifier kw args)))))
-
-;; Define some initial qualifiers.
-(dolist (qual '(const volatile restrict))
- (declare-qualifier qual))
-
;;;--------------------------------------------------------------------------
;;; Simple C types (e.g., built-in arithmetic types).
"C types with simple forms."))
(let ((cache (make-hash-table :test #'equal)))
- (defun make-simple-type (name)
+ (defun make-simple-type (name &optional qualifiers)
"Make a distinguished object for the simple type called NAME."
- (or (gethash name cache)
- (setf (gethash name cache)
- (make-instance 'simple-c-type :name name)))))
-
-(defmethod c-declaration ((type simple-c-type) decl)
- (values (concatenate 'string
- (format-qualifiers (c-type-qualifiers type))
- (c-type-name type))
- decl))
+ (qualify-type (or (gethash name cache)
+ (setf (gethash name cache)
+ (make-instance 'simple-c-type :name name)))
+ qualifiers)))
+
+(defmethod pprint-c-type ((type simple-c-type) stream kernel)
+ (pprint-logical-block (stream nil)
+ (format stream "~{~(~A~) ~@_~}~A"
+ (c-type-qualifiers type)
+ (c-type-name type))
+ (funcall kernel stream 0 t)))
(defmethod c-type-equal-p and ((type-a simple-c-type)
(type-b simple-c-type))
(declare (ignore colon atsign))
(let* ((name (c-type-name type))
(symbol (gethash name *simple-type-map*)))
- (if symbol
- (princ symbol stream)
- (format stream "~:@<SIMPLE-C-TYPE ~@_~S~:>" name))))
+ (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]"
+ (c-type-qualifiers type) (or symbol name))))
;; S-expression syntax.
-(define-c-type-syntax simple-c-type (name)
- "Constructs a simple C type called NAME (a string or symbol)."
- (make-simple-type (c-name-case name)))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmethod expand-c-type-spec ((spec string))
+ `(make-simple-type ,spec))
+ (defmethod expand-c-type-form ((head string) tail)
+ `(make-simple-type ,head ,@tail)))
(defmacro define-simple-c-type (names type)
"Define each of NAMES to be a simple type called TYPE."
- `(progn
- (setf (gethash ,type *simple-type-map*)
- ',(if (listp names) (car names) names))
- (defctype ,names (simple-c-type ,type))))
+ (let ((names (if (listp names) names (list names))))
+ `(progn
+ (setf (gethash ,type *simple-type-map*) ',(car names))
+ (defctype ,names ,type)
+ (define-c-type-syntax ,(car names) (&rest quals)
+ `(make-simple-type ,',type (list ,@quals))))))
(define-simple-c-type void "void")
"Return the kind of tagged type that TYPE is, as a keyword."))
(macrolet ((define-tagged-type (kind what)
- (let ((type (intern (format nil "C-~A-TYPE" (string kind))))
- (constructor (intern (format nil "MAKE-~A-TYPE"
- (string kind)))))
+ (let ((type (symbolicate 'c- kind '-type))
+ (constructor (symbolicate 'make- kind '-type)))
`(progn
(defclass ,type (tagged-c-type) ()
(:documentation ,(format nil "C ~a types." what)))
(defmethod c-tagged-type-kind ((type ,type))
- ,kind)
+ ',kind)
(let ((cache (make-hash-table :test #'equal)))
- (defun ,constructor (tag)
- (or (gethash tag cache)
- (setf (gethash tag cache)
- (make-instance ',type :tag tag)))))
- (define-c-type-syntax ,(intern (string kind)) (tag)
- ,(format nil "Construct ~A type named TAG" what)
- (,constructor tag))))))
- (define-tagged-type :enum "enumerated")
- (define-tagged-type :struct "structure")
- (define-tagged-type :union "union"))
-
-(defclass c-enum-type (tagged-c-type)
- ()
- (:documentation
- "C enumeration types."))
-(defclass c-struct-type (tagged-c-type)
- ()
- (:documentation
- "C structure types."))
-(defclass c-union-type (tagged-c-type)
- ()
- (:documentation
- "C union types."))
-
-(defmethod c-declaration ((type tagged-c-type) decl)
- (values (concatenate 'string
- (format-qualifiers (c-type-qualifiers type))
- (string-downcase (c-tagged-type-kind type))
- " "
- (c-type-tag type))
- decl))
+ (defun ,constructor (tag &optional qualifiers)
+ (qualify-type (or (gethash tag cache)
+ (setf (gethash tag cache)
+ (make-instance ',type
+ :tag tag)))
+ qualifiers)))
+ (define-c-type-syntax ,kind (tag &rest quals)
+ ,(format nil "Construct ~A type named TAG" what)
+ `(,',constructor ,tag (list ,@quals)))))))
+ (define-tagged-type enum "enumerated")
+ (define-tagged-type struct "structure")
+ (define-tagged-type union "union"))
+
+(defmethod pprint-c-type ((type tagged-c-type) stream kernel)
+ (pprint-logical-block (stream nil)
+ (format stream "~{~(~A~) ~@_~}~(~A~) ~A"
+ (c-type-qualifiers type)
+ (c-tagged-type-kind type)
+ (c-type-tag type))
+ (funcall kernel stream 0 t)))
(defmethod c-type-equal-p and ((type-a tagged-c-type)
(type-b tagged-c-type))
(defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
(declare (ignore colon atsign))
- (format stream "~:@<~A ~A~:>"
+ (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>"
(c-tagged-type-kind type)
- (c-type-tag type)))
-
-;; S-expression syntax.
-
-(define-c-type-syntax enum (tag)
- "Construct an enumeration type named TAG."
- (make-instance 'c-enum-type :tag (c-name-case tag)))
-(define-c-type-syntax struct (tag)
- "Construct a structure type named TAG."
- (make-instance 'c-struct-type :tag (c-name-case tag)))
-(define-c-type-syntax union (tag)
- "Construct a union type named TAG."
- (make-instance 'c-union-type :tag (c-name-case tag)))
+ (c-type-tag type)
+ (c-type-qualifiers type)))
;;;--------------------------------------------------------------------------
;;; Pointer types.
(:documentation
"C pointer types."))
-(defmethod c-declarator-priority ((type c-pointer-type)) 1)
-
-(defmethod c-declaration ((type c-pointer-type) decl)
- (compound-type-declaration type
- "*~A~A"
- (format-qualifiers (c-type-qualifiers type))
- decl))
+(let ((cache (make-hash-table :test #'eql)))
+ (defun make-pointer-type (subtype &optional qualifiers)
+ "Return a (maybe distinguished) pointer type."
+ (qualify-type (or (gethash subtype cache)
+ (make-instance 'c-pointer-type :subtype subtype))
+ qualifiers)))
+
+(defmethod pprint-c-type ((type c-pointer-type) stream kernel)
+ (pprint-c-type (c-type-subtype type) stream
+ (lambda (stream prio spacep)
+ (when spacep (c-type-space stream))
+ (maybe-in-parens (stream (> prio 1))
+ (format stream "*~{~(~A~)~^ ~@_~}"
+ (c-type-qualifiers type))
+ (funcall kernel stream 1 (c-type-qualifiers type))))))
(defmethod c-type-equal-p and ((type-a c-pointer-type)
(type-b c-pointer-type))
(defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign)
(declare (ignore colon atsign))
- (format stream "~:@<* ~@_~/sod::print-c-type/~:>"
- (c-type-subtype type)))
+ (format stream "~:@<* ~@_~/sod::print-c-type/~{ ~_~S~}~:>"
+ (c-type-subtype type)
+ (c-type-qualifiers type)))
;; S-expression syntax.
-(define-c-type-syntax pointer (sub)
+(define-c-type-syntax * (sub &rest quals)
"Return the type of pointer-to-SUB."
- (make-instance 'c-pointer-type :subtype (expand-c-type sub)))
-(c-type-alias pointer * ptr)
+ `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals)))
+(c-type-alias * pointer ptr)
(defctype string (* char))
+(defctype const-string (* (char :const)))
;;;--------------------------------------------------------------------------
;;; Array types.
(:documentation
"C array types."))
-(defmethod c-declarator-priority ((type c-array-type)) 2)
+(defun make-array-type (subtype dimensions)
+ "Return a new array of SUBTYPE with given DIMENSIONS."
+ (make-instance 'c-array-type :subtype subtype
+ :dimensions (or dimensions '(nil))))
-(defmethod c-declaration ((type c-array-type) decl)
- (compound-type-declaration type
- "~A~{[~@[~A~]]~}"
- decl
- (c-array-dimensions type)))
+(defmethod pprint-c-type ((type c-array-type) stream kernel)
+ (pprint-c-type (c-type-subtype type) stream
+ (lambda (stream prio spacep)
+ (maybe-in-parens (stream (> prio 2))
+ (funcall kernel stream 2 spacep)
+ (format stream "~@<~{[~@[~A~]]~^~_~}~:>"
+ (c-array-dimensions type))))))
(defmethod c-type-equal-p and ((type-a c-array-type)
(type-b c-array-type))
(defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
(declare (ignore colon atsign))
- (format stream "~:@<[] ~@_~:I~/sod::print-c-type/~{ ~_~A~}~:>"
+ (format stream "~:@<[] ~@_~:I~/sod::print-c-type/~{ ~_~S~}~:>"
(c-type-subtype type)
(c-array-dimensions type)))
;; S-expression syntax.
-(define-c-type-syntax array (sub &rest dims)
+(define-c-type-syntax [] (sub &rest dims)
"Return the type of arrays of SUB with the dimensions DIMS.
If the DIMS are omitted, a single unknown-length dimension is added."
- (make-instance 'c-array-type
- :subtype (expand-c-type sub)
- :dimensions (or dims '(nil))))
-(c-type-alias array [] vec)
+ `(make-array-type ,(expand-c-type-spec sub)
+ (list ,@(or dims '(nil)))))
+(c-type-alias [] array vec)
;;;--------------------------------------------------------------------------
;;; Function types.
-;; Definitions.
-
-(defclass c-function-type (c-type)
- ((subtype :initarg :subtype
- :type c-type
- :reader c-type-subtype)
- (arguments :initarg :arguments
- :type list
- :reader c-function-arguments))
- (:documentation
- "C function types. The subtype is the return type, as implied by the C
- syntax for function declarations."))
-
-(defmethod c-declarator-priority ((type c-function-type)) 2)
+;; Arguments.
(defstruct (argument (:constructor make-argument (name type)) (:type list))
"Simple list structure representing a function argument."
name
type)
-(defmethod c-declaration ((type c-function-type) decl)
- (compound-type-declaration type
- "~A(~:[void~;~:*~{~A~^, ~}~])"
- decl
- (mapcar (lambda (arg)
- (if (eq arg :ellipsis)
- "..."
- (multiple-value-bind
- (typestr declstr)
- (c-declaration
- (argument-type arg)
- (or (argument-name arg) ""))
- (format nil "~A~:[~; ~A~]"
- typestr
- (plusp (length declstr))
- declstr))))
- (c-function-arguments type))))
-
(defun arguments-lists-equal-p (list-a list-b)
+ "Return whether LIST-A and LIST-B match.
+
+ They must have the same number of arguments, and each argument must have
+ the same type, or be :ELLIPSIS. The argument names are not inspected."
(and (= (length list-a) (length list-b))
(every (lambda (arg-a arg-b)
(if (eq arg-a :ellipsis)
(argument-type arg-b))))
list-a list-b)))
+(defgeneric commentify-argument-name (name)
+ (:documentation
+ "Produce a `commentified' version of the argument.
+
+ The default behaviour is that temporary argument names are simply omitted
+ (NIL is returned); otherwise, `/*...*/' markers are wrapped around the
+ printable representation of the argument.")
+ (:method ((name null)) nil)
+ (:method ((name t)) (format nil "/*~A*/" name)))
+
+(defun commentify-argument-names (arguments)
+ "Return an argument list with the arguments commentified.
+
+ That is, with each argument name passed through COMMENTIFY-ARGUMENT-NAME."
+ (mapcar (lambda (arg)
+ (if (eq arg :ellipsis)
+ arg
+ (make-argument (commentify-argument-name (argument-name arg))
+ (argument-type arg))))
+ arguments))
+
+(defun commentify-function-type (type)
+ "Return a type like TYPE, but with arguments commentified.
+
+ This doesn't recurse into the return type or argument types."
+ (make-function-type (c-type-subtype type)
+ (commentify-argument-names
+ (c-function-arguments type))))
+
+;; Definitions.
+
+(defclass c-function-type (c-type)
+ ((subtype :initarg :subtype
+ :type c-type
+ :reader c-type-subtype)
+ (arguments :initarg :arguments
+ :type list
+ :reader c-function-arguments))
+ (:documentation
+ "C function types. The subtype is the return type, as implied by the C
+ syntax for function declarations."))
+
+(defun make-function-type (subtype arguments)
+ "Return a new function type, returning SUBTYPE and accepting ARGUMENTS."
+ (make-instance 'c-function-type :subtype subtype :arguments arguments))
+
(defmethod c-type-equal-p and ((type-a c-function-type)
(type-b c-function-type))
(and (c-type-equal-p (c-type-subtype type-a)
#.(concatenate 'string
"~:@<"
"FUN ~@_~:I~/sod::print-c-type/"
- "~{ ~_~:<~A ~@_~/sod::print-c-type/~:>~}"
+ "~{ ~_~:<~S ~@_~/sod::print-c-type/~:>~}"
"~:>")
(c-type-subtype type)
(c-function-arguments type)))
+(defmethod pprint-c-type ((type c-function-type) stream kernel)
+ (pprint-c-type (c-type-subtype type) stream
+ (lambda (stream prio spacep)
+ (maybe-in-parens (stream (> prio 2))
+ (when spacep (c-type-space stream))
+ (funcall kernel stream 2 nil)
+ (pprint-indent :block 4 stream)
+ ;;(pprint-newline :miser stream)
+ (pprint-logical-block
+ (stream nil :prefix "(" :suffix ")")
+ (let ((firstp t))
+ (dolist (arg (c-function-arguments type))
+ (if firstp
+ (setf firstp nil)
+ (format stream ", ~_"))
+ (if (eq arg :ellipsis)
+ (write-string "..." stream)
+ (pprint-c-type (argument-type arg)
+ stream
+ (argument-name arg))))))))))
+
;; S-expression syntax.
-(define-c-type-syntax function (ret &rest args)
+(define-c-type-syntax fun (ret &rest args)
"Return the type of functions which returns RET and has arguments ARGS.
- The ARGS are a list (NAME TYPE). The NAME can be NIL to indicate that no
- name was given."
- (make-instance 'c-function-type
- :subtype (expand-c-type ret)
- :arguments (mapcar (lambda (arg)
- (make-argument (car arg)
- (expand-c-type
- (cadr arg))))
- args)))
-(c-type-alias function () func fun fn)
+ The ARGS are a list of arguments of the form (NAME TYPE). The NAME can be
+ NIL to indicate that no name was given.
+
+ If an entry isn't a list, it's assumed to be the start of a Lisp
+ expression to compute the tail of the list; similarly, if the list is
+ improper, then it's considered to be a complete expression. The upshot of
+ this apparently bizarre rule is that you can say
+
+ (c-type (fun int (\"foo\" int) . arg-tail))
+
+ where ARG-TAIL is (almost) any old Lisp expression and have it tack the
+ arguments onto the end. Of course, there don't have to be any explicit
+ arguments at all. The only restriction is that the head of the Lisp form
+ can't be a list -- so ((lambda (...) ...) ...) is out, but you probably
+ wouldn't type that anyway."
+
+ `(make-function-type ,(expand-c-type-spec ret)
+ ,(do ((args args (cdr args))
+ (list nil
+ (cons `(make-argument ,(caar args)
+ ,(expand-c-type-spec
+ (cadar args)))
+ list)))
+ ((or (atom args) (atom (car args)))
+ (cond ((and (null args) (null list)) `nil)
+ ((null args) `(list ,@(nreverse list)))
+ ((null list) `,args)
+ (t `(list* ,@(nreverse list) ,args)))))))
+(c-type-alias fun function () func fn)
;;;----- That's all, folks --------------------------------------------------
(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 --------------------------------------------------
(cl:in-package #:sod)
;;;--------------------------------------------------------------------------
-;;; Class definitions.
+;;; Classes.
(defclass sod-class ()
((name :initarg :name
(direct-superclasses :initarg :superclasses
:type list
:reader sod-class-direct-superclasses)
- (chained-superclass :initarg :chain-to
- :type (or sod-class null)
- :reader sod-class-chained-superclass)
+ (chain-link :initarg :link
+ :type (or sod-class null)
+ :reader sod-class-chain-link)
(metaclass :initarg :metaclass
:type sod-class
:reader sod-class-metaclass)
(chain :type list :accessor sod-class-chain)
(chains :type list :accessor sod-class-chains)
+ (ilayout :type ilayout :accessor sod-class-ilayout)
+ (effective-methods :type list :accessor sod-class-effective-methods)
+ (vtables :type list :accessor sod-class-vtables)
+
(state :initform nil
:type (member nil :finalized broken)
:accessor sod-class-state))
(:documentation
"Classes describe the layout and behaviour of objects.
- The NAME, LOCATION, NICKNAME, DIRECT-SUPERCLASSES, CHAINED-SUPERCLASS and
+ The NAME, LOCATION, NICKNAME, DIRECT-SUPERCLASSES, CHAIN-LINK and
METACLASS slots are intended to be initialized when the class object is
constructed:
precedence list is computed from the DIRECT-SUPERCLASSES lists of all
of the superclasses involved.
- * The CHAINED-SUPERCLASS is either NIL or one of the
- DIRECT-SUPERCLASSES. Class chains are a means for recovering most of
- the benefits of simple hierarchy lost by the introduction of multiple
- inheritance. A class's superclasses (including itself) are
- partitioned into chains, consisting of a class, its CHAINED-
- SUPERCLASS, that class's CHAINED-SUPERCLASS, and so on. It is an
- error if two direct subclasses of any class appear in the same
- chain (a global property which requires global knowledge of an entire
- program's class hierarchy in order to determine sensibly). Slots of
- superclasses in the same chain can be accessed efficiently; there is
- an indirection needed to access slots of superclasses in other chains.
- Furthermore, an indirection is required to perform a cross-chain
- conversion (i.e., converting a pointer to an instance of some class
- into a pointer to an instance of one of its superclasses in a
- different chain), an operation which occurs implicitly in effective
- methods in order to call direct methods defined on cross-chain
- superclasses.
+ * The CHAIN-LINK is either NIL or one of the DIRECT-SUPERCLASSES. Class
+ chains are a means for recovering most of the benefits of simple
+ hierarchy lost by the introduction of multiple inheritance. A class's
+ superclasses (including itself) are partitioned into chains,
+ consisting of a class, its CHAIN-LINK superclass, that class's
+ CHAIN-LINK, and so on. It is an error if two direct subclasses of any
+ class appear in the same chain (a global property which requires
+ global knowledge of an entire program's class hierarchy in order to
+ determine sensibly). Slots of superclasses in the same chain can be
+ accessed efficiently; there is an indirection needed to access slots
+ of superclasses in other chains. Furthermore, an indirection is
+ required to perform a cross-chain conversion (i.e., converting a
+ pointer to an instance of some class into a pointer to an instance of
+ one of its superclasses in a different chain), an operation which
+ occurs implicitly in effective methods in order to call direct methods
+ defined on cross-chain superclasses.
* The METACLASS is the class of the class object. Classes are objects
in their own right, and therefore must be instances of some class;
Other slots are computed from these in order to describe the class's
layout and effective methods; this is done by FINALIZE-SOD-CLASS.
- FIXME: Add the necessary slots and describe them."))
+ * The CLASS-PRECEDENCE-LIST is a list of superclasses in a linear order.
+ It is computed by the generic function COMPUTE-CLASS-PRECEDENCE-LIST,
+ whose default implementation ensures that the order of superclasses is
+ such that (a) subclasses appear before their superclasses; (b) the
+ direct superclasses of a given class appear in the order in which they
+ were declared by the programmer; and (c) classes always appear in the
+ same relative order in all class precedence lists in the same
+ superclass graph.
+
+ * The CHAIN-HEAD is the least-specific class in the class's chain. If
+ there is no link class then the CHAIN-HEAD is the class itself. This
+ slot, like the next two, is computed by the generic function
+ COMPUTE-CHAINS.
+
+ * The CHAIN is the list of classes on the complete primary chain,
+ starting from this class and ending with the CHAIN-HEAD.
+
+ * The CHAINS are the complete collection of chains (most-to-least
+ specific) for the class and all of its superclasses.
+
+ * The ILAYOUT describes the layout for an instance of the class. It's
+ quite complicated; see the documentation of the ILAYOUT class for
+ detais.
+
+ * The EFFECTIVE-METHODS are a list of effective methods, specialized for
+ the class.
+
+ * The VTABLES are a list of descriptions of vtables for the class. The
+ individual elements are VTABLE objects, which are even more
+ complicated than ILAYOUT structures. See the class documentation for
+ details."))
(defmethod print-object ((class sod-class) stream)
- (print-unreadable-object (class stream :type t)
- (prin1 (sod-class-name class) stream)))
+ (maybe-print-unreadable-object (class stream :type t)
+ (princ (sod-class-name class) stream)))
+
+;;;--------------------------------------------------------------------------
+;;; Slots and initializers.
+
+(defclass sod-slot ()
+ ((name :initarg :name
+ :type string
+ :reader sod-slot-name)
+ (location :initarg :location
+ :initform (file-location nil)
+ :type file-location
+ :reader file-location)
+ (class :initarg :class
+ :type sod-class
+ :reader sod-slot-class)
+ (type :initarg :type
+ :type c-type
+ :reader sod-slot-type))
+ (:documentation
+ "Slots are units of information storage in instances.
+
+ Each class defines a number of slots, which function similarly to (data)
+ members in structures. An instance contains all of the slots defined in
+ its class and all of its superclasses.
+
+ A slot carries the following information.
+
+ * A NAME, which distinguishes it from other slots defined by the same
+ class. Unlike most (all?) other object systems, slots defined in
+ different classes are in distinct namespaces. There are no special
+ restrictions on slot names.
+
+ * A LOCATION, which states where in the user's source the slot was
+ defined. This gets used in error messages.
+
+ * A CLASS, which states which class defined the slot. The slot is
+ available in instances of this class and all of its descendents.
+
+ * A TYPE, which is the C type of the slot. This must be an object type
+ (certainly not a function type, and it must be a complete type by the
+ time that the user header code has been scanned)."))
+
+(defmethod print-object ((slot sod-slot) stream)
+ (maybe-print-unreadable-object (slot stream :type t)
+ (pprint-c-type (sod-slot-type slot) stream
+ (format nil "~A.~A"
+ (sod-class-nickname (sod-slot-class slot))
+ (sod-slot-name slot)))))
+
+(defclass sod-initializer ()
+ ((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)
+ (value-kind :initarg :value-kind
+ :type keyword
+ :reader sod-initializer-value-kind)
+ (value-form :initarg :value-form
+ :type c-fragment
+ :reader sod-initializer-value-form))
+ (:documentation
+ "Provides an initial value for a slot.
+
+ The slots of an initializer are as follows.
+
+ * The SLOT specifies which slot this initializer is meant to initialize.
+
+ * The LOCATION states the position in the user's source file where the
+ initializer was found. This gets used in error messages. (Depending
+ on the source layout style, this might differ from the location in the
+ VALUE-FORM C fragment.)
+
+ * The CLASS states which class defined this initializer. For instance
+ slot initializers (SOD-INSTANCE-INITIALIZER), this will be the same as
+ the SLOT's class, or be one of its descendants. For class slot
+ initializers (SOD-CLASS-INITIALIZER), this will be an instance of the
+ SLOT's class, or an instance of one of its descendants.
+
+ * The VALUE-KIND states what manner of initializer we have. It can be
+ either :SINGLE, indicating a standalone expression, or :COMPOUND,
+ indicating a compound initializer which must be surrounded by braces
+ on output.
+
+ * The VALUE-FORM gives the text of the initializer, as a C fragment.
+
+ Typically you'll see instances of subclasses of this class in the wild
+ rather than instances of this class directly. See SOD-CLASS-INITIALIZER
+ and SOD-INSTANCE-INITIALIZER."))
+
+(defmethod print-object ((initializer sod-initializer) stream)
+ (if *print-escape*
+ (print-unreadable-object (initializer stream :type t)
+ (format stream "~A = ~A"
+ (sod-initializer-slot initializer)
+ initializer))
+ (format stream "~:[{~A}~;~A~]"
+ (eq (sod-initializer-value-kind initializer) :single)
+ (sod-initializer-value-form initializer))))
+
+(defclass sod-class-initializer (sod-initializer)
+ ()
+ (:documentation
+ "Provides an initial value for a class slot.
+
+ A class slot initializer provides an initial value for a slot in the class
+ object (i.e., one of the slots defined by the class's metaclass). Its
+ VALUE-FORM must have the syntax of an initializer, and its consituent
+ expressions must be constant expressions.
+
+ See SOD-INITIALIZER for more details."))
+
+(defclass sod-instance-initializer (sod-initializer)
+ ()
+ (:documentation
+ "Provides an initial value for a slot in all instances.
+
+ An instance slot initializer provides an initial value for a slot in
+ instances of the class. Its VALUE-FORM must have the syntax of an
+ initializer. Furthermore, if the slot has aggregate type, then you'd
+ better be sure that your compiler supports compound literals (6.5.2.5)
+ because that's what the initializer gets turned into.
+
+ See SOD-INITIALIZER for more details."))
+
+;;;--------------------------------------------------------------------------
+;;; Messages and methods.
(defclass sod-message ()
((name :initarg :name
Subclasses can (and probably will) define additional slots."))
+(defmethod print-object ((message sod-message) stream)
+ (maybe-print-unreadable-object (message stream :type t)
+ (pprint-c-type (sod-message-type message) stream
+ (format nil "~A.~A"
+ (sod-class-nickname (sod-message-class message))
+ (sod-message-name message)))))
+
(defclass sod-method ()
((message :initarg :message
:type sod-message
subclasses of SOD-METHOD in order to carry the additional metadata they
need to keep track of."))
-(defclass sod-slot ()
- ((name :initarg :name
- :type string
- :reader sod-slot-name)
- (location :initarg :location
- :initform (file-location nil)
- :type file-location
- :reader file-location)
- (class :initarg :class
- :type sod-class
- :reader sod-slot-class)
- (type :initarg :type
- :type c-type
- :reader sod-slot-type))
- (:documentation
- "Slots are units of information storage in instances.
-
- Each class defines a number of slots, which function similarly to (data)
- members in structures. An instance contains all of the slots defined in
- its class and all of its superclasses.
-
- A slot carries the following information.
-
- * A NAME, which distinguishes it from other slots defined by the same
- class. Unlike most (all?) other object systems, slots defined in
- different classes are in distinct namespaces. There are no special
- restrictions on slot names.
-
- * A LOCATION, which states where in the user's source the slot was
- defined. This gets used in error messages.
-
- * A CLASS, which states which class defined the slot. The slot is
- available in instances of this class and all of its descendents.
-
- * A TYPE, which is the C type of the slot. This must be an object type
- (certainly not a function type, and it must be a complete type by the
- time that the user header code has been scanned)."))
-
-(defclass sod-initializer ()
- ((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)
- (value-kind :initarg :value-kind
- :type keyword
- :reader sod-initializer-value-kind)
- (value-form :initarg :value-form
- :type c-fragment
- :reader sod-initializer-value-form))
- (:documentation
- "Provides an initial value for a slot.
-
- The slots of an initializer are as follows.
-
- * The SLOT specifies which slot this initializer is meant to initialize.
-
- * The LOCATION states the position in the user's source file where the
- initializer was found. This gets used in error messages. (Depending
- on the source layout style, this might differ from the location in the
- VALUE-FORM C fragment.)
-
- * The CLASS states which class defined this initializer. For instance
- slot initializers (SOD-INSTANCE-INITIALIZER), this will be the same as
- the SLOT's class, or be one of its descendants. For class slot
- initializers (SOD-CLASS-INITIALIZER), this will be an instance of the
- SLOT's class, or an instance of one of its descendants.
-
- * The VALUE-KIND states what manner of initializer we have. It can be
- either :SINGLE, indicating a standalone expression, or :COMPOUND,
- indicating a compound initializer which must be surrounded by braces
- on output.
-
- * The VALUE-FORM gives the text of the initializer, as a C fragment.
-
- Typically you'll see instances of subclasses of this class in the wild
- rather than instances of this class directly. See SOD-CLASS-INITIALIZER
- and SOD-INSTANCE-INITIALIZER."))
-
-(defclass sod-class-initializer (sod-initializer)
- ()
- (:documentation
- "Provides an initial value for a class slot.
-
- A class slot initializer provides an initial value for a slot in the class
- object (i.e., one of the slots defined by the class's metaclass). Its
- VALUE-FORM must have the syntax of an initializer, and its consituent
- expressions must be constant expressions.
-
- See SOD-INITIALIZER for more details."))
-
-(defclass sod-instance-initializer (sod-initializer)
- ()
- (:documentation
- "Provides an initial value for a slot in all instances.
-
- An instance slot initializer provides an initial value for a slot in
- instances of the class. Its VALUE-FORM must have the syntax of an
- initializer. Furthermore, if the slot has aggregate type, then you'd
- better be sure that your compiler supports compound literals (6.5.2.5)
- because that's what the initializer gets turned into.
-
- See SOD-INITIALIZER for more details."))
+(defmethod print-object ((method sod-method) stream)
+ (maybe-print-unreadable-object (method stream :type t)
+ (format stream "~A ~@_~A"
+ (sod-method-message method)
+ (sod-method-class method))))
;;;--------------------------------------------------------------------------
;;; Classes as C types.
(defmethod print-c-type (stream (type c-class-type) &optional colon atsign)
(declare (ignore colon atsign))
- (format stream "~:@<CLASS ~@_~S~:>" (c-type-name type)))
+ (format stream "~:@<CLASS ~@_~S~{ ~_~S~}~:>"
+ (c-type-name type)
+ (c-type-qualifiers type)))
(defun find-class-type (name &optional floc)
"Look up NAME and return the corresponding C-CLASS-TYPE.
"Return a class type for NAME, creating it if necessary.
FLOC is the location to use in error reports."
- (multiple-value-bind (type winp) (find-class-type name floc)
- (cond ((not winp) nil)
- (type type)
- (t (setf (gethash name *type-map*)
- (make-instance 'c-class-type :name name :class nil))))))
+ (let ((name (etypecase name
+ (sod-class (sod-class-name name))
+ (string name))))
+ (or (find-class-type name floc)
+ (setf (gethash name *type-map*)
+ (make-instance 'c-class-type :name name :class nil)))))
(defun find-sod-class (name &optional floc)
"Return the SOD-CLASS object with the given NAME.
FLOC is the location to use in error reports."
(with-default-error-location (floc)
- (multiple-value-bind (type winp) (find-class-type name floc)
+ (let ((type (find-class-type name floc)))
(cond ((not type) (error "Type `~A' not known" name))
(t (let ((class (c-type-class type)))
(unless class
(t
(setf (c-type-class type) class))))))
-(define-c-type-syntax class (name)
- "Returns a type object for the named class."
- (make-class-type (c-name-case name)))
-
-;;;--------------------------------------------------------------------------
-;;; Class finalization.
-
-;; Protocol.
-
-(defgeneric compute-chains (class)
- (:documentation
- "Compute the layout chains for CLASS.
-
- Fills in
+(defun sod-class-type (class)
+ "Returns the C type corresponding to CLASS."
+ (find-class-type (sod-class-name class)))
- * the head of the class's primary chain;
-
- * the class's primary chain as a list, most- to least-specific; and
-
- * the complete collection of chains, as a list of lists, each most- to
- least-specific, with the primary chain first.
-
- If the chains are ill-formed (i.e., not distinct) then an error is
- reported and the function returns nil; otherwise it returns a true
- value."))
-
-(defgeneric check-sod-class (class)
- (:documentation
- "Check the CLASS for validity.
-
- This is done as part of class finalization. The checks performed are as
- follows.
-
- * The class name and nickname, and the names of messages, obey the
- rules (see VALID-NAME-P).
-
- * The messages and slots have distinct names.
-
- * The classes in the class-precedence-list have distinct nicknames.
-
- * The chained-superclass is actually one of the direct superclasses.
-
- * The chosen metaclass is actually a subclass of all of the
- superclasses' metaclasses.
-
- Returns true if all is well; false (and signals errors) if anything was
- wrong."))
-
-(defgeneric finalize-sod-class (class)
- (:documentation
- "Computes all of the gory details about a class.
-
- Once one has stopped inserting methods and slots and so on into a class,
- one needs to finalize it to determine the layout structure and the class
- precedence list and so on. More precisely that gets done is this:
-
- * Related classes (i.e., direct superclasses and the metaclass) are
- finalized if they haven't been already.
-
- * If you've been naughty and failed to store a list of slots or
- whatever, then an empty list is inserted.
-
- * The class precedence list is computed and stored.
-
- * The class is checked for compiance with the well-formedness rules.
-
- * The layout chains are computed.
-
- Other stuff will need to happen later, but it's not been done yet. In
- particular:
-
- * Actually computing the layout of the instance and the virtual tables.
-
- * Combining the applicable methods into effective methods.
-
- FIXME this needs doing."))
-
-;; Implementation.
-
-(defmethod compute-chains ((class sod-class))
- (with-default-error-location (class)
- (let* ((head (with-slots (chained-superclass) class
- (if chained-superclass
- (sod-class-chain-head chained-superclass)
- class)))
- (chain (with-slots (chained-superclass) class
- (cons class (and chained-superclass
- (sod-class-chain chained-superclass)))))
- (chains (list chain)))
-
- ;; Compute the chains. This is (unsurprisingly) the hard bit. The
- ;; chain of this class must either be a new chain or the same as one of
- ;; its superclasses. Therefore, the chains are well-formed if the
- ;; chains of the superclasses are distinct. We can therefore scan the
- ;; direct superclasses from left to right as follows.
- (with-slots (direct-superclasses) class
- (let ((table (make-hash-table)))
- (dolist (super direct-superclasses)
- (let* ((head (sod-class-chain-head super))
- (tail (gethash head table)))
- (cond ((not tail)
- (setf (gethash head table) super))
- ((not (sod-subclass-p super tail))
- (error "Conflicting chains (~A and ~A) in class ~A"
- (sod-class-name tail)
- (sod-class-name super)
- (sod-class-name class)))
- (t
- (let ((ch (sod-class-chain super)))
- (unless (eq ch chain)
- (push ch chains)))))))))
-
- ;; Done.
- (values head chain (nreverse chains)))))
-
-(defmethod check-sod-class ((class sod-class))
- (with-default-error-location (class)
-
- ;; Check the names of things are valid.
- (with-slots (name nickname messages) class
- (unless (valid-name-p name)
- (error "Invalid class name `~A'" name))
- (unless (valid-name-p nickname)
- (error "Invalid class nickname `~A' on class `~A'" nickname name))
- (dolist (message messages)
- (unless (valid-name-p (sod-message-name message))
- (error "Invalid message name `~A' on class `~A'"
- (sod-message-name message) name))))
-
- ;; Check that the slots and messages have distinct names.
- (with-slots (name slots messages class-precedence-list) class
- (flet ((check-list (list what namefunc)
- (let ((table (make-hash-table :test #'equal)))
- (dolist (item list)
- (let ((itemname (funcall namefunc item)))
- (if (gethash itemname table)
- (error "Duplicate ~A name `~A' on class `~A'"
- what itemname name)
- (setf (gethash itemname table) item)))))))
- (check-list slots "slot" #'sod-slot-name)
- (check-list messages "message" #'sod-message-name)
- (check-list class-precedence-list "nickname" #'sod-class-name)))
-
- ;; Check that the CHAIN-TO class is actually a superclass.
- (with-slots (name direct-superclasses chained-superclass) class
- (unless (or (not chained-superclass)
- (member chained-superclass direct-superclasses))
- (error "In `~A~, chain-to class `~A' is not a direct superclass"
- name (sod-class-name chained-superclass))))
-
- ;; Check that the metaclass is a subclass of each of the
- ;; superclasses' metaclasses.
- (with-slots (name metaclass direct-superclasses) class
- (dolist (super direct-superclasses)
- (unless (sod-subclass-p metaclass (sod-class-metaclass super))
- (error "Incompatible metaclass for `~A': ~
- `~A' isn't subclass of `~A' (of `~A')"
- name
- (sod-class-name metaclass)
- (sod-class-name (sod-class-metaclass super))
- (sod-class-name super)))))))
-
-(defmethod finalize-sod-class ((class sod-class))
- (with-default-error-location (class)
- (ecase (sod-class-state class)
- ((nil)
-
- ;; If this fails, mark the class as a loss.
- (setf (sod-class-state class) :broken)
-
- ;; Finalize all of the superclasses. There's some special pleading
- ;; here to make bootstrapping work: we don't try to finalize the
- ;; metaclass if we're a root class (no direct superclasses -- because
- ;; in that case the metaclass will have to be a subclass of us!), or
- ;; if it's equal to us. This is enough to tie the knot at the top of
- ;; the class graph.
- (with-slots (name direct-superclasses metaclass) class
- (dolist (super direct-superclasses)
- (finalize-sod-class super))
- (unless (or (null direct-superclasses)
- (eq class metaclass))
- (finalize-sod-class metaclass)))
-
- ;; Clobber the lists of items if they've not been set.
- (dolist (slot '(slots instance-initializers class-initializers
- messages methods))
- (unless (slot-boundp class slot)
- (setf (slot-value class slot) nil)))
-
- ;; If the CPL hasn't been done yet, compute it.
- (with-slots (class-precedence-list) class
- (unless (slot-boundp class 'class-precedence-list)
- (setf class-precedence-list (compute-cpl class))))
-
- ;; If no metaclass has been established, then choose one.
- (with-slots (metaclass) class
- (unless (and (slot-boundp class 'metaclass) metaclass)
- (setf metaclass (guess-metaclass class))))
-
- ;; If no nickname has been set, choose a default. This might cause
- ;; conflicts, but, well, the user should have chosen an explicit
- ;; nickname.
- (with-slots (name nickname) class
- (unless (and (slot-boundp class 'nickname) nickname)
- (setf nickname (string-downcase name))))
-
- ;; Check that the class is fairly sane.
- (check-sod-class class)
-
- ;; Determine the class's layout.
- (compute-chains class)
-
- ;; Done.
- (setf (sod-class-state class) :finalized)
- t)
-
- (:broken
- nil)
-
- (:finalized
- t))))
+(define-c-type-syntax class (name &rest quals)
+ "Returns a type object for the named class."
+ (if quals
+ `(qualify-type (make-class-type ,name) (list ,@quals))
+ `(make-class-type ,name)))
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Class finalization
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Class finalization.
+
+;; Protocol.
+
+(defgeneric compute-chains (class)
+ (:documentation
+ "Compute the layout chains for CLASS.
+
+ Returns the following three values.
+
+ * the head of the class's primary chain;
+
+ * the class's primary chain as a list, most- to least-specific; and
+
+ * the complete collection of chains, as a list of lists, each most- to
+ least-specific, with the primary chain first.
+
+ These values will be stored in the CHAIN-HEAD, CHAIN and CHAINS slots.
+
+ If the chains are ill-formed (i.e., not distinct) then an error is
+ signalled."))
+
+(defgeneric check-sod-class (class)
+ (:documentation
+ "Check the CLASS for validity.
+
+ This is done as part of class finalization. The checks performed are as
+ follows.
+
+ * The class name and nickname, and the names of messages, obey the
+ rules (see VALID-NAME-P).
+
+ * The messages and slots have distinct names.
+
+ * The classes in the class-precedence-list have distinct nicknames.
+
+ * The chain-link is actually a proper (though not necessarily direct)
+ superclass.
+
+ * The chosen metaclass is actually a subclass of all of the
+ superclasses' metaclasses.
+
+ Returns true if all is well; false (and signals errors) if anything was
+ wrong."))
+
+(defgeneric finalize-sod-class (class)
+ (:documentation
+ "Computes all of the gory details about a class.
+
+ Once one has stopped inserting methods and slots and so on into a class,
+ one needs to finalize it to determine the layout structure and the class
+ precedence list and so on. More precisely that gets done is this:
+
+ * Related classes (i.e., direct superclasses and the metaclass) are
+ finalized if they haven't been already.
+
+ * If you've been naughty and failed to store a list of slots or
+ whatever, then an empty list is inserted.
+
+ * The class precedence list is computed and stored.
+
+ * The class is checked for compiance with the well-formedness rules.
+
+ * The layout chains are computed.
+
+ Other stuff will need to happen later, but it's not been done yet. In
+ particular:
+
+ * Actually computing the layout of the instance and the virtual tables.
+
+ * Combining the applicable methods into effective methods.
+
+ FIXME this needs doing."))
+
+;; Implementation.
+
+(defun sod-subclass-p (class-a class-b)
+ "Return whether CLASS-A is a descendent of CLASS-B."
+ (member class-b (sod-class-precedence-list class-a)))
+
+(defun valid-name-p (name)
+ "Checks whether NAME is a valid name.
+
+ The rules are:
+
+ * the name must be a string
+ * which is nonempty
+ * whose first character is alphabetic
+ * all of whose characters are alphanumeric or underscores
+ * and which doesn't contain two consecutive underscores."
+
+ (and (stringp name)
+ (plusp (length name))
+ (alpha-char-p (char name 0))
+ (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
+ (not (search "__" name))))
+
+(defmethod compute-chains ((class sod-class))
+ (with-default-error-location (class)
+ (with-slots (chain-link class-precedence-list) class
+ (let* ((head (if chain-link
+ (sod-class-chain-head chain-link)
+ class))
+ (chain (cons class (and chain-link
+ (sod-class-chain chain-link))))
+ (table (make-hash-table)))
+
+ ;; Check the chains. We work through each superclass, maintaining a
+ ;; hash table keyed by class. If we encounter a class C which links
+ ;; to L, then we store C as L's value; if L already has a value then
+ ;; we've found an error. By the end of all of this, the classes
+ ;; which don't have an entry are the chain tails.
+ (dolist (super class-precedence-list)
+ (let ((link (sod-class-chain-link super)))
+ (when link
+ (when (gethash link table)
+ (error "Conflicting chains in class ~A: ~
+ (~A and ~A both link to ~A)"
+ class super (gethash link table) link))
+ (setf (gethash link table) super))))
+
+ ;; Done.
+ (values head chain
+ (cons chain
+ (mapcar #'sod-class-chain
+ (remove-if (lambda (super)
+ (gethash super table))
+ (cdr class-precedence-list)))))))))
+
+(defmethod check-sod-class ((class sod-class))
+ (with-default-error-location (class)
+
+ ;; Check the names of things are valid.
+ (with-slots (name nickname messages) class
+ (unless (valid-name-p name)
+ (error "Invalid class name `~A'" class))
+ (unless (valid-name-p nickname)
+ (error "Invalid class nickname `~A' on class `~A'" nickname class))
+ (dolist (message messages)
+ (unless (valid-name-p (sod-message-name message))
+ (error "Invalid message name `~A' on class `~A'"
+ (sod-message-name message) class))))
+
+ ;; 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)))
+ (dolist (item list)
+ (let ((name (funcall namefunc item)))
+ (if (gethash name table)
+ (error "Duplicate ~A name `~A' on class `~A'"
+ what name class)
+ (setf (gethash name table) item)))))))
+ (check-list slots "slot" #'sod-slot-name)
+ (check-list messages "message" #'sod-message-name)
+ (check-list class-precedence-list "nickname" #'sod-class-name)))
+
+ ;; Check that the CHAIN-TO class is actually a proper superclass. (This
+ ;; eliminates hairy things like a class being its own link.)
+ (with-slots (class-precedence-list chain-link) class
+ (unless (or (not chain-link)
+ (member chain-link (cdr class-precedence-list)))
+ (error "In `~A~, chain-to class `~A' is not a proper superclass"
+ class chain-link)))
+
+ ;; Check that the metaclass is a subclass of each direct superclass's
+ ;; metaclass.
+ (with-slots (metaclass direct-superclasses) class
+ (dolist (super direct-superclasses)
+ (unless (sod-subclass-p metaclass (sod-class-metaclass super))
+ (error "Incompatible metaclass for `~A': ~
+ `~A' isn't a subclass of `~A' (of `~A')"
+ class metaclass (sod-class-metaclass super) super))))))
+
+(defmethod finalize-sod-class ((class sod-class))
+
+ ;; CLONE-AND-HACK WARNING: Note that BOOTSTRAP-CLASSES has a (very brief)
+ ;; clone of the CPL and chain establishment code. If the interface changes
+ ;; then BOOTSTRAP-CLASSES will need to be changed too.
+
+ (with-default-error-location (class)
+ (ecase (sod-class-state class)
+ ((nil)
+
+ ;; If this fails, mark the class as a loss.
+ (setf (sod-class-state class) :broken)
+
+ ;; Finalize all of the superclasses. There's some special pleading
+ ;; here to make bootstrapping work: we don't try to finalize the
+ ;; metaclass if we're a root class (no direct superclasses -- because
+ ;; in that case the metaclass will have to be a subclass of us!), or
+ ;; if it's equal to us. This is enough to tie the knot at the top of
+ ;; the class graph.
+ (with-slots (name direct-superclasses metaclass) class
+ (dolist (super direct-superclasses)
+ (finalize-sod-class super))
+ (unless (or (null direct-superclasses)
+ (eq class metaclass))
+ (finalize-sod-class metaclass)))
+
+ ;; Clobber the lists of items if they've not been set.
+ (dolist (slot '(slots instance-initializers class-initializers
+ messages methods))
+ (unless (slot-boundp class slot)
+ (setf (slot-value class slot) nil)))
+
+ ;; If the CPL hasn't been done yet, compute it.
+ (with-slots (class-precedence-list) class
+ (unless (slot-boundp class 'class-precedence-list)
+ (setf class-precedence-list (compute-cpl class))))
+
+ ;; If no metaclass has been established, then choose one.
+ (with-slots (metaclass) class
+ (unless (and (slot-boundp class 'metaclass) metaclass)
+ (setf metaclass (guess-metaclass class))))
+
+ ;; If no nickname has been set, choose a default. This might cause
+ ;; conflicts, but, well, the user should have chosen an explicit
+ ;; nickname.
+ (with-slots (name nickname) class
+ (unless (and (slot-boundp class 'nickname) nickname)
+ (setf nickname (string-downcase name))))
+
+ ;; Check that the class is fairly sane.
+ (check-sod-class class)
+
+ ;; Determine the class's layout.
+ (with-slots (chain-head chain chains) class
+ (setf (values chain-head chain chains) (compute-chains class)))
+
+ (with-slots (ilayout effective-methods vtables) class
+ (setf ilayout (compute-ilayout class))
+ (setf effective-methods (compute-effective-methods class))
+ (setf vtables (compute-vtables class)))
+
+ ;; Done.
+ (setf (sod-class-state class) :finalized)
+ t)
+
+ (:broken
+ nil)
+
+ (:finalized
+ t))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Layout for instances and vtables
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Effective slot objects.
+
+(defclass effective-slot ()
+ ((class :initarg :class :type sod-slot :reader effective-slot-class)
+ (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
+ (initializer :initarg :initializer
+ :type (or sod-initializer null)
+ :reader effective-slot-initializer))
+ (:documentation
+ "Describes a slot and how it's meant to be initialized.
+
+ Effective slot objects are usually attached to layouts."))
+
+(defgeneric find-slot-initializer (class slot)
+ (:documentation
+ "Return the most specific initializer for SLOT, starting from CLASS."))
+
+(defgeneric compute-effective-slot (class slot)
+ (:documentation
+ "Construct an effective slot from the supplied direct slot.
+
+ SLOT is a direct slot defined on CLASS or one of its superclasses.
+ (Metaclass initializers are handled using a different mechanism.)"))
+
+(defmethod print-object ((slot effective-slot) stream)
+ (maybe-print-unreadable-object (slot stream :type t)
+ (format stream "~A~@[ = ~@_~A~]"
+ (effective-slot-direct-slot slot)
+ (effective-slot-initializer slot))))
+
+(defmethod find-slot-initializer ((class sod-class) (slot sod-slot))
+ (some (lambda (super)
+ (find slot
+ (sod-class-instance-initializers super)
+ :key #'sod-initializer-slot))
+ (sod-class-precedence-list class)))
+
+(defmethod compute-effective-slot ((class sod-class) (slot sod-slot))
+ (make-instance 'effective-slot
+ :slot slot
+ :class class
+ :initializer (find-slot-initializer class slot)))
+
+;;;--------------------------------------------------------------------------
+;;; Instance layout objects.
+
+;;; islots
+
+(defclass islots ()
+ ((class :initarg :class :type sod-class :reader islots-class)
+ (subclass :initarg :subclass :type sod-class :reader islots-subclass)
+ (slots :initarg :slots :type list :reader islots-slots))
+ (:documentation
+ "The collection of effective SLOTS defined by an instance of CLASS."))
+
+(defmethod print-object ((islots islots) stream)
+ (print-unreadable-object (islots stream :type t)
+ (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
+ (islots-subclass islots)
+ (islots-class islots)
+ (islots-slots islots))))
+
+(defgeneric compute-islots (class subclass)
+ (:documentation
+ "Return ISLOTS containing EFFECTIVE-SLOTs for a particular CLASS.
+
+ Initializers for the slots should be taken from the most specific
+ superclass of SUBCLASS."))
+
+;;; vtable-pointer
+
+(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))
+ (:documentation
+ "A pointer to the vtable for CLASS corresponding to a particular CHAIN."))
+
+(defmethod print-object ((vtp vtable-pointer) stream)
+ (print-unreadable-object (vtp stream :type t)
+ (format stream "~A:~A"
+ (vtable-pointer-class vtp)
+ (sod-class-nickname (vtable-pointer-chain-head vtp)))))
+
+;;; ichain
+
+(defclass ichain ()
+ ((class :initarg :class :type sod-class :reader ichain-class)
+ (chain-head :initarg :chain-head :type sod-class :reader ichain-head)
+ (body :initarg :body :type list :reader ichain-body))
+ (:documentation
+ "All of the instance layout for CLASS corresponding to a particular CHAIN.
+
+ The BODY is a list of things to include in the finished structure. By
+ default, it contains a VTABLE-POINTER and ISLOTS for each class in the
+ chain."))
+
+(defmethod print-object ((ichain ichain) stream)
+ (print-unreadable-object (ichain stream :type t)
+ (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
+ (ichain-class ichain)
+ (sod-class-nickname (ichain-head ichain))
+ (ichain-body ichain))))
+
+(defgeneric compute-ichain (class chain)
+ (:documentation
+ "Return an ICHAIN for a particular CHAIN of CLASS's superclasses.
+
+ The CHAIN is a list of classes, with the least specific first -- so the
+ chain head is the first element."))
+
+;;; ilayout
+
+(defclass ilayout ()
+ ((class :initarg :class :type sod-class :reader ilayout-class)
+ (ichains :initarg :ichains :type list :reader ilayout-ichains))
+ (:documentation
+ "All of the instance layout for a CLASS.
+
+ Consists of an ICHAIN for each distinct chain."))
+
+(defmethod print-object ((ilayout ilayout) stream)
+ (print-unreadable-object (ilayout stream :type t)
+ (format stream "~A ~_~:<~@{~S~^ ~_~}~:>"
+ (ilayout-class ilayout)
+ (ilayout-ichains ilayout))))
+
+(defgeneric compute-ilayout (class)
+ (:documentation
+ "Compute and return an instance layout for CLASS."))
+
+;;; Standard implementation.
+
+(defmethod compute-islots ((class sod-class) (subclass sod-class))
+ (make-instance 'islots
+ :class class
+ :subclass subclass
+ :slots (mapcar (lambda (slot)
+ (compute-effective-slot subclass slot))
+ (sod-class-slots class))))
+
+(defmethod compute-ichain ((class sod-class) chain)
+ (let* ((head (car chain))
+ (vtable-pointer (make-instance 'vtable-pointer
+ :class class
+ :chain-head head))
+ (islots (remove-if-not #'islots-slots
+ (mapcar (lambda (super)
+ (compute-islots super class))
+ chain))))
+ (make-instance 'ichain
+ :class class
+ :chain-head head
+ :body (cons vtable-pointer islots))))
+
+(defmethod compute-ilayout ((class sod-class))
+ (make-instance 'ilayout
+ :class class
+ :ichains (mapcar (lambda (chain)
+ (compute-ichain class
+ (reverse chain)))
+ (sod-class-chains class))))
+
+;;;--------------------------------------------------------------------------
+;;; Effective methods.
+
+(defclass effective-method ()
+ ((message :initarg :message
+ :type sod-message
+ :reader effective-method-message)
+ (class :initarg :class
+ :type sod-class
+ :reader effective-method-class))
+ (:documentation
+ "The effective method invoked by sending MESSAGE to an instance of CLASS.
+
+ This is not a useful class by itself. Message classes are expected to
+ define their own effective-method classes.
+
+ An effective method class must accept a :DIRECT-METHODS initarg, which
+ will be a list of applicable methods sorted in most-to-least specific
+ order."))
+
+(defmethod print-object ((method effective-method) stream)
+ (maybe-print-unreadable-object (method stream :type t)
+ (format stream "~A ~A"
+ (effective-method-message method)
+ (effective-method-class method))))
+
+(defgeneric message-effective-method-class (message)
+ (:documentation
+ "Return the effective method class for the given MESSAGE."))
+
+(defgeneric compute-sod-effective-method (message class)
+ (:documentation
+ "Return the effective method when a CLASS instance receives MESSAGE.
+
+ The default method constructs an instance of the message's chosen
+ MESSAGE-EFFECTIVE-METHOD-CLASS, passing the MESSAGE, the CLASS and the
+ list of applicable methods as initargs to MAKE-INSTANCE."))
+
+(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))))
+ (sod-class-precedence-list class))))
+ (make-instance (message-effective-method-class message)
+ :message message
+ :class class
+ :direct-methods direct-methods)))
+
+;;;--------------------------------------------------------------------------
+;;; Vtable layout.
+
+;;; method-entry
+
+(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))
+ (:documentation
+ "An entry point into an effective method.
+
+ Calls to an effective method via different vtable chains will have their
+ `me' pointers pointing to different ichains within the instance layout.
+ Rather than (necessarily) duplicating the entire effective method for each
+ chain, we insert an entry veneer (the method entry) to fix up the pointer.
+ Exactly how it does this is up to the effective method -- and duplication
+ under some circumstances is probably a reasonable approach -- e.g., if the
+ effective method is just going to call a direct method immediately."))
+
+(defmethod print-object ((entry method-entry) stream)
+ (maybe-print-unreadable-object (entry stream :type t)
+ (format stream "~A:~A"
+ (method-entry-effective-method entry)
+ (sod-class-nickname (method-entry-chain-head entry)))))
+
+(defgeneric make-method-entry (effective-method chain-head)
+ (:documentation
+ "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
+
+ There is no default method for this function. (Maybe when the
+ effective-method/method-entry output protocol has settled down I'll know
+ what a sensible default action would be.)"))
+
+;;; vtmsgs
+
+(defclass vtmsgs ()
+ ((class :initarg :class :type sod-class :reader vtmsgs-class)
+ (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
+ (chain-head :initarg :chain-head
+ :type sod-class
+ :reader vtmsgs-chain-head)
+ (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
+ CHAIN-HEAD."))
+
+(defmethod print-object ((vtmsgs vtmsgs) stream)
+ (print-unreadable-object (vtmsgs stream :type t)
+ (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
+ (vtmsgs-subclass vtmsgs)
+ (vtmsgs-class vtmsgs)
+ (vtmsgs-entries vtmsgs))))
+
+(defgeneric compute-vtmsgs (class subclass chain-head)
+ (:documentation
+ "Return a VTMSGS object containing method entries for CLASS.
+
+ The CHAIN-HEAD describes which chain the method entries should be
+ constructed for.
+
+ The default method simply calls MAKE-METHOD-ENTRY for each of the methods
+ and wraps a VTMSGS object around them. This ought to be enough for almost
+ all purposes."))
+
+;;; class-pointer
+
+(defclass class-pointer ()
+ ((class :initarg :class
+ :type sod-class
+ :reader class-pointer-class)
+ (chain-head :initarg :chain-head
+ :type sod-class
+ :reader class-pointer-chain-head)
+ (metaclass :initarg :metaclass
+ :type sod-class
+ :reader class-pointer-metaclass)
+ (meta-chain-head :initarg :meta-chain-head
+ :type sod-class
+ :reader class-pointer-meta-chain-head))
+ (:documentation
+ "Represents a pointer to a class object for the instance's class.
+
+ A class instance can have multiple chains. It may be useful to find any
+ of those chains from an instance of the class. Therefore the vtable
+ stores a pointer to each separate chain of the class instance."))
+
+(defmethod print-object ((cptr class-pointer) stream)
+ (print-unreadable-object (cptr stream :type t)
+ (format stream "~A:~A"
+ (class-pointer-metaclass cptr)
+ (sod-class-nickname (class-pointer-meta-chain-head cptr)))))
+
+(defgeneric make-class-pointer (class chain-head metaclass meta-chain-head)
+ (:documentation
+ "Return a class pointer to a metaclass chain."))
+
+;;; base-offset
+
+(defclass base-offset ()
+ ((class :initarg :class :type sod-class :reader base-offset-class)
+ (chain-head :initarg :chain-head
+ :type sod-class
+ :reader base-offset-chain-head))
+ (:documentation
+ "The offset of this chain to the ilayout base.
+
+ There's only one of these per vtable."))
+
+(defmethod print-object ((boff base-offset) stream)
+ (print-unreadable-object (boff stream :type t)
+ (format stream "~A:~A"
+ (base-offset-class boff)
+ (sod-class-nickname (base-offset-chain-head boff)))))
+
+(defgeneric make-base-offset (class chain-head)
+ (:documentation
+ "Return the base offset object for CHAIN-HEAD ichain."))
+
+;;; chain-offset
+
+(defclass chain-offset ()
+ ((class :initarg :class :type sod-class :reader chain-offset-class)
+ (chain-head :initarg :chain-head
+ :type sod-class
+ :reader chain-offset-chain-head)
+ (target-head :initarg :target-head
+ :type sod-class
+ :reader chain-offset-target-head))
+ (:documentation
+ "The offset from the CHAIN-HEAD ichain to the TARGET-HEAD ichain."))
+
+(defmethod print-object ((choff chain-offset) stream)
+ (print-unreadable-object (choff stream :type t)
+ (format stream "~A:~A->~A"
+ (chain-offset-class choff)
+ (sod-class-nickname (chain-offset-chain-head choff))
+ (sod-class-nickname (chain-offset-target-head choff)))))
+
+(defgeneric make-chain-offset (class chain-head target-head)
+ (:documentation
+ "Return the offset from CHAIN-HEAD to TARGET-HEAD."))
+
+;;; vtable
+
+(defclass vtable ()
+ ((class :initarg :class :type sod-class :reader vtable-class)
+ (chain-head :initarg :chain-head
+ :type sod-class
+ :reader vtable-chain-head)
+ (body :initarg :body :type list :reader vtable-body))
+ (:documentation
+ "VTABLEs hold all of the per-chain static information for a class.
+
+ There is one vtable for each chain of each class. The vtables for a class
+ are prefixes of the corresponding chains of its subclasses.
+
+ Vtables contain method entry pointers, pointers to class objects, and
+ the offset information used for cross-chain slot access."))
+
+(defmethod print-object ((vtable vtable) stream)
+ (print-unreadable-object (vtable stream :type t)
+ (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
+ (vtable-class vtable)
+ (sod-class-nickname (vtable-chain-head vtable))
+ (vtable-body vtable))))
+
+(defgeneric compute-vtable (class chain)
+ (:documentation
+ "Compute the vtable layout for a chain of CLASS.
+
+ The CHAIN is a list of classes, with the least specific first."))
+
+(defgeneric compute-vtables (class)
+ (:documentation
+ "Compute the vtable layouts for CLASS.
+
+ Returns a list of VTABLE objects in the order of CLASS's chains."))
+
+;;; Implementation.
+
+(defmethod compute-vtmsgs
+ ((class sod-class)
+ (subclass sod-class)
+ (chain-head 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-instance 'vtmsgs
+ :class class
+ :subclass subclass
+ :chain-head chain-head
+ :entries (mapcar #'make-entry
+ (sod-class-messages class)))))
+
+(defmethod make-class-pointer
+ ((class sod-class) (chain-head sod-class)
+ (metaclass sod-class) (meta-chain-head sod-class))
+
+ ;; Slightly tricky. We don't necessarily want a pointer to the metaclass,
+ ;; but to its most specific subclass on the given chain. Fortunately, CL
+ ;; is good at this game.
+ (let* ((meta-chains (sod-class-chains metaclass))
+ (meta-chain-tails (mapcar #'car meta-chains))
+ (meta-chain-tail (find meta-chain-head meta-chain-tails
+ :key #'sod-class-chain-head)))
+ (make-instance 'class-pointer
+ :class class
+ :chain-head chain-head
+ :metaclass meta-chain-tail
+ :meta-chain-head meta-chain-head)))
+
+(defmethod make-base-offset ((class sod-class) (chain-head sod-class))
+ (make-instance 'base-offset
+ :class class
+ :chain-head chain-head))
+
+(defmethod make-chain-offset
+ ((class sod-class) (chain-head sod-class) (target-head sod-class))
+ (make-instance 'chain-offset
+ :class class
+ :chain-head chain-head
+ :target-head target-head))
+
+;; Special variables used by COMPUTE-VTABLE.
+(defvar *done-metaclass-chains*)
+(defvar *done-instance-chains*)
+
+(defgeneric compute-vtable-items (class super chain-head emit)
+ (:documentation
+ "Emit vtable items for a superclass of CLASS.
+
+ This function is called for each superclass SUPER of CLASS reached on the
+ chain headed by CHAIN-HEAD. The function should call EMIT for each
+ vtable item it wants to write.
+
+ The right way to check to see whether items have already been emitted
+ (e.g., has an offset to some other chain been emitted?) is as follows:
+
+ * In a method on COMPUTE-VTABLE, bind a special variable to an empty
+ list or hash table.
+
+ * In a method on this function, check the variable or hash table.
+
+ This function is the real business end of COMPUTE-VTABLE."))
+
+(defmethod compute-vtable-items
+ ((class sod-class) (super sod-class) (chain-head sod-class)
+ (emit function))
+
+ ;; If this class introduces new metaclass chains, then emit pointers to
+ ;; them.
+ (let* ((metasuper (sod-class-metaclass super))
+ (metasuper-chains (sod-class-chains metasuper))
+ (metasuper-chain-heads (mapcar (lambda (chain)
+ (sod-class-chain-head (car chain)))
+ metasuper-chains)))
+ (dolist (metasuper-chain-head metasuper-chain-heads)
+ (unless (member metasuper-chain-head *done-metaclass-chains*)
+ (funcall emit (make-class-pointer class
+ chain-head
+ metasuper
+ metasuper-chain-head))
+ (push metasuper-chain-head *done-metaclass-chains*))))
+
+ ;; If there are new instance chains, then emit offsets to them.
+ (let* ((chains (sod-class-chains super))
+ (chain-heads (mapcar (lambda (chain)
+ (sod-class-chain-head (car chain)))
+ chains)))
+ (dolist (head chain-heads)
+ (unless (member head *done-instance-chains*)
+ (funcall emit (make-chain-offset class chain-head head))
+ (push head *done-instance-chains*))))
+
+ ;; Finally, if there are interesting methods, emit those too.
+ (when (sod-class-messages super)
+ (funcall emit (compute-vtmsgs super class chain-head))))
+
+(defmethod compute-vtable ((class sod-class) (chain list))
+ (let* ((chain-head (car chain))
+ (*done-metaclass-chains* nil)
+ (*done-instance-chains* (list chain-head))
+ (done-superclasses nil)
+ (items nil))
+ (flet ((emit (item)
+ (push item items)))
+
+ ;; 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*))
+
+ ;; Write an offset to the instance base.
+ (emit (make-base-offset class chain-head))
+
+ ;; Now walk the chain. As we ascend the chain, scan the class
+ ;; precedence list of each class in reverse to ensure that we have
+ ;; everything interesting.
+ (dolist (super chain)
+ (dolist (sub (reverse (sod-class-precedence-list super)))
+ (unless (member sub done-superclasses)
+ (compute-vtable-items class
+ sub
+ chain-head
+ #'emit)
+ (push sub done-superclasses))))
+
+ ;; We're through.
+ (make-instance 'vtable
+ :class class
+ :chain-head chain-head
+ :body (nreverse items)))))
+
+(defgeneric compute-effective-methods (class)
+ (:documentation
+ "Return a list of all of the effective methods needed for CLASS.
+
+ The list needn't be in any particular order."))
+
+(defmethod compute-effective-methods ((class sod-class))
+ (mapcan (lambda (super)
+ (mapcar (lambda (message)
+ (compute-sod-effective-method message class))
+ (sod-class-messages super)))
+ (sod-class-precedence-list class)))
+
+(defmethod compute-vtables ((class sod-class))
+ (mapcar (lambda (chain)
+ (compute-vtable class (reverse chain)))
+ (sod-class-chains class)))
+
+;;;--------------------------------------------------------------------------
+;;; Names of things.
+
+(defun islots-struct-tag (class)
+ (format nil "~A__islots" class))
+
+(defun ichain-struct-tag (class chain-head)
+ (format nil "~A__ichain_~A" class(sod-class-nickname chain-head)))
+
+(defun ilayout-struct-tag (class)
+ (format nil "~A__ilayout" class))
+
+(defun vtmsgs-struct-tag (class super)
+ (format nil "~A__vtmsgs_~A" class (sod-class-nickname super)))
+
+(defun vtable-struct-tag (class chain-head)
+ (format nil "~A__vt_~A" class (sod-class-nickname chain-head)))
+
+(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 --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Output functions for classes
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Utility macro.
+
+(defmacro sequence-output
+ ((streamvar sequencer) &body clauses)
+ (let ((seqvar (gensym "SEQ")))
+ (labels ((convert-item-name (name)
+ (if (listp name)
+ (cons 'list name)
+ name))
+ (convert-constraint (constraint)
+ (cons 'list (mapcar #'convert-item-name constraint)))
+ (process-body (clauses)
+ (if (eq (car clauses) :constraint)
+ (cons `(add-sequencer-constraint
+ ,seqvar
+ ,(convert-constraint (cadr clauses)))
+ (process-body (cddr clauses)))
+ (mapcar (lambda (clause)
+ (let ((name (car clause))
+ (body (cdr clause)))
+ `(add-sequencer-item-function
+ ,seqvar
+ ,(convert-item-name name)
+ (lambda (,streamvar)
+ ,@body))))
+ clauses))))
+ `(let ((,seqvar ,sequencer))
+ ,@(process-body clauses)))))
+
+;;;--------------------------------------------------------------------------
+;;; Classes.
+
+(defmethod add-output-hooks progn
+ ((class sod-class) (reason (eql :h)) sequencer)
+
+ ;; Main output sequencing.
+ (sequence-output (stream sequencer)
+
+ :constraint
+ (:typedefs)
+
+ :constraint
+ ((:classes :start)
+ (class :banner)
+ (class :islots :start) (class :islots :slots) (class :islots :end)
+ (class :vtmsgs :start) (class :vtmsgs :end)
+ (class :vtables :start) (class :vtables :end)
+ (class :vtable-externs) (class :vtable-externs-after)
+ (class :direct-methods)
+ (class :ichains :start) (class :ichains :end)
+ (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
+ (class :conversions)
+ (:classes :end))
+
+ (:typedefs
+ (format stream "typedef struct ~A ~A;~%"
+ (ichain-struct-tag class (sod-class-chain-head class)) class))
+
+ ((class :banner)
+ (banner (format nil "Class ~A" class) stream))
+ ((class :vtable-externs-after)
+ (terpri stream)))
+
+ ;; Maybe generate an islots structure.
+ (when (sod-class-slots class)
+ (dolist (slot (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)))
+ ((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)
+ (terpri stream))))
+
+ ;; Provide upcast macros which do the right thing.
+ (when (sod-class-direct-superclasses class)
+ (sequence-output (stream sequencer)
+ ((class :conversions)
+ (let ((chain-head (sod-class-chain-head class)))
+ (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~])~%")
+ class (sod-class-nickname super) super
+ (eq chain-head super-head)
+ (sod-class-nickname super-head))))))))
+
+ ;; Generate vtmsgs structure for all superclasses.
+ (add-output-hooks (car (sod-class-vtables class))
+ 'populate-vtmsgs
+ sequencer))
+
+(defmethod add-output-hooks progn ((class sod-class) reason sequencer)
+ (with-slots (ilayout vtables) class
+ (add-output-hooks ilayout reason sequencer)
+ (dolist (vtable vtables) (add-output-hooks vtable reason sequencer))))
+
+;;;--------------------------------------------------------------------------
+;;; Instance structure.
+
+(defmethod add-output-hooks progn
+ ((slot sod-slot) (reason (eql 'populate-islots)) sequencer)
+ (sequence-output (stream sequencer)
+ (((sod-slot-class slot) :islots :slots)
+ (pprint-logical-block (stream nil :prefix " " :suffix ";")
+ (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
+ (terpri stream))))
+
+(defmethod add-output-hooks progn ((ilayout ilayout) reason sequencer)
+ (with-slots (ichains) ilayout
+ (dolist (ichain ichains) (add-output-hooks ichain reason sequencer))))
+
+(defmethod add-output-hooks progn
+ ((ilayout ilayout) (reason (eql :h)) sequencer)
+ (with-slots (class ichains) ilayout
+ (sequence-output (stream sequencer)
+ ((class :ilayout :start)
+ (format stream "struct ~A {~%" (ilayout-struct-tag class)))
+ ((class :ilayout :end)
+ (format stream "};~2%")))
+ (dolist (ichain ichains)
+ (add-output-hooks ichain 'populate-ilayout sequencer))))
+
+(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%")))))
+
+(defmethod add-output-hooks progn
+ ((ichain ichain) (reason (eql 'populate-ilayout)) sequencer)
+ (with-slots (class chain-head) ichain
+ (sequence-output (stream sequencer)
+ ((class :ilayout :slots)
+ (format stream " struct ~A ~A;~%"
+ (ichain-struct-tag class 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
+ (sequence-output (stream sequencer)
+ ((class :ichain chain-head :slots)
+ (format stream " const struct ~A *_vt;~%"
+ (vtable-struct-tag class chain-head))))))
+
+(defmethod add-output-hooks progn
+ ((islots islots) (reason (eql :h)) sequencer)
+ (with-slots (class subclass slots) islots
+ (sequence-output (stream sequencer)
+ ((subclass :ichain (sod-class-chain-head class) :slots)
+ (format stream " struct ~A ~A;~%"
+ (islots-struct-tag class)
+ (sod-class-nickname class))))))
+
+;;;--------------------------------------------------------------------------
+;;; Vtable structure.
+
+(defmethod add-output-hooks progn ((vtable vtable) reason sequencer)
+ (with-slots (body) vtable
+ (dolist (item body) (add-output-hooks item reason sequencer))))
+
+(defmethod add-output-hooks progn
+ ((vtable vtable) (reason (eql :h)) sequencer)
+ (with-slots (class chain-head) vtable
+ (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)
+ class (sod-class-nickname chain-head))))))
+
+(defmethod add-output-hooks progn
+ ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
+ (with-slots (class subclass chain-head) vtmsgs
+ (sequence-output (stream sequencer)
+ ((subclass :vtable chain-head :slots)
+ (format stream " struct ~A ~A;~%"
+ (vtmsgs-struct-tag subclass class)
+ (sod-class-nickname class))))))
+
+(defmethod add-output-hooks progn
+ ((vtmsgs vtmsgs) (reason (eql 'populate-vtmsgs)) sequencer)
+ (when (vtmsgs-entries vtmsgs)
+ (with-slots (class subclass) vtmsgs
+ (sequence-output (stream sequencer)
+ :constraint ((subclass :vtmsgs :start)
+ (subclass :vtmsgs class :start)
+ (subclass :vtmsgs class :slots)
+ (subclass :vtmsgs class :end)
+ (subclass :vtmsgs :end))
+ ((subclass :vtmsgs class :start)
+ (format stream "struct ~A {~%" (vtmsgs-struct-tag subclass class)))
+ ((subclass :vtmsgs class :end)
+ (format stream "};~2%"))))))
+
+(defmethod add-output-hooks progn ((vtmsgs vtmsgs) reason sequencer)
+ (with-slots (entries) vtmsgs
+ (dolist (entry entries) (add-output-hooks entry reason sequencer))))
+
+(defmethod add-output-hooks progn ((entry method-entry) reason sequencer)
+ (with-slots (method) entry
+ (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))
+ (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)))))))
+ (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)))
+ (terpri stream)))))
+
+(defmethod add-output-hooks progn
+ ((cptr class-pointer) (reason (eql :h)) sequencer)
+ (with-slots (class chain-head metaclass meta-chain-head) cptr
+ (sequence-output (stream sequencer)
+ ((class :vtable chain-head :slots)
+ (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
+ metaclass
+ (if (sod-class-direct-superclasses meta-chain-head)
+ (sod-class-nickname meta-chain-head)
+ nil))))))
+
+(defmethod add-output-hooks progn
+ ((boff base-offset) (reason (eql :h)) sequencer)
+ (with-slots (class chain-head) boff
+ (sequence-output (stream sequencer)
+ ((class :vtable chain-head :slots)
+ (write-line " size_t _base;" stream)))))
+
+(defmethod add-output-hooks progn
+ ((choff chain-offset) (reason (eql :h)) sequencer)
+ (with-slots (class chain-head target-head) choff
+ (sequence-output (stream sequencer)
+ ((class :vtable chain-head :slots)
+ (format stream " ptrdiff_t _off_~A;~%"
+ (sod-class-nickname target-head))))))
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
+
+#+test
+(defun test (name)
+ (let ((sequencer (make-instance 'sequencer))
+ (class (find-sod-class name)))
+ (add-output-hooks class :h sequencer)
+ (invoke-sequencer-items sequencer *standard-output*)
+ sequencer))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Code generator for effective methods
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Temporary names.
+
+(defclass temporary-name ()
+ ((tag :initarg :tag :reader temp-tag))
+ (:documentation
+ "Base class for temporary variable and argument names."))
+
+(defclass temporary-argument (temporary-name) ())
+(defclass temporary-function (temporary-name) ())
+
+(defclass temporary-variable (temporary-name)
+ ((in-use-p :initarg :in-use-p
+ :initform nil
+ :type boolean
+ :accessor var-in-use-p)))
+
+(defmethod var-in-use-p ((var t))
+ "Non-temporary variables are always in use."
+ t)
+
+(defmethod commentify-argument-name ((name temporary-name))
+ nil)
+
+(defparameter *temporary-index* 0
+ "Index for temporary name generation.
+
+ This is automatically reset to zero before the output functions are
+ invoked to write a file. This way, we can ensure that the same output
+ file is always produced from the same input.")
+
+(defun temporary-function ()
+ "Return a temporary function name."
+ (make-instance 'temporary-function
+ :tag (prog1 *temporary-index* (incf *temporary-index*))))
+
+(defgeneric format-temporary-name (var stream)
+ (:method ((var temporary-name) stream)
+ (format stream "~A" (temp-tag var)))
+ (:method ((var temporary-argument) stream)
+ (format stream "sod__a~A" (temp-tag var)))
+ (:method ((var temporary-variable) stream)
+ (format stream "sod__v~A" (temp-tag var)))
+ (:method ((var temporary-function) stream)
+ (format stream "sod__f~A" (temp-tag var))))
+
+(defmethod print-object ((var temporary-name) stream)
+ (if *print-escape*
+ (print-unreadable-object (var stream :type t)
+ (prin1 (temp-tag var) stream))
+ (format-temporary-name var stream)))
+
+(defparameter *sod-ap*
+ (make-instance 'temporary-name :tag "sod__ap"))
+(defparameter *sod-master-ap*
+ (make-instance 'temporary-name :tag "sod__master_ap"))
+
+;;;--------------------------------------------------------------------------
+;;; Instructions.
+
+(defclass inst () ()
+ (:documentation
+ "A base class for instructions.
+
+ An `instruction' is anything which might be useful to string into a code
+ generator. Both statements and expressions map can be represented by
+ trees of instructions. The DEFINST macro is a convenient way of defining
+ new instructions.
+
+ The only important protocol for instructions is output, which is achieved
+ by calling PRINT-OBJECT with *PRINT-ESCAPE* nil.
+
+ This doesn't really do very much, but it acts as a handy marker for
+ instruction subclasses."))
+
+(defgeneric inst-metric (inst)
+ (:documentation
+ "Returns a `metric' describing how complicated INST is.
+
+ The default metric of an inst node is simply 1; INST subclasses generated
+ by DEFINST (q.v.) have an automatically generated method which returns one
+ plus the sum of the metrics of the node's children.
+
+ This isn't intended to be a particularly rigorous definition. Its purpose
+ is to allow code generators to make decisions about inlining or calling
+ code fairly simply.")
+ (:method (inst) 1))
+
+(defmacro definst (code (streamvar) args &body body)
+ "Define an instruction type and describe how to output it.
+
+ An INST can represent any structured piece of output syntax: a statement,
+ expression or declaration, for example. This macro defines the following
+ things:
+
+ * A class CODE-INST to represent the instruction.
+
+ * Instance slots named after the ARGS, with matching keyword initargs,
+ and INST-ARG readers.
+
+ * A constructor MAKE-CODE-INST which accepts the ARGS (in order, not
+ with keywords) as arguments and returns a fresh instance.
+
+ * A print method, which prints a diagnostic dump if *PRINT-ESCAPE* is
+ set, or invokes the BODY (with STREAMVAR bound to the output stream)
+ otherwise. The BODY is expected to produce target code at this
+ point."
+
+ (let ((inst-var (gensym "INST"))
+ (class-name (symbolicate code '-inst))
+ (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword))
+ args)))
+ `(progn
+ (defclass ,class-name (inst)
+ ,(mapcar (lambda (arg key)
+ `(,arg :initarg ,key :reader ,(symbolicate 'inst- arg)))
+ args keys))
+ (defun ,(symbolicate 'make- code '-inst) (,@args)
+ (make-instance ',class-name ,@(mappend #'list keys args)))
+ (defmethod inst-metric ((,inst-var ,class-name))
+ (with-slots (,@args) ,inst-var
+ (+ 1 ,@(mapcar (lambda (arg) `(inst-metric ,arg)) args))))
+ (defmethod print-object ((,inst-var ,class-name) ,streamvar)
+ (with-slots (,@args) ,inst-var
+ (if *print-escape*
+ (print-unreadable-object (,inst-var ,streamvar :type t)
+ (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
+ ,@(mappend #'list keys args)))
+ (progn ,@body)))))))
+
+(defun format-compound-statement* (stream child morep thunk)
+ "Underlying function for FORMAT-COMPOUND-STATEMENT."
+ (cond ((typep child 'block-inst)
+ (funcall thunk stream)
+ (write-char #\space stream)
+ (princ child stream)
+ (when morep (write-char #\space stream)))
+ (t
+ (pprint-logical-block (stream nil)
+ (funcall thunk stream)
+ (write-char #\space stream)
+ (pprint-indent :block 2 stream)
+ (pprint-newline :linear stream)
+ (princ child stream)
+ (pprint-indent :block 0 stream)
+ (case morep
+ (:space
+ (write-char #\space stream)
+ (pprint-newline :linear stream))
+ (t
+ (pprint-newline :mandatory stream)))))))
+
+(defmacro format-compound-statement
+ ((stream child &optional morep) &body body)
+ "Format a compound statement to STREAM.
+
+ The introductory material is printed by BODY. The CHILD is formatted
+ properly according to whether it's a BLOCK-INST. If MOREP is true, then
+ allow for more stuff following the child."
+ `(format-compound-statement* ,stream ,child ,morep
+ (lambda (,stream) ,@body)))
+
+;;;--------------------------------------------------------------------------
+;;; Instruction types.
+
+;; Compound statements.
+
+(definst block (stream) (decls body)
+ (format stream "{~:@_~@< ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
+ decls body))
+
+(definst if (stream) (condition consequent alternative)
+ (format-compound-statement (stream consequent alternative)
+ (format stream "if (~A)" condition))
+ (when alternative
+ (format-compound-statement (stream alternative)
+ (write-string "else" stream))))
+
+(definst while (stream) (condition body)
+ (format-compound-statement (stream body)
+ (format stream "while (~A)" condition)))
+
+(definst do-while (stream) (body condition)
+ (format-compound-statement (stream body :space)
+ (write-string "do" stream))
+ (format stream "while (~A);" condition))
+
+;; Simple statements.
+
+(definst set (stream) (var expr)
+ (format stream "~@<~A = ~@_~2I~A;~:>" var expr))
+
+(definst return (stream) (expr)
+ (format stream "return~@[ (~A)~];" expr))
+
+(definst expr (stream) (expr)
+ (format stream "~A;" expr))
+
+;; Special varargs hacks.
+
+(definst va-start (stream) (ap arg)
+ (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))
+
+(definst va-copy (stream) (to from)
+ (format stream "va_copy(~@<~A, ~_~A~:>);" to from))
+
+(definst va-end (stream) (ap)
+ (format stream "va_end(~A);" ap))
+
+;; Declarations. These should appear at the heads of BLOCK-INSTs.
+
+(definst var (stream) (name type init)
+ (pprint-c-type type stream name)
+ (when init
+ (format stream " = ~A" init)))
+
+;; Expressions.
+
+(definst call (stream) (func args)
+ (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))
+
+;; Top level things.
+
+(definst function (stream) (name type body)
+ (pprint-logical-block (stream nil)
+ (pprint-c-type type stream name)
+ (format stream "~:@_~A~:@_~:@_" body)))
+
+;;;--------------------------------------------------------------------------
+;;; Code generator objects.
+
+(defclass basic-codegen ()
+ ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
+ (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
+ (temp-index :initarg :temp-index
+ :initform 0
+ :type fixnum
+ :accessor codegen-temp-index))
+ (:documentation
+ "Base class for code generator state.
+
+ This contains the bare essentials for supporting the EMIT-INST and
+ ENSURE-VAR protocols; see the documentation for those generic functions
+ for more details.
+
+ This class isn't abstract. A full CODEGEN object uses instances of this
+ to keep track of pending functions which haven't been completed yet.
+
+ Just in case that wasn't clear enough: this is nothing to do with the
+ BASIC language."))
+
+(defgeneric emit-inst (codegen inst)
+ (:documentation
+ "Add INST to the end of CODEGEN's list of instructions.")
+ (:method ((codegen basic-codegen) inst)
+ (push inst (codegen-insts codegen))))
+
+(defgeneric emit-insts (codegen insts)
+ (:documentation
+ "Add a list of INSTS to the end of CODEGEN's list of instructions.")
+ (:method ((codegen basic-codegen) insts)
+ (setf (codegen-insts codegen)
+ (revappend insts (codegen-insts codegen)))))
+
+(defgeneric ensure-var (codegen name type &optional init)
+ (:documentation
+ "Add a variable to CODEGEN's list.
+
+ The variable is called NAME (which should be comparable using EQUAL and
+ print to an identifier) and has the given TYPE. If INIT is present and
+ non-nil it is an expression INST used to provide the variable with an
+ initial value.")
+ (:method ((codegen basic-codegen) name type &optional init)
+ (let* ((vars (codegen-vars codegen))
+ (var (find name vars :key #'inst-name :test #'equal)))
+ (cond ((not var)
+ (setf (codegen-vars codegen)
+ (cons (make-var-inst name type init) vars)))
+ ((not (c-type-equal-p type (inst-type var)))
+ (error "(Internal) Redefining type for variable ~A." name)))
+ name)))
+
+(defclass codegen (basic-codegen)
+ ((functions :initform nil :type list :accessor codegen-functions)
+ (stack :initform nil :type list :accessor codegen-stack))
+ (:documentation
+ "A full-fat code generator which can generate and track functions.
+
+ This is the real deal. Subclasses may which to attach additional state
+ for convenience's sake, but this class is self-contained. It supports the
+ CODEGEN-PUSH, CODEGEN-POP and CODEGEN-POP-FUNCTION protocols."))
+
+(defgeneric codegen-push (codegen)
+ (:documentation
+ "Pushes the current code generation state onto a stack.
+
+ The state consists of the accumulated variables and instructions, i.e.,
+ what is representable by a BASIC-CODEGEN.")
+ (:method ((codegen codegen))
+ (with-slots (vars insts temp-index stack) codegen
+ (push (make-instance 'basic-codegen
+ :vars vars
+ :insts insts
+ :temp-index temp-index)
+ stack)
+ (setf vars nil insts nil temp-index 0))))
+
+(defgeneric codegen-pop (codegen)
+ (:documentation
+ "Pops a saved state off of the CODEGEN's stack.
+
+ Returns the newly accumulated variables and instructions as lists, as
+ separate values.")
+ (:method ((codegen codegen))
+ (with-slots (vars insts temp-index stack) codegen
+ (multiple-value-prog1
+ (values (nreverse vars) (nreverse insts))
+ (let ((sub (pop stack)))
+ (setf vars (codegen-vars sub)
+ insts (codegen-insts sub)
+ temp-index (codegen-temp-index sub)))))))
+
+(defgeneric codegen-add-function (codegen function)
+ (:documentation
+ "Adds a function to CODEGEN's list.
+
+ Actually, we're not picky: FUNCTION can be any kind of object that you're
+ willing to find in the list returned by CODEGEN-FUNCTIONS.")
+ (:method ((codegen codegen) function)
+ (with-slots (functions) codegen
+ (setf functions (nconc functions (list function))))))
+
+(defun codegen-build-function (codegen name type vars insts)
+ "Build a function and add it to CODEGEN's list.
+
+ Returns the function's name."
+ (codegen-add-function codegen
+ (make-function-inst name type
+ (make-block-inst vars insts)))
+ name)
+
+(defgeneric codegen-pop-function (codegen name type)
+ (:documentation
+ "Makes a function out of the completed code in CODEGEN.
+
+ The NAME can be any object you like. The TYPE should be a function type
+ object which includes argument names. The return value is the NAME.")
+ (:method ((codegen codegen) name type)
+ (multiple-value-bind (vars insts) (codegen-pop codegen)
+ (codegen-build-function codegen name type vars insts))))
+
+(defgeneric temporary-var (codegen type)
+ (:documentation
+ "Return the name of a temporary variable.
+
+ The temporary variable will have the given TYPE, and will be marked
+ in-use. You should clear the in-use flag explicitly when you've finished
+ with the variable -- or, better, use WITH-TEMPORARY-VAR to do the cleanup
+ automatically."))
+
+(defmethod temporary-var ((codegen basic-codegen) type)
+ (with-slots (vars temp-index) codegen
+ (or (find-if (lambda (var)
+ (and (not (var-in-use-p (inst-name var)))
+ (c-type-equal-p type (inst-type var))))
+ vars)
+ (let* ((name (make-instance 'temporary-variable
+ :tag (prog1 temp-index
+ (incf temp-index)))))
+ (push (make-var-inst name type nil) vars)
+ name))))
+
+(defmacro with-temporary-var ((codegen var type) &body body)
+ "Evaluate BODY with VAR bound to a temporary variable name.
+
+ During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
+ available for re-use."
+ `(let ((,var (temporary-var ,codegen ,type)))
+ (unwind-protect
+ (progn ,@body)
+ (setf (var-in-use-p ,var) nil))))
+
+;;;--------------------------------------------------------------------------
+;;; Code generation idioms.
+
+(defun deliver-expr (codegen target expr)
+ "Emit code to deliver the value of EXPR to the TARGET.
+
+ The TARGET may be one of the following.
+
+ * :VOID, indicating that the value is to be discarded. The expression
+ will still be evaluated.
+
+ * :VOID-RETURN, indicating that the value is to be discarded (as for
+ :VOID) and furthermore a `return' from the current function should be
+ forced after computing the value.
+
+ * :RETURN, indicating that the value is to be returned from the current
+ function.
+
+ * A variable name, indicating that the value is to be stored in the
+ variable.
+
+ In the cases of :RETURN, :VOID and :VOID-RETURN targets, it is valid for
+ EXPR to be nil; this signifies that no computation needs to be performed.
+ Variable-name targets require an expression."
+
+ (case target
+ (:return (emit-inst codegen (make-return-inst expr)))
+ (:void (when expr (emit-inst codegen (make-expr-inst expr))))
+ (:void-return (when expr (emit-inst codegen (make-expr-inst expr)))
+ (emit-inst codegen (make-return-inst nil)))
+ (t (emit-inst codegen (make-set-inst target expr)))))
+
+(defun convert-stmts (codegen target type func)
+ "Invoke FUNC to deliver a value to a non-:RETURN target.
+
+ FUNC is a function which accepts a single argument, a non-:RETURN target,
+ and generates statements which deliver a value (see DELIVER-EXPR) of the
+ specified TYPE to this target. In general, the generated code will have
+ the form
+
+ setup instructions...
+ (DELIVER-EXPR CODEGEN TARGET (compute value...))
+ cleanup instructions...
+
+ where the cleanup instructions are essential to the proper working of the
+ generated program.
+
+ CONVERT-STMTS will call FUNC to generate code, and arrange that its value
+ is correctly delivered to TARGET, regardless of what the TARGET is --
+ i.e., it lifts the restriction to non-:RETURN targets. It does this by
+ inventing a new temporary variable."
+
+ (case target
+ (:return (with-temporary-var (codegen var type)
+ (funcall func var)
+ (deliver-expr codegen target var)))
+ (:void-return (funcall func :void)
+ (emit-inst codegen (make-return-inst nil)))
+ (t (funcall func target))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Method combinations
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Common behaviour.
+
+(defclass simple-message (basic-message)
+ ()
+ (:documentation
+ "Base class for messages with `simple' method combinations.
+
+ A simple method combination is one which has only one method role other
+ than the `before', `after' and `around' methods provided by BASIC-MESSAGE.
+ We call these `primary' methods, and the programmer designates them by not
+ specifying an explicit role.
+
+ If the programmer doesn't define any primary methods then the effective
+ method is null -- i.e., the method entry pointer shows up as a null
+ pointer."))
+
+(defclass simple-effective-method (basic-effective-method)
+ ((primary-methods :initarg :primary-methods
+ :initform nil
+ :type list
+ :reader effective-method-primary-methods))
+ (:documentation
+ "Effective method counterpart to SIMPLE-MESSAGE."))
+
+(defgeneric primary-method-class (message)
+ (:documentation
+ "Return the name of the primary direct method class for MESSAGE."))
+
+(defgeneric simple-method-body (method codegen target)
+ (:documentation
+ "Generate the body of a simple effective method.
+
+ The function is invoked on an effective METHOD, with a CODEGEN to which it
+ should emit code delivering the method's value to TARGET."))
+
+(defmethod sod-message-method-class
+ ((message standard-message) (class sod-class) pset)
+ (if (get-property pset :role :keyword nil)
+ (call-next-method)
+ (primary-method-class message)))
+
+(defmethod shared-initialize :after
+ ((method simple-effective-method) slot-names &key direct-methods)
+ (declare (ignore slot-names))
+ (categorize (method direct-methods :bind ((role (sod-method-role method))))
+ ((primary (null role))
+ (before (eq role :before))
+ (after (eq role :after))
+ (around (eq role :around)))
+ (with-slots (primary-methods before-methods after-methods around-methods)
+ method
+ (setf primary-methods primary
+ before-methods before
+ after-methods (reverse after)
+ around-methods around))))
+
+(defmethod compute-effective-method-entry-functions
+ ((method standard-effective-method))
+ (if (effective-method-primary-methods method)
+ (call-next-method)
+ nil))
+
+(defmethod compute-effective-method-body
+ ((method simple-effective-method) codegen target)
+ (with-slots (message basic-argument-names primary-methods) method
+ (basic-effective-method-body codegen target method
+ (lambda (target)
+ (simple-method-body method
+ codegen
+ target)))))
+
+;;;--------------------------------------------------------------------------
+;;; Standard method combination.
+
+(defclass standard-message (simple-message)
+ ()
+ (:documentation
+ "Message class for standard method combination.
+
+ Standard method combination is a simple method combination where the
+ primary methods are invoked as a delegation chain, from most- to
+ least-specific."))
+
+(defclass standard-effective-method (simple-effective-method)
+ ()
+ (:documentation
+ "Effective method counterpart to STANDARD-MESSAGE."))
+
+(defmethod primary-method-class ((message standard-message))
+ 'delegating-direct-method)
+
+(defmethod message-effective-method-class ((message standard-message))
+ 'standard-effective-method)
+
+(defmethod simple-method-body
+ ((method standard-effective-method) codegen target)
+ (invoke-delegation-chain codegen
+ target
+ (effective-method-basic-argument-names method)
+ (effective-method-primary-methods method)
+ nil))
+
+;;;----- That's all, folks --------------------------------------------------
(labels ((superclasses (class)
(let ((direct-supers (sod-class-direct-superclasses class)))
(remove-duplicates (cons class
- (reduce #'append
- (mapcar #'superclasses
- direct-supers)
- :from-end t
- :initial-value nil))))))
+ (mappend #'superclasses
+ direct-supers))))))
(merge-lists (mapcar (lambda (class)
(cons class
(sod-class-direct-superclasses class)))
#+ecl #:clos)
(:export #:c-type
#:c-declarator-priority #:maybe-parenthesize
- #:c-declaration
+ #:pprint-c-type
#:c-type-subtype #:compount-type-declaration
#:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
#:simple-c-type #:c-type-name
(ldb t-byte flags) type)
flags))
+
+(defun expand-c-type (spec)
+ "Parse SPEC as a C type and return the result.
+
+ The SPEC can be one of the following.
+
+ * A C-TYPE object, which is returned immediately.
+
+ * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
+ function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
+ or some other means is invoked on the ARGUMENTS, and the result is
+ returned.
+
+ * A symbol, which is treated the same way as a singleton list would be."
+
+ (flet ((interp (sym)
+ (or (get sym 'c-type)
+ (error "Unknown C type operator ~S." sym))))
+ (etypecase spec
+ (c-type spec)
+ (symbol (funcall (interp spec)))
+ (list (apply (interp (car spec)) (cdr spec))))))
+
+(defmacro c-type (spec)
+ "Evaluates to the type that EXPAND-C-TYPE would return.
+
+ Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime. Maybe
+ later it will do something more clever."
+ `(expand-c-type ',spec))
+
+;; S-expression machinery. Qualifiers have hairy syntax and need to be
+;; implemented by hand.
+
+(defun qualifier (qual &rest args)
+ "Parse a qualified C type.
+
+ The ARGS consist of a number of qualifiers and exactly one C-type
+ S-expression. The result is a qualified version of this type, with the
+ given qualifiers attached."
+ (if (null args)
+ qual
+ (let* ((things (mapcar #'expand-c-type args))
+ (quals (delete-duplicates
+ (sort (cons qual (remove-if-not #'keywordp things))
+ #'string<)))
+ (types (remove-if-not (lambda (thing) (typep thing 'c-type))
+ things)))
+ (when (or (null types)
+ (not (null (cdr types))))
+ (error "Only one proper type expected in ~S." args))
+ (qualify-type (car types) quals))))
+(setf (get 'qualifier 'c-type) #'qualifier)
+
+(defun declare-qualifier (qual)
+ "Defines QUAL as being a type qualifier.
+
+ When used as a C-type operator, it applies that qualifier to the type that
+ is its argument."
+ (let ((kw (intern (string qual) :keyword)))
+ (setf (get qual 'c-type)
+ (lambda (&rest args)
+ (apply #'qualifier kw args)))))
+
+;; Define some initial qualifiers.
+(dolist (qual '(const volatile restrict))
+ (declare-qualifier qual))
+
+
+(define-c-type-syntax simple-c-type (name)
+ "Constructs a simple C type called NAME (a string or symbol)."
+ (make-simple-type (c-name-case name)))
+
+(defmethod print-c-type :around
+ (stream (type qualifiable-c-type) &optional colon atsign)
+ (if (c-type-qualifiers type)
+ (pprint-logical-block (stream nil :prefix "(" :suffix ")")
+ (format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
+ (c-type-qualifiers type))
+ (call-next-method stream type colon atsign))
+ (call-next-method)))
+;; S-expression syntax.
+
+
+(define-c-type-syntax enum (tag)
+ "Construct an enumeration type named TAG."
+ (make-instance 'c-enum-type :tag (c-name-case tag)))
+(define-c-type-syntax struct (tag)
+ "Construct a structure type named TAG."
+ (make-instance 'c-struct-type :tag (c-name-case tag)))
+(define-c-type-syntax union (tag)
+ "Construct a union type named TAG."
+ (make-instance 'c-union-type :tag (c-name-case tag)))
+
+(defgeneric make-me-argument (message class)
+ (:documentation
+ "Return an ARGUMENT object for the `me' argument to MESSAGE, as
+ specialized to CLASS."))
+
+(defmethod make-me-argument
+ ((message basic-message) (class sod-class))
+ (make-argument "me" (make-instance 'c-pointer-type
+ :subtype (sod-class-type class))))
--- /dev/null
+(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=)))
+
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Layout for instances and vtables
-;;;
-;;; (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)
-
-;;;--------------------------------------------------------------------------
-;;; Layout objects.
-
-(defclass effective-slot ()
- ((slot :initarg :slot :type sod-slot :reader slot-direct-slot)
- (initializer :initarg :initializer
- :type (or sod-initializer null)
- :reader slot-initializer)))
-
-(defclass islots ()
- ((class :initarg :class :type sod-class :reader islots-class)
- (slots :initarg :slots :type list :reader islots-slots)))
-
-(defclass ichain ()
- ((class :initarg :class :type sod-class :reader ichain-class)
- (chain :initarg :chain :type sod-class :reader ichain-chain)
- (body :initarg :body :type list :reader ichain-body)))
-
-(defclass ilayout ()
- ((class :initarg :class :type sod-class :reader ilayout-class)
- (ichains :initarg :ichains :type list :reader ilayout-ichains)))
-
-(defclass effective-method ()
- ((message :initarg :message :type sod-message :reader method-message)
- (class :initarg :class :type sod-class :reader method-class)))
-
-(defclass method-entry ()
- ((method :initarg :method
- :type effective-method
- :reader method-entry-effective-method)
- (ichain :initarg :chain :type ichain :reader method-entry-ichain)))
-
-(defclass vtmsgs ()
- ((class :initargs :class :type sod-class :reader vtmsgs-class)
- (body :initargs :body :type list :reader vtmsgs-body)))
-
-(defclass class-pointer ()
- ((metaclass :initarg :metaclass
- :type sod-class
- :reader class-pointer-metaclass)
- (ichain :initarg :chain :type ichain :reader class-pointer-ichain)))
-
-(defclass base-offset ()
- ((class :initargs :class :type sod-class :reader base-offset-class)
- (ichain :initargs :chain :type ichain :reader base-offset-ichain)))
-
-(defclass chain-offset ()
- ((class :initargs :class :type sod-class :reader chain-offset-class)
- (ichain :initargs :ichain :type ichain :reader chain-offset-ichain)
- (target :initargs :chain :type ichain :reader chain-offset-target)))
-
-(defclass vtable ()
- ((class :initargs :class :type sod-class :reader vtable-class)
- (ichain :initargs :ichain :type ichain :reader vtable-ichain)
- (body :initargs :body :type list :reader vtable-body)))
-
-;;;----- That's all, folks --------------------------------------------------
;; Words with important meanings to us.
"class"
"import" "load" "lisp" "typename"
- "source" "header"
+ "code"
+ "extern"
;; Words with a meaning to C's type system.
"char" "int" "float" "void"
;; Strings.
((or (char= ch #\") (char= ch #\'))
- (with-default-error-location (file-location lexer)
+ (with-default-error-location ((file-location lexer))
(let* ((quote ch)
(string
(with-output-to-string (out)
(flet ((getch ()
(setf ch (next-char lexer))
(when (null ch)
- (cerror* floc
+ (cerror*
"Unexpected end of file in string/character constant")
(return))))
(getch)
;; If we last munched an interesting letter, we need to skip over
;; it. That's what the SKIP-CHAR flag is for.
+ ;;
+ ;; Danger, Will Robinson! If we're' just about to eat a radix
+ ;; letter, then the next thing must be a digit. For example,
+ ;; `0xfatenning' parses as a hex number followed by an identifier
+ ;; `0xfa ttening', but `0xturning' is an octal number followed
+ ;; by an identifier `0 xturning'.
(when skip-char
- (setf ch (next-char lexer)))
+ (let ((peek (next-char lexer)))
+ (unless (digit-char-p peek radix)
+ (pushback-char lexer ch)
+ (return-from scan-token (values :integer 0)))
+ (setf ch peek)))
;; Scan an integer. While there are digits, feed them into the
;; accumulator.
A C fragment is aware of its original location, and will bear proper #line
markers when written out."))
-(defgeneric write-fragment (fragment stream)
- (:documentation
- "Writes a fragment to the output stream, marking its source properly.")
-
- (:method ((fragment c-fragment) stream)
- (with-slots (location text) fragment
- (format stream "~&#line ~D ~S~%~A~&"
- (file-location-line location)
- (namestring (file-location-pathname location))
- text)
- (format stream "#line ~D ~S~%"
- (1+ (position-aware-stream-line stream))
- (namestring (stream-pathname stream))))))
+(defun output-c-excursion (stream location thunk)
+ "Invoke THUNK surrounding it by writing #line markers to STREAM.
+
+ The first marker describes LOCATION; the second refers to the actual
+ output position in STREAM. If LOCATION doesn't provide a line number then
+ no markers are output after all. If the output stream isn't
+ position-aware then no final marker is output."
+
+ (let* ((location (file-location location))
+ (line (file-location-line location))
+ (pathname (file-location-pathname location))
+ (namestring (and pathname (namestring pathname))))
+ (cond (line
+ (format stream "~&#line ~D~@[ ~S~]~%" line namestring)
+ (funcall thunk)
+ (when (typep stream 'position-aware-stream)
+ (fresh-line stream)
+ (format stream "~&#line ~D ~S~%"
+ (1+ (position-aware-stream-line stream))
+ (namestring (stream-pathname stream)))))
+ (t
+ (funcall thunk)))))
+
+(defmethod print-object ((fragment c-fragment) stream)
+ (let ((text (c-fragment-text fragment))
+ (location (c-fragment-location fragment)))
+ (if *print-escape*
+ (print-unreadable-object (fragment stream :type t)
+ (when location
+ (format stream "~A " location))
+ (cond ((< (length text) 40)
+ (prin1 text stream) stream)
+ (t
+ (prin1 (subseq text 0 40) stream)
+ (write-string "..." stream))))
+ (output-c-excursion stream location
+ (lambda () (write-string text stream))))))
+
+(defmethod make-load-form ((fragment c-fragment) &optional environment)
+ (make-load-form-saving-slots fragment :environment environment))
(defun scan-c-fragment (lexer end-chars)
"Snarfs a sequence of C tokens with balanced brackets.
;; Return the fragment we've collected.
(make-instance 'c-fragment
- :location floc
+ :location start-floc
:text (get-output-stream-string output)))))
(defun c-fragment-reader (stream char arg)
(next-char lexer)
(scan-c-fragment lexer '(#\}))))
+#+interactive
+(set-dispatch-macro-character #\# #\{ 'c-fragment-reader)
+
;;;--------------------------------------------------------------------------
;;; Testing cruft.
(with-input-from-string (in "
{ foo } 'x' /?/***/!
123 0432 0b010123 0xc0ffee __burp_32 class
+
+0xturning 0xfattening
...
class integer : integral_domain {
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Infrastructure for effective method generation
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Function type protocol.
+
+(defgeneric sod-message-argument-tail (message)
+ (:documentation
+ "Return the argument tail for the message, with invented argument names.
+
+ No `me' argument is prepended; any :ELLIPSIS is left as it is."))
+
+(defgeneric sod-message-no-varargs-tail (message)
+ (:documentation
+ "Return the argument tail for the message with :ELLIPSIS substituted.
+
+ As with SOD-MESSAGE-ARGUMENT-TAIL, no `me' argument is prepended.
+ However, an :ELLIPSIS is replaced by an argument of type `va_list', named
+ `sod__ap'."))
+
+(defgeneric direct-method-function-type (method)
+ (:documentation
+ "Return the C function type for the direct method.
+
+ This is called during initialization of a direct method object, and the
+ result is cached.
+
+ A default method is provided (by BASIC-DIRECT-METHOD) which simply
+ 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)
+ (:documentation
+ "Return the C function type for the next-method trampoline.
+
+ This is called during initialization of a direct method object, and the
+ result is cached. It should return a function type, not a pointer type.
+
+ A default method is provided (by DELEGATING-DIRECT-METHOD) which should do
+ the right job. Very fancy subclasses might need to do something
+ different."))
+
+(defgeneric direct-method-function-name (method)
+ (:documentation
+ "Return the C function name for the direct method."))
+
+;;;--------------------------------------------------------------------------
+;;; Message classes.
+
+(defclass basic-message (sod-message)
+ ((argument-tail :type list :reader sod-message-argument-tail)
+ (no-varargs-tail :type list :reader sod-message-no-varargs-tail))
+ (:documentation
+ "Base class for built-in message classes.
+
+ Provides the basic functionality for the built-in method combinations.
+ This is a separate class so that `special effect' messages can avoid
+ inheriting its default behaviour.
+
+ The function type protocol is implemented on BASIC-MESSAGE using slot
+ reader methods. The actual values are computed on demand in methods
+ defined on SLOT-UNBOUND."))
+
+;;; Function type protocol.
+
+(defmethod slot-unbound (class
+ (message basic-message)
+ (slot-name (eql 'argument-tail)))
+ (let ((seq 0))
+ (mapcar (lambda (arg)
+ (if (or (eq arg :ellipsis) (argument-name arg))
+ arg
+ (make-argument (make-instance 'temporary-argument
+ :tag (prog1 seq (incf seq)))
+ (argument-type arg))))
+ (c-function-arguments (sod-message-type message)))))
+
+(defmethod slot-unbound (class
+ (message basic-message)
+ (slot-name (eql 'no-varargs-tail)))
+ (mapcar (lambda (arg)
+ (if (eq arg :ellipsis)
+ (make-argument *sod-ap* (c-type va-list))
+ arg))
+ (sod-message-argument-tail message)))
+
+;;; Method class selection.
+
+(defmethod sod-message-method-class
+ ((message basic-message) (class sod-class) pset)
+ (let ((role (get-property pset :role :keyword nil)))
+ (case role
+ ((:before :after) 'daemon-direct-method)
+ (:around 'delegating-direct-method)
+ ((nil) (error "How odd: a primary method slipped through the net"))
+ (t (error "Unknown method role ~A" role)))))
+
+;;; Utility functions.
+
+(defun varargs-message-p (message)
+ "Answer whether the MESSAGE accepts a variable-length argument list.
+
+ We need to jump through some extra hoops in order to cope with varargs
+ messages, so this is useful to know."
+ (member :ellipsis (sod-message-argument-tail message)))
+
+;;;--------------------------------------------------------------------------
+;;; Direct method classes.
+
+(defclass basic-direct-method (sod-method)
+ ((role :initarg :role
+ :type symbol
+ :reader sod-method-role)
+ (function-type :type c-function-type
+ :reader sod-method-function-type))
+ (:documentation
+ "Base class for built-in direct method classes.
+
+ Provides the basic functionality for the built-in direct-method classes.
+ This is a separate class so that `special effect' methods can avoid
+ inheriting its default behaviour and slots.
+
+ A basic method can be assigned a `role', which may be set either as an
+ initarg or using the :ROLE property. Roles are used for method
+ categorization.
+
+ The function type protocol is implemented on BASIC-DIRECT-METHOD using
+ slot reader methods. The actual values are computed on demand in methods
+ defined on SLOT-UNBOUND."))
+
+(defmethod shared-initialize :after
+ ((method basic-direct-method) slot-names &key pset)
+ (declare (ignore slot-names))
+ (default-slot (method 'role) (get-property pset :role :keyword nil)))
+
+(defmethod slot-unbound
+ (class (method basic-direct-method) (slot-name (eql 'function-type)))
+ (let ((type (sod-method-type method)))
+ (setf (slot-value method 'function-type)
+ (c-type (fun (lisp (c-type-subtype type))
+ ("me" (* (class (sod-method-class method))))
+ . (c-function-arguments type))))))
+
+(defmethod direct-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))
+ (sod-message-name message))))
+
+(defclass daemon-direct-method (basic-direct-method)
+ ()
+ (:documentation
+ "A daemon direct method is invoked for side effects and cannot override.
+
+ This is the direct method class for `before' and `after' methods, which
+ cannot choose to override the remaining methods and are not involved in
+ the computation of the final result.
+
+ In C terms, a daemon method must return `void', and is not passed a
+ `next_method' pointer."))
+
+(defmethod check-method-type
+ ((method daemon-direct-method)
+ (message sod-message)
+ (type c-function-type))
+ (with-slots ((msgtype type)) message
+ (unless (c-type-equal-p (c-type-subtype type) (c-type void))
+ (error "Method return type ~A must be `void'" (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))))
+
+(defclass delegating-direct-method (basic-direct-method)
+ ((next-method-type :type c-function-type
+ :reader sod-method-next-method-type))
+ (:documentation
+ "A delegating direct method can choose to override other methods.
+
+ This is the direct method class for `around' and standard-method-
+ combination primary methods, which are given the choice of computing the
+ entire method's result or delegating to (usually) less-specific methods.
+
+ In C terms, a delegating method is passed a `next_method' pointer so that
+ it can delegate part of its behaviour. (A delegating direct method for a
+ varargs message is also given an additional `va_list' argument,
+ conventionally named `sod__ap_master', which it is expected to pass on to
+ its `next_method' function if necessary.)
+
+ The function type protocol is implemented on DELEGATING-DIRECT-METHOD
+ using slot reader methods. The actual values are computed on demand in
+ methods defined on SLOT-UNBOUND."))
+
+(defmethod slot-unbound (class
+ (method delegating-direct-method)
+ (slot-name (eql 'next-method-type)))
+ (let* ((message (sod-method-message method))
+ (type (sod-message-type message)))
+ (setf (slot-value method 'next-method-type)
+ (c-type (fun (lisp (c-type-subtype type))
+ ("me" (* (class (sod-method-class method))))
+ . (c-function-arguments type))))))
+
+(defmethod slot-unbound (class
+ (method delegating-direct-method)
+ (slot-name (eql 'function-type)))
+ (let* ((message (sod-method-message method))
+ (type (sod-method-type method))
+ (method-args (c-function-arguments type)))
+ (setf (slot-value method 'function-type)
+ (c-type (fun (lisp (c-type-subtype type))
+ ("me" (* (class (sod-method-class method))))
+ ("next_method" (* (lisp (commentify-function-type
+ (sod-method-next-method-type
+ method)))))
+ . (if (varargs-message-p message)
+ (cons (make-argument *sod-master-ap*
+ (c-type va-list))
+ method-args)
+ method-args))))))
+
+;;;--------------------------------------------------------------------------
+;;; Effective method classes.
+
+(defgeneric effective-method-basic-argument-names (method)
+ (:documentation
+ "Return a list of argument names to be passed to direct methods.
+
+ The argument names are constructed from the message's arguments returned
+ by SOD-MESSAGE-NO-VARARGS-TAIL. The basic arguments are the ones
+ immediately derived from the programmer's explicitly stated arguments; the
+ `me' argument is not included, and neither are more exotic arguments added
+ as part of the method delegation protocol."))
+
+(defclass basic-effective-method (effective-method)
+ ((around-methods :initarg :around-methods
+ :initform nil
+ :type list
+ :reader effective-method-around-methods)
+ (before-methods :initarg :before-methods
+ :initform nil
+ :type list
+ :reader effective-method-before-methods)
+ (after-methods :initarg :after-methods
+ :initform nil
+ :type list
+ :reader effective-method-after-methods)
+ (basic-argument-names :type list
+ :reader effective-method-basic-argument-names)
+ (functions :type list :reader effective-method-functions))
+ (:documentation
+ "Base class for built-in effective method classes.
+
+ This class maintains lists of the applicable `before', `after' and
+ `around' methods and provides behaviour for invoking these methods
+ correctly.
+
+ The argument names protocol is implemented on BASIC-EFFECTIVE-METHOD using
+ a slot reader method. The actual values are computed on demand in methods
+ defined on SLOT-UNBOUND."))
+
+(defmethod slot-unbound (class
+ (method basic-effective-method)
+ (slot-name (eql 'basic-argument-names)))
+ (let ((message (effective-method-message method)))
+ (setf (slot-value method 'basic-argument-names)
+ (subst *sod-master-ap* *sod-ap*
+ (mapcar #'argument-name
+ (sod-message-no-varargs-tail message))))))
+
+;;;--------------------------------------------------------------------------
+;;; Method categorization.
+
+(defmacro categorize ((itemvar items &key bind) categories &body body)
+ "Categorize ITEMS into lists and invoke BODY.
+
+ The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR
+ will contain the current item. The BIND argument is a list of LET*-like
+ clauses. The CATEGORIES are a list of clauses of the form (SYMBOL
+ PREDICATE).
+
+ The behaviour of the macro is as follows. ITEMVAR is assigned (not
+ bound), in turn, each item in the list ITEMS. The PREDICATEs in the
+ CATEGORIES list are evaluated in turn, in an environment containing
+ ITEMVAR and the BINDings, until one of them evaluates to a non-nil value.
+ At this point, the item is assigned to the category named by the
+ corresponding SYMBOL. If none of the PREDICATEs returns non-nil then an
+ error is signalled; a PREDICATE consisting only of T will (of course)
+ match anything; it is detected specially so as to avoid compiler warnings.
+
+ Once all of the ITEMS have been categorized in this fashion, the BODY is
+ evaluated as an implicit PROGN. For each SYMBOL naming a category, a
+ variable named after that symbol will be bound in the BODY's environment
+ to a list of the items in that category, in the same order in which they
+ were found in the list ITEMS. The final values of the macro are the final
+ values of the BODY."
+
+ (let* ((cat-names (mapcar #'car categories))
+ (cat-match-forms (mapcar #'cadr categories))
+ (cat-vars (mapcar (lambda (name) (gensym (symbol-name name)))
+ cat-names))
+ (items-var (gensym "ITEMS")))
+ `(let ((,items-var ,items)
+ ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
+ (dolist (,itemvar ,items-var)
+ (let* ,bind
+ (cond ,@(mapcar (lambda (cat-match-form cat-var)
+ `(,cat-match-form
+ (push ,itemvar ,cat-var)))
+ cat-match-forms cat-vars)
+ ,@(and (not (member t cat-match-forms))
+ `((t (error "Failed to categorize ~A" ,itemvar)))))))
+ (let ,(mapcar (lambda (name var)
+ `(,name (nreverse ,var)))
+ cat-names cat-vars)
+ ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Code generation.
+
+(defclass method-codegen (codegen)
+ ((message :initarg :message :type sod-message :reader codegen-message)
+ (class :initarg :class :type sod-class :reader codegen-class)
+ (method :initarg :method :type effective-method :reader codegen-method)
+ (target :initarg :target :reader codegen-target))
+ (:documentation
+ "Augments CODEGEN with additional state regarding an effective method.
+
+ We store the effective method, and also its target class and owning
+ message, so that these values are readily available to the code-generating
+ functions."))
+
+(defmethod shared-initialize :after
+ ((codegen method-codegen) slot-names &key)
+ (with-slots (message target) codegen
+ (setf target
+ (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
+ :void
+ :return))))
+
+(defgeneric compute-effective-method-body (method codegen target)
+ (:documentation
+ "Generates the body of an effective method.
+
+ Writes the function body to the code generator. It can (obviously)
+ generate auxiliary functions if it needs to.
+
+ The arguments are as specified by the SOD-MESSAGE-NO-VARARGS-TAIL, with an
+ additional argument `sod__obj' of type pointer-to-ilayout. The code
+ should deliver the result (if any) to the TARGET."))
+
+(defun invoke-method (codegen target arguments-tail direct-method)
+ "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL.
+
+ The code is generated in the context of CODEGEN, which can be any instance
+ of the CODEGEN class -- it needn't be an instance of METHOD-CODEGEN. The
+ DIRECT-METHOD is called with the given ARGUMENTS-TAIL (a list of argument
+ expressions), preceded by a `me' argument of type pointer-to-CLASS where
+ CLASS is the class on which the method was defined.
+
+ If the message accepts a variable-length argument list then a copy of the
+ prevailing master argument pointer is provided in place of the :ELLIPSIS."
+
+ (let* ((message (sod-method-message direct-method))
+ (class (sod-method-class direct-method))
+ (function (direct-method-function-name direct-method))
+ (arguments (cons (format nil "(~A *)&sod__obj.~A" class
+ (sod-class-nickname
+ (sod-class-chain-head class)))
+ arguments-tail)))
+ (if (varargs-message-p message)
+ (convert-stmts codegen target
+ (c-type-subtype (sod-method-type direct-method))
+ (lambda (var)
+ (ensure-var codegen *sod-ap* (c-type va-list))
+ (emit-inst codegen
+ (make-va-copy-inst *sod-ap*
+ *sod-master-ap*))
+ (deliver-expr codegen var
+ (make-call-inst function arguments))
+ (emit-inst codegen
+ (make-va-end-inst *sod-ap*))))
+ (deliver-expr codegen target (make-call-inst function arguments)))))
+
+(definst convert-to-ilayout (stream) (class chain-head expr)
+ (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
+ class (sod-class-nickname chain-head) expr))
+
+(defun ensure-ilayout-var (codegen super)
+ "Define a variable `sod__obj' pointing to the class's ilayout structure.
+
+ CODEGEN is a METHOD-CODEGEN. The class in question is CODEGEN's class,
+ i.e., the target class for the effective method. SUPER is one of the
+ class's superclasses; it is assumed that `me' is a pointer to a SUPER
+ (i.e., to SUPER's ichain within the ilayout)."
+
+ (let* ((class (codegen-class codegen))
+ (super-head (sod-class-chain-head super)))
+ (ensure-var codegen "sod__obj"
+ (c-type (* (struct (ilayout-struct-tag class))))
+ (make-convert-to-ilayout-inst class super-head "me"))))
+
+(defun make-trampoline (codegen super body)
+ "Construct a trampoline function and return its name.
+
+ CODEGEN is a METHOD-CODEGEN. SUPER is a superclass of the CODEGEN class.
+ We construct a new trampoline function (with an unimaginative name)
+ suitable for being passed to a direct method defined on SUPER as its
+ `next_method'. In particular, it will have a `me' argument whose type is
+ pointer-to-SUPER.
+
+ The code of the function is generated by BODY, which will be invoked with
+ a single argument which is the TARGET to which it should deliver its
+ result.
+
+ The return value is the name of the generated function."
+
+ (let* ((message (codegen-message codegen))
+ (message-type (sod-message-type message))
+ (return-type (c-type-subtype message-type))
+ (arguments (mapcar (lambda (arg)
+ (if (eq (argument-name arg) *sod-ap*)
+ (make-argument *sod-master-ap*
+ (c-type va-list))
+ arg))
+ (sod-message-no-varargs-tail message))))
+ (codegen-push codegen)
+ (ensure-ilayout-var codegen super)
+ (funcall body (codegen-target codegen))
+ (codegen-pop-function codegen (temporary-function)
+ (c-type (fun (lisp return-type)
+ ("me" (* (class super)))
+ . arguments))))))
+
+(defun invoke-delegation-chain (codegen target basic-tail chain kernel)
+ "Invoke a chain of delegating methods.
+
+ CODEGEN is a METHOD-CODEGEN. BASIC-TAIL is a list of argument expressions
+ to provide to the methods. The result of the delegation chain will be
+ delivered to TARGET.
+
+ The CHAIN is a list of DELEGATING-DIRECT-METHOD objects. The behaviour is
+ as follows. The first method in the chain is invoked with the necessary
+ arguments (see below) including a `next_method' pointer. If KERNEL is nil
+ and there are no more methods in the chain then the `next_method' pointer
+ will be null; otherwise it will point to a `trampoline' function, whose
+ behaviour is to call the remaining methods on the chain as a delegation
+ chain. The method may choose to call this function with its arguments.
+ It will finally return a value, which will be delivered to the TARGET.
+
+ If the chain is empty, then the code generated by KERNEL (given a TARGET
+ argument) will be invoked. It is an error if both CHAIN and KERNEL are
+ nil."
+
+ (let* ((message (codegen-message codegen))
+ (argument-tail (if (varargs-message-p message)
+ (cons *sod-master-ap* basic-tail)
+ basic-tail)))
+ (labels ((next-trampoline (method chain)
+ (if (or kernel chain)
+ (make-trampoline codegen (sod-method-class method)
+ (lambda (target)
+ (invoke chain target)))
+ 0))
+ (invoke (chain target)
+ (if (null chain)
+ (funcall kernel target)
+ (let* ((trampoline (next-trampoline (car chain)
+ (cdr chain))))
+ (invoke-method codegen target
+ (cons trampoline argument-tail)
+ (car chain))))))
+ (invoke chain target))))
+
+(defun basic-effective-method-body (codegen target method body)
+ "Build the common method-invocation structure.
+
+ Writes to CODEGEN some basic method-invocation instructions. It invokes
+ the `around' methods, from most- to least-specific. If they all delegate,
+ then the `before' methods are run, most-specific first; next, the
+ instructions generated by BODY (invoked with a target argument); then, the
+ `after' methods are run, least-specific first; and, finally, the value
+ delivered by the BODY is returned to the `around' methods. The result
+ returned by the outermost `around' method -- or, if there are none,
+ delivered by the BODY -- is finally delivered to the TARGET."
+
+ (with-slots (message class before-methods after-methods around-methods)
+ method
+ (let* ((message-type (sod-message-type message))
+ (return-type (c-type-subtype message-type))
+ (voidp (eq return-type (c-type void)))
+ (basic-tail (effective-method-basic-argument-names method)))
+ (flet ((method-kernel (target)
+ (dolist (before before-methods)
+ (invoke-method codegen :void basic-tail before))
+ (if (or voidp (null after-methods))
+ (funcall body target)
+ (convert-stmts codegen target return-type
+ (lambda (target)
+ (funcall body target)
+ (dolist (after (reverse after-methods))
+ (invoke-method codegen :void
+ after basic-tail)))))))
+ (invoke-delegation-chain codegen target basic-tail
+ around-methods #'method-kernel)))))
+
+;;;--------------------------------------------------------------------------
+;;; Effective method entry points.
+
+(defgeneric compute-method-entry-functions (method)
+ (:documentation
+ "Construct method entry functions.
+
+ Builds the effective method function (if there is one) and the necessary
+ 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
+ "Threshold below which effective method bodies are inlined into entries.
+
+ After the effective method body has been computed, we calculate its
+ metric, multiply by the number of entries we need to generate, and compare
+ it with this threshold. If the metric is below the threshold then we
+ fold the method body into the entry functions; otherwise we split the
+ effective method out into its own function.")
+
+(defgeneric effective-method-function-name (method)
+ (:documentation
+ "Returns the function name of an effective method."))
+
+(defgeneric method-entry-function-name (method chain-head)
+ (:documentation
+ "Returns the function name of a method entry.
+
+ The method entry is given as an effective method/chain-head pair, rather
+ than as a method entry object because we want the function name before
+ we've made the entry object."))
+
+(defmethod effective-method-function-name ((method effective-method))
+ (let* ((class (effective-method-class method))
+ (message (effective-method-message method))
+ (message-class (sod-message-class message)))
+ (format nil "~A__emethod_~A__~A"
+ class
+ (sod-class-nickname message-class)
+ (sod-message-name message))))
+
+(defmethod method-entry-function-name
+ ((method effective-method) (chain-head sod-class))
+ (let* ((class (effective-method-class method))
+ (message (effective-method-message method))
+ (message-class (sod-message-class message)))
+ (format nil "~A__mentry_~A__~A__~A"
+ class
+ (sod-class-nickname message-class)
+ (sod-message-name message)
+ (sod-class-nickname chain-head))))
+
+(defmethod compute-method-entry-functions ((method basic-effective-method))
+
+ ;; OK, there's quite a lot of this, so hold tight.
+ ;;
+ ;; The first thing we need to do is find all of the related objects. This
+ ;; is a bit verbose but fairly straightforward.
+ ;;
+ ;; Next, we generate the effective method body -- using COMPUTE-EFFECTIVE-
+ ;; METHOD-BODY of all things. This gives us the declarations and body for
+ ;; an effective method function, but we don't have an actual function yet.
+ ;;
+ ;; Now we look at the chains which are actually going to need a method
+ ;; entry: only those chains whose tail (most specific) class is a
+ ;; superclass of the class which defined the message need an entry. We
+ ;; build a list of these tail classes.
+ ;;
+ ;; Having done this, we decide whether it's better to generate a standalone
+ ;; effective-method function and call it from each of the method entries,
+ ;; or to inline the effective method body into each of the entries.
+ ;;
+ ;; Most of the complexity here comes from (a) dealing with the two
+ ;; different strategies for constructing method entry functions and (b)
+ ;; (unsurprisingly) the mess involved with dealing with varargs messages.
+
+ (let* ((message (effective-method-message method))
+ (class (effective-method-class method))
+ (message-class (sod-message-class message))
+ (return-type (c-type-subtype (sod-message-type message)))
+ (codegen (make-instance 'method-codegen
+ :message message
+ :class class
+ :method method))
+
+ ;; Effective method function details.
+ (emf-name (effective-method-function-name method))
+ (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
+ (emf-arg-tail (mapcar (lambda (arg)
+ (if (eq (argument-name arg) *sod-ap*)
+ (make-argument *sod-master-ap*
+ (c-type va-list))
+ arg))
+ (sod-message-no-varargs-tail message)))
+ (emf-type (c-type (fun (lisp return-type)
+ ("sod__obj" (lisp ilayout-type))
+ . (sod-message-no-varargs-tail message))))
+ (result (if (eq return-type (c-type void)) nil
+ (temporary-var codegen return-type)))
+ (emf-target (or result :void))
+
+ ;; Method entry details.
+ (chain-tails (remove-if-not (lambda (super)
+ (sod-subclass-p super message-class))
+ (mapcar #'car
+ (sod-class-chains class))))
+ (n-entries (length chain-tails))
+ (entry-args (sod-message-argument-tail message))
+ (parm-n (do ((prev "me" (car args))
+ (args entry-args (cdr args)))
+ ((endp args) nil)
+ (when (eq (car args) :ellipsis)
+ (return prev))))
+ (entry-target (codegen-target codegen)))
+
+ (labels ((setup-entry (tail)
+ (let ((head (sod-class-chain-head tail)))
+ (codegen-push codegen)
+ (ensure-var codegen "sod__obj" ilayout-type
+ (make-convert-to-ilayout-inst class
+ head "me"))))
+ (varargs-prologue ()
+ (ensure-var codegen *sod-master-ap* (c-type va-list))
+ (emit-inst codegen
+ (make-va-start-inst *sod-master-ap* parm-n)))
+ (varargs-epilogue ()
+ (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
+ (finish-entry (tail)
+ (let* ((head (sod-class-chain-head tail))
+ (name (method-entry-function-name method head))
+ (type (c-type (fun (lisp return-type)
+ ("me" (* (class tail)))
+ . entry-args))))
+ (codegen-pop-function codegen name type))))
+
+ ;; Generate the method body. We'll work out what to do with it later.
+ (codegen-push codegen)
+ (compute-effective-method-body method codegen emf-target)
+ (multiple-value-bind (vars insts) (codegen-pop codegen)
+ (cond ((or (= n-entries 1)
+ (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
+ *method-entry-inline-threshold*))
+
+ ;; The effective method body is simple -- or there's only one
+ ;; of them. We'll inline the method body into the entry
+ ;; functions.
+ (dolist (tail chain-tails)
+ (setup-entry tail)
+ (dolist (var vars)
+ (ensure-var codegen (inst-name var)
+ (inst-type var) (inst-init var)))
+ (when parm-n (varargs-prologue))
+ (emit-insts codegen insts)
+ (when parm-n (varargs-epilogue))
+ (deliver-expr codegen entry-target result)
+ (finish-entry tail)))
+
+ (t
+
+ ;; The effective method body is complicated and we'd need more
+ ;; than one copy. We'll generate an effective method function
+ ;; and call it a lot.
+ (codegen-build-function codegen emf-name emf-type vars
+ (nconc insts (and result (list (make-return-inst result)))))
+
+ (let ((call (make-call-inst emf-name
+ (cons "sod__obj" (mapcar #'argument-name
+ emf-arg-tail)))))
+ (dolist (tail chain-tails)
+ (setup-entry tail)
+ (cond (parm-n
+ (varargs-prologue)
+ (convert-stmts codegen entry-target return-type
+ (lambda (target)
+ (deliver-expr codegen target call)
+ (varargs-epilogue))))
+ (t
+ (deliver-expr codegen entry-target call)))
+ (finish-entry tail))))))
+
+ (codegen-functions codegen))))
+
+(defmethod slot-unbound
+ (class (method basic-effective-method) (slot-name (eql 'functions)))
+ (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))
+
+;;;----- That's all, folks --------------------------------------------------
;; might not work very well, but it could be worth a shot.)
(if module
(setf (gethash truename *module-map*) module)
- (remhash truename *module-map*))))
+ (remhash truename *module-map*)))
;; A module which is being read can't be included again.
((eql module :in-progress)
(cl:in-package #:sod)
;;;--------------------------------------------------------------------------
+;;; Sequencing machinery.
+
+(defclass sequencer-item ()
+ ((name :initarg :name
+ :reader sequencer-item-name)
+ (functions :initarg :functions
+ :initform nil
+ :type list
+ :accessor sequencer-item-functions))
+ (:documentation
+ "Represents a distinct item to be sequenced by a SEQUENCER.
+
+ A SEQUENCER-ITEM maintains a list of FUNCTIONS which are invoked when the
+ sequencer is invoked. This class is not intended to be subclassed."))
+
+(defmethod print-object ((item sequencer-item) stream)
+ (print-unreadable-object (item stream :type t)
+ (prin1 (sequencer-item-name item) stream)))
+
+(defclass sequencer ()
+ ((constraints :initarg :constraints
+ :initform nil
+ :type list
+ :accessor sequencer-constraints)
+ (table :initform (make-hash-table :test #'equal)
+ :reader sequencer-table))
+ (:documentation
+ "A sequencer tracks items and invokes them in the proper order.
+
+ The job of a SEQUENCER object is threefold. Firstly, it collects
+ sequencer items and stores them in its table indexed by name. Secondly,
+ it gathers CONSTRAINTS, which impose an ordering on the items. Thirdly,
+ it can be instructed to invoke the items in an order compatible with the
+ established constraints.
+
+ Sequencer item names may may any kind of object which can be compared with
+ EQUAL. In particular, symbols, integers and strings are reasonable
+ choices for atomic names, and lists work well for compound names -- so
+ it's possible to construct a hierarchy."))
+
+(defgeneric ensure-sequencer-item (sequencer name)
+ (:documentation
+ "Arrange that SEQUENCER has a sequencer-item called NAME.
+
+ Returns the corresponding SEQUENCER-ITEM object."))
+
+(defgeneric add-sequencer-constraint (sequencer constraint)
+ (:documentation
+ "Attach the given CONSTRAINT to an SEQUENCER.
+
+ The CONSTRAINT should be a list of sequencer-item names; see
+ ENSURE-SEQUENCER-ITEM for what they look like. Note that the names
+ needn't have been declared in advance; indeed, they needn't be mentioned
+ anywhere else at all."))
+
+(defgeneric add-sequencer-item-function (sequencer name function)
+ (:documentation
+ "Arranges to call FUNCTION when the item called NAME is traversed.
+
+ More than one function can be associated with a given sequencer item.
+ They are called in the same order in which they were added.
+
+ Note that an item must be mentioned in at least one constraint in order to
+ be traversed by INVOKE-SEQUENCER-ITEMS. If there are no special ordering
+ requirments for a particular item, then the trivial constraint (NAME) will
+ suffice."))
+
+(defgeneric invoke-sequencer-items (sequencer &rest arguments)
+ (:documentation
+ "Invoke functions attached to the SEQUENCER's items in the right order.
+
+ Each function is invoked in turn with the list of ARGUMENTS. The return
+ values of the functions are discarded."))
+
+(defmethod ensure-sequencer-item ((sequencer sequencer) name)
+ (with-slots (table) sequencer
+ (or (gethash name table)
+ (setf (gethash name table)
+ (make-instance 'sequencer-item :name name)))))
+
+(defmethod add-sequencer-constraint ((sequencer sequencer) (constraint list))
+ (let ((converted-constraint (mapcar (lambda (name)
+ (ensure-sequencer-item sequencer
+ name))
+ constraint)))
+ (with-slots (constraints) sequencer
+ (pushnew converted-constraint constraints :test #'equal))))
+
+(defmethod add-sequencer-item-function ((sequencer sequencer) name function)
+ (let ((item (ensure-sequencer-item sequencer name)))
+ (pushnew function (sequencer-item-functions item))))
+
+(defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments)
+ (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
+ (dolist (function (reverse (sequencer-item-functions item)))
+ (apply function arguments))))
+
+;;;--------------------------------------------------------------------------
+;;; Output preparation.
+
+(defgeneric add-output-hooks (object reason sequencer)
+ (:documentation
+ "Announces the intention to write SEQUENCER, with a particular REASON.
+
+ The SEQUENCER is an SEQUENCER instance; the REASON will be a symbol which
+ can be matched using an EQL-specializer. In response, OBJECT should add
+ any constrains and item functions that it wishes, and pass the
+ announcement to its sub-objects.")
+ (:method-combination progn)
+ (:method progn (object reason sequencer)
+ nil))
+
+(defvar *seen-announcement*) ;Keep me unbound!
+#+hmm
+(defmethod add-output-hooks :around (object reason sequencer &rest stuff)
+ "Arrange not to invoke any object more than once during a particular
+ announcement."
+ (declare (ignore stuff))
+ (cond ((not (boundp '*seen-announcement*))
+ (let ((*seen-announcement* (make-hash-table)))
+ (setf (gethash object *seen-announcement*) t)
+ (call-next-method)))
+ ((gethash object *seen-announcement*)
+ nil)
+ (t
+ (setf (gethash object *seen-announcement*) t)
+ (call-next-method))))
+
+;;;--------------------------------------------------------------------------
;;; Utilities.
(defun banner (title output &key (blank-line-p t))
(when (module-header-fragments module)
(banner "User code" output)
(dolist (frag (module-header-fragments module))
- (write-fragment frag output)))
+ (princ frag output)))
;; The definitions of the necessary structures.
;;
(when (module-source-fragments module)
(banner "User code" output)
(dolist (frag (module-source-fragments module))
- (write-fragment frag output)))
+ (princ frag output)))
;; The definitions of the necessary tables.
;;
(return)))
(setf dims (nreverse dims))
(push (lambda (ty)
+ (when (typep ty 'c-function-type)
+ (error "Array element type cannot be ~
+ a function type"))
(make-instance 'c-array-type
:dimensions dims
:subtype ty))
;; Catch: if the only thing in the list is `void' (with no
;; identifier) then kill the whole thing.
- (break)
(setf args
(if (and args
(null (cdr args))
;; Stash the operator.
(push (lambda (ty)
+ (when (typep ty '(or c-function-type c-array-type))
+ (error "Function return type cannot be ~
+ a function or array type"))
(make-instance 'c-function-type
:arguments args
:subtype ty))
(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
(next-token lex)
(let ((ty (parse-c-type lex)))
(multiple-value-bind (type name) (parse-c-declarator lex ty)
- (multiple-value-bind (typestr declstr) (c-declaration type name)
- (list ty
- (list type name)
- (list typestr declstr)
+ (list ty
+ (list type name)
+ (with-output-to-string (out)
+ (pprint-c-type type out name)
(format-token lex)))))))
;;;----- That's all, folks --------------------------------------------------
(make-file-location (stream-pathname stream) nil nil)))
(defmethod print-object ((object file-location) stream)
- (if *print-escape*
- (call-next-method)
- (with-slots (pathname line column) object
- (format stream "~:[<unnamed>~;~:*~A~]~@[:~D~]~@[:~D~]"
- pathname line column))))
+ (maybe-print-unreadable-object (object stream :type t)
+ (with-slots (pathname line column) object
+ (format stream "~:[<unnamed>~;~:*~A~]~@[:~D~]~@[:~D~]"
+ pathname line column))))
+
+(defmethod make-load-form ((object file-location) &optional environment)
+ (make-load-form-saving-slots object :environment environment))
;;;--------------------------------------------------------------------------
;;; Proxy streams.
(defun property-type (value)
"Guess the right property type to use for VALUE."
- (etypecase value
+ (typecase value
(symbol :symbol)
(integer :integer)
(string :string)
- (c-fragment :frag)))
+ (character :char)
+ (c-fragment :frag)
+ (t :other)))
(defstruct (property
(:conc-name p-)
processed; don't put colons in package names if you want to use them from
SOD property sets."
- (declare (optimize debug))
(let* ((length (length string))
(colon (position #\: string)))
(multiple-value-bind (start internalp)
"Convert VALUE, a property of type TYPE, to be of type WANTED.")
;; If TYPE matches WANTED, we'll assume that VALUE already has the right
- ;; form.
- (:method :around (value type wanted)
- (if (eq type wanted)
- value
- (call-next-method)))
-
- ;; If nothing else matched, then I guess we'll have to say it didn't work.
+ ;; form. Otherwise, if nothing else matched, then I guess we'll have to
+ ;; say it didn't work.
(:method (value type wanted)
(if (eql type wanted)
value
(error "Incorrect type: expected ~A but found ~A" wanted type)))
+ ;; If the caller asks for type T then give him the raw thing.
+ (:method (value type (wanted (eql t)))
+ value)
+
;; Keywords.
(:method ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
value)
the value and its file location. In the latter case, mark the property as
having been used.
- The value returned depends on the TYPE argument provided. If you pass T
- (meaning any type) then you get back the entire PROPERTY object.
- Otherwise the value is coerced to the right kind of thing (where possible)
- and returned."
+ The value returned depends on the TYPE argument provided. If you pass NIL
+ then you get back the entire PROPERTY object. If you pass T, then you get
+ whatever was left in the property set, uninterpreted. Otherwise the value
+ is coerced to the right kind of thing (where possible) and returned."
(let ((prop (find name pset :key #'p-key)))
(with-default-error-location ((and prop (p-location prop)))
(dolist (prop pset)
(unless (p-seenp prop)
(cerror*-with-location (p-location prop) "Unknown property `~A'"
- (p-name prop)))))a
+ (p-name prop)))))
;;;--------------------------------------------------------------------------
;;; Property set parsing.
(defun parse-expression (lexer)
"Parse an expression from the LEXER.
- The return values are the expression's VALUE and TYPE; currently the
- types are :ID, :INTEGER and :STRING. If an error prevented a sane value
+ The return values are the expression's VALUE and TYPE; currently the types
+ are :ID, :INTEGER, :STRING, and :CHAR. If an error prevented a sane value
being produced, the TYPE :INVALID is returned.
Expression syntax is rather limited at the moment:
;; Aha. A primary. Push it onto the stack, and see if
;; there's an infix operator.
- ((:integer :id :string)
+ ((:integer :id :string :char)
(push (cons (token-type lexer)
(token-value lexer))
valstack)
--- /dev/null
+%%% -*-latex-*-
+%%%
+%%% Tutorial information
+%%%
+%%% (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{Tutorial}
+\label{ch:tut}
+
+This chapter provides a tutorial introduction to the Sod object system. It
+intentionally misses out nitty-gritty details. If you want those, the
+remaining chapters provide a complete reference to Sod.
+
+The author isn't terribly good at writing tutorial-style documentation.
+You'll have to bear with him. If you think you can do a better job, I'm sure
+that he'll be grateful for your contribution.
+
+%%%--------------------------------------------------------------------------
+\section{Introduction} \label{sec:tut.intro}
+
+Sod is an object system for the C~programming language. Because it doesn't
+have enough already. Actually, that's not right: it's got plenty already.
+But Sod is a Sensible Object Design, and C doesn't have any of those.
+
+What does that mean when the author's not off on one of his tirades? It
+means that is has the following features.
+\begin{itemize}
+\item It has a \emph{minimal runtime system}. Sod isn't likely to interfere
+ with other language runtimes or be difficult to deal with from a practical
+ point of view.
+\item It provides \emph{multiple inheritance}. Rather than having a single
+ superclass, Sod allows a class to specify any number of superclasses.
+ Moreover, it implements multiple inheritance using \emph{superclass
+ linearization}, which means that it's not a nightmare to deal with.
+\item It provides multiple \emph{method rôles}, including `before', `after'
+ and `around' methods, which makes constructing object protocols rather more
+ straightforward.
+\item It provides a number of \emph{method combinations}. For those coming
+ from languages other than Lisp, a method combination is a rule for deciding
+ how to invoke the various methods which might be used to respond to a
+ message. (This might still sound like a strange idea. We'll deal with it
+ in detail later.)
+\item It allows \emph{user-defined method combinations}. It does a whole lot
+ more: there's an entire translation-time \emph{meta-object protocol}, so
+ that extensions can modify many different aspects of the object system.
+ The downside is that you have to learn Common Lisp and roll up your sleeves
+ if you want to do any of this.
+\end{itemize}
+There's a good chance that half of that didn't mean anything to you. Bear
+with me, though, because we'll explain it all eventually.
+
+\subsection{Building programs with Sod} \label{sec:tut.intro.build}
+
+Sod is basically a fancy preprocessor, in the same vein as Lex and Yacc. It
+reads source files written in a vaguely C-like language. It produces output
+files which are actually C code (both header files and standalone sources),
+and which contain chunks of the input files verbatim.
+
+The main consequences of this are as follows.
+\begin{itemize}
+\item The output is completely portable between different machines and
+ compilers. If you're preparing a source distribution for general release,
+ it's probably a good idea to provide the generated C~source as well as your
+ Sod sources.
+\item Sod hasn't made any attempt to improve C's syntax. It's just as
+ hostile to object-oriented programming as it ever was. This means that
+ you'll end up writing ugly things like
+ \begin{prog}%
+ thing->_vt->foo.frob(thing, mumble);%
+ \end{prog}
+ fairly frequently. This can be made somewhat less painful using macros,
+ but we're basically stuck with C. The upside is that you know exactly what
+ you're getting. A common complaint about \Cplusplus\ is that it has a
+ tendency to hide arbitrarily complicated runtime behaviour behind
+ apparently innocent syntax: you don't get any of that with Sod. Some
+ people might even think this is a benefit.
+\end{itemize}
+Of course, this means that your build system needs to become more
+complicated. If you use \man{make}{1}, then something like
+\begin{prog}%
+ SOD = sod
+
+ .SUFFIXES: .sod .c .h
+ .sod.c:; \$(SOD) -gc -o \$@@ \$<
+ .sod.h:; \$(SOD) -gh -o \$@@ \$< %
+\end{prog}
+ought to do the job.
+
+%%%--------------------------------------------------------------------------
+\section{A traditional trivial introduction}
+
+The following is a simple Sod input file.
+\begin{prog}\quad\=\quad\=\kill%
+/* -*-sod-*- */
+
+code c : includes \{
+\#include "greeter.h"
+\}
+
+code h : includes \{
+\#include <stdio.h>
+\#include <sod.h>
+\}
+
+class Greeter : SodObject \{ \+
+ void greet(FILE *fp) \{ \+
+ fputs("Hello, world!\textbackslash n", fp); \-
+ \} \-
+\} %
+\end{prog}
+Save it as @"greeter.sod", and run
+\begin{prog}%
+sod --gc --gh greeter %
+\end{prog}
+This will create files @"greeter.c" and @"greeter.h" in the current
+directory. Here's how we might use such a simple thing.
+\begin{prog}\quad\=\kill%
+\#include "greeter.h"
+
+int main(void)
+\{ \+
+ struct Greeter__ilayout g_obj;
+ Greeter *g = Greeter__class->cls.init(\&g_obj);
+
+ g->_vt.greeter.greet(g, stdout);
+ return (0); \-
+\} %
+\end{prog}
+Compare this to the traditional
+\begin{prog}\quad\=\kill%
+\#include <stdio.h>
+
+int main(void) \+
+ \{ fputs("Hello, world\\n", stdout); return (0); \} %
+\end{prog}
+and I'm sure you'll appreciate the benefits of using Sod already -- mostly to
+do with finger exercise. Trust me, it gets more useful.
+
+The @".sod" file was almost comprehensible. There are two important parts to
+it (after the comment which tells Emacs how to cope with it).
+
+The first part consists of the two @"code" stanzas. Both of them define
+gobbets of raw C code to copy into output files. The first one, @"code~:
+c"~\ldots, says that
+\begin{prog}%
+ \#include "greeter.h" %
+\end{prog}
+needs to appear in the generated @|greeter.c| file; the second says that
+\begin{prog}%
+ \#include <stdio.h>
+ \#include <sod.h> %
+\end{prog}
+needs to appear in the header file @|greeter.h|. The generated C files need
+to get declarations for external types and functions (e.g., @"FILE" and
+@"fputs") from somewhere, and the generated @".c" file will need the
+declarations from the corresponding @".h" file. Sod takes a very simple
+approach to all of this: it expects you, the programmer, to deal with it.
+
+The basic syntax for @"code" stanzas is
+\begin{prog}\quad\=\kill%
+ code @<file-label> : @<section> \{
+ \> @<code>
+ \} %
+\end{prog}
+The @<file-label> is either @"c" or @"h", and says which output file the code
+wants to be written to. The @<section> is a name which explains where in the
+output file to place the code. The @"includes" section is the usual choice:
+it's the `right' place for @`\#include' directives and similar declarations.
+
+The remaining part, the `meat' of the file, defines a class called
+@"greeter". The class can respond to a single message, named @"greet", and
+in response, it writes a traditional greeting to the file passed in with the
+message.
+
+So far, so good. The C code, which we thought we understood, contains some
+bizarre looking runes. Let's take it one step at a time.
+\begin{prog}%
+ struct Greeter__ilayout g_obj; %
+\end{prog}
+allocates space for an instance of class @"Greeter". We're not going to use
+this space directly. Instead, we do this frightening looking thing.
+\begin{prog}%
+ Greeter *g = Greeter__class->cls.init(\&g_obj); %
+\end{prog}
+Taking it slowly: @"Greeter__class" is a pointer to the object that
+represents our class @"Greeter". This object contains a member, named
+@"cls.init", which points to a function whose job is to turn uninitialized
+storage space into working instances of the class. It returns a pointer to
+the instance, which we use in preference to grovelling about in the
+@"ilayout" structure.
+
+Having done this, we `send the instance a message':
+\begin{prog}%
+ g->_vt->greeter.greet(g, stdout); %
+\end{prog}
+This looks horrific, and seems to repeat itself quite unnecessarily. The
+first @"g" is the recipient of our `message'. The second is indeed a copy of
+the first: we have to tell it who it is. (Sod doesn't extend C's syntax, so
+this is the sort of thing we just have to put up with.) The lowercase
+@"greeter" is our class's `nickname': we didn't choose one explicitly, so Sod
+picked one by forcing the classname to lowercase.
+
+%%%----- That's all, folks --------------------------------------------------
+
+%%% Local variables:
+%%% mode: LaTeX
+%%% TeX-master: "sod.tex"
+%%% TeX-PDF-mode: t
+%%% End:
(:file "utilities" :depends-on ("package"))
(:file "tables" :depends-on ("package"))
(:file "c-types" :depends-on ("utilities"))
+ (:file "codegen" :depends-on ("c-types"))
(:file "posn-stream" :depends-on ("utilities"))
- (:file "lex" :depends-on ("posn-stream"))
+ (:file "errors" :depends-on ("posn-stream"))
+ (:file "lex" :depends-on ("posn-stream" "errors"))
(:file "pset" :depends-on ("lex"))
- (:file "parse-c-types" :depends-on ("lex" "c-types"))
- (:file "class-defs" :depends-on ("parse-c-types" "tables"))
- (:file "class-builder" :depends-on ("class-defs"))
+ (:file "parse-c-types" :depends-on ("lex" "c-types" "tables"))
+ (:file "class-defs" :depends-on ("parse-c-types"))
+ (:file "cpl" :depends-on ("class-defs"))
+ (:file "class-finalize" :depends-on ("class-defs" "cpl"))
+ (:file "class-builder" :depends-on ("class-finalize" "pset"))
+ (:file "class-layout" :depends-on ("class-defs"))
(:file "module" :depends-on ("parse-c-types" "tables"))
- (:file "output" :depends-on ("module"))))
+ (:file "output" :depends-on ("module"))
+ (:file "class-output" :depends-on ("class-layout" "output"))))
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+/* -*-c-*-
+ *
+ * Sensible Object Design header file
+ *
+ * (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.
+ */
+
+#ifndef SOD_H
+#define SOD_H
+
+#ifdef __cplusplus
+ extern "C" {
+#endif
+
+/*----- Header files ------------------------------------------------------*/
+
+#include <stdarg.h>
+#include <stddef.h>
+
+#include <sod-base.h>
+
+/*----- Data structures ---------------------------------------------------*/
+
+/* A skeletal vtable structure. At the beginning of every ichain is a
+ * pointer to one of these.
+ */
+struct sod_vtable {
+ SodClass *_class; /* Pointer to class object */
+ size_t _base; /* Offset to instance base */
+};
+
+/* A skeletal instance structure. Every instance pointer points to one of
+ * these.
+ */
+struct sod_instance {
+ struct sod_vtable *_vt; /* Pointer to (chain's) vtable */
+};
+
+/* Information about a particular chain of superclasses. In each class,
+ * there's a pointer to an array of these. If you search hard enough, you'll
+ * be able to find out a fair amount of information about an instance and its
+ * class.
+ */
+struct sod_chain {
+ size_t n_classes; /* Number of classes in chain */
+ const SodClass *const *classes; /* Vector of classes, head first */
+ size_t off_ichain; /* Offset of ichain from base */
+ const struct sod_vtable *vt; /* Chain's vtable pointer */
+ size_t ichainsz; /* Size of the ichain structure */
+};
+
+/*----- Infrastructure macros ---------------------------------------------*/
+
+/* --- @SOD_XCHAIN@ --- *
+ *
+ * Arguments: @chead@ = nickname of target chain's head
+ * @p@ = pointer to an instance chain
+ *
+ * Returns: Pointer to target chain, as a @char *@.
+ *
+ * Use: Utility for implementing cross-chain upcasts. It's probably
+ * not that clever to use this macro directly; it's used to make
+ * the automatically-generated upcast macros more palatable.
+ */
+
+#define SOD_XCHAIN(chead, p) ((char *)(p) + (p)->_vt->_off_##chead)
+
+/* --- @SOD_ILAYOUT@ --- *
+ *
+ * Arguments: @cls@ = name of a class
+ * @chead@ = nickname of chain head of @cls@
+ * @p@ = pointer to the @chead@ ichain of an (exact) instance of
+ * @cls@
+ *
+ * Returns: A pointer to the instance's base, cast as a pointer to the
+ * ilayout structure.
+ *
+ * Use: Finds an instance's base address given a pointer to one of
+ * its ichains, if you know precisely the instance's class and
+ * which chain you're pointing to. If you don't, then (a)
+ *
+ * @(char *)(p) - (p)->_vt->_base@
+ *
+ * will do the job just fine, and (b) you'll have the wrong
+ * ilayout anyway.
+ *
+ * This macro is not intended to be used directly outside of
+ * automatically generated effective method and trampoline
+ * functions, which have the kinds of specific knowledge
+ * necessary to use it safely.
+ */
+
+#define SOD_ILAYOUT(cls, chead, p) \
+ ((struct cls##__ilayout *) \
+ ((char *)(p) - offsetof(struct cls##__ilayout, chead)))
+
+/*----- Functions provided ------------------------------------------------*/
+
+/* --- @sod_convert@ --- *
+ *
+ * Arguments: @const SodClass *cls@ = desired class object
+ * @const void *obj@ = pointer to instance
+ *
+ * Returns: Pointer to appropriate ichain of object, or null if the
+ * instance isn't of the specified class.
+ *
+ * Use: General down/cross-casting function.
+ *
+ * Upcasts can be performed efficiently using the automatically
+ * generated macros. In particular, upcasts with a chain are
+ * trivial; cross-chain upcasts require information from vtables
+ * but are fairly fast. This function is rather slower, but is
+ * much more general.
+ *
+ * Suppose we have an instance of a class C, referred to by a
+ * pointer to an instance of one of C's superclasses S. If S'
+ * is some other superclass of C then this function will return
+ * a pointer to C suitable for use as an instance of S'. If S'
+ * is not a superclass of C, then the function returns null.
+ * (If the pointer doesn't point to an instance of some class
+ * then the behaviour is undefined.) Note that you don't need
+ * to know what C or S actually are.
+ */
+
+extern void *sod_convert(const SodClass */*cls*/, void */*p*/);
+
+/*----- That's all, folks -------------------------------------------------*/
+
+#ifdef __cplusplus
+ }
+#endif
+
+#endif
--- /dev/null
+\documentclass[noarticle]{strayman}
+
+\usepackage[T1]{fontenc}
+\usepackage[utf8]{inputenc}
+\usepackage[palatino, helvetica, courier, maths=cmr]{mdwfonts}
+\usepackage{syntax}
+\usepackage{sverb}
+\usepackage{at}
+\usepackage{mdwref}
+
+\title{A Sensible Object Design for C}
+\author{Mark Wooding}
+
+\def\syntleft{\normalfont\itshape}
+\let\syntright\empty
+
+\def\ulitleft{\normalfont\sffamily}
+\let\ulitright\empty
+
+\let\listingsize\relax
+
+\let\epsilon\varepsilon
+
+\atdef <#1>{\synt{#1}}
+\atdef "#1"{\lit*{#1}}
+\atdef `#1'{\lit{#1}}
+\atdef |#1|{\textsf{#1}}
+
+\def\Cplusplus{C\kern-1pt++}
+\def\Csharp{C\#}
+\def\man#1#2{\textbf{#1}(#2)}
+
+\begingroup\lccode`\~=`\
+\lowercase{
+\endgroup
+\def\prog{%
+ \sffamily%
+ \quote%
+ \let\oldnl\\%
+ \obeylines%
+ \tabbing%
+ \global\let~\\%
+ \global\let\\\textbackslash%
+}
+\def\endprog{%
+ \endtabbing%
+ \global\let\\\oldnl%
+ \endquote%
+}}
+
+\begin{document}
+
+\maketitle
+
+\include{sod-tut}
+
+%%%--------------------------------------------------------------------------
+\chapter{Internals}
+
+\section{Generated names}
+
+The generated names for functions and objects related to a class are
+constructed systematically so as not to interfere with each other. The rules
+on class, slot and message naming exist so as to ensure that the generated
+names don't collide with each other.
+
+The following notation is used in this section.
+\begin{description}
+\item[@<class>] The full name of the `focus' class: the one for which we are
+ generating name.
+\item[@<super-nick>] The nickname of a superclass.
+\item[@<head-nick>] The nickname of the chain-head class of the chain
+ in question.
+\end{description}
+
+\subsection{Instance layout}
+
+%%%--------------------------------------------------------------------------
+\section{Syntax}
+\label{sec:syntax}
+
+Fortunately, Sod is syntactically quite simple. I've used a little slightly
+unusual notation in order to make the presentation easier to read.
+\begin{itemize}
+\item $\epsilon$ denotes the empty nonterminal:
+ \begin{quote}
+ $\epsilon$ ::=
+ \end{quote}
+\item $[$@<item>$]$ means an optional @<item>:
+ \begin{quote}
+ \syntax{$[$<item>$]$ ::= $\epsilon$ | <item>}
+ \end{quote}
+\item @<item>$^*$ means a sequence of zero or more @<item>s:
+ \begin{quote}
+ \syntax{<item>$^*$ ::= $\epsilon$ | <item>$^*$ <item>}
+ \end{quote}
+\item @<item>$^+$ means a sequence of one or more @<item>s:
+ \begin{quote}
+ \syntax{<item>$^+$ ::= <item> <item>$^*$}
+ \end{quote}
+\item @<item-list> means a sequence of one or more @<item>s separated
+ by commas:
+ \begin{quote}
+ \syntax{<item-list> ::= <item> | <item-list> "," <item>}
+ \end{quote}
+\end{itemize}
+
+\subsection{Lexical syntax}
+\label{sec:syntax.lex}
+
+Whitespace and comments are discarded. The remaining characters are
+collected into tokens according to the following syntax.
+
+\begin{grammar}
+<token> ::= <identifier>
+\alt <reserved-word>
+\alt <string-literal>
+\alt <char-literal>
+\alt <integer-literal>
+\alt <punctuation>
+\end{grammar}
+
+This syntax is slightly ambiguous. The following two rules serve to
+disambiguate:
+\begin{enumerate}
+\item Reserved words take precedence. All @<reserved-word>s are
+ syntactically @<identifier>s; Sod resolves the ambiguity in favour of
+ @<reserved-word>.
+\item `Maximal munch'. In other cases, at each stage we take the longest
+ sequence of characters which could be a token.
+\end{enumerate}
+
+\subsubsection{Identifiers} \label{sec:syntax.lex.id}
+
+\begin{grammar}
+<identifier> ::= <id-start-char> <id-body-char>$^*$
+
+<id-start-char> ::= <alpha-char> $|$ "_"
+
+<id-body-char> ::= <id-start-char> $|$ <digit-char>
+
+<alpha-char> ::= "A" $|$ "B" $|$ \dots\ $|$ "Z"
+\alt "a" $|$ "b" $|$ \dots\ $|$ "z"
+\alt <extended-alpha-char>
+
+<digit-char> ::= "0" $|$ <nonzero-digit-char>
+
+<nonzero-digit-char> ::= "1" $|$ "2" $| \cdots |$ "9"
+\end{grammar}
+
+The precise definition of @<alpha-char> is left to the function
+\textsf{alpha-char-p} in the hosting Lisp system. For portability,
+programmers are encouraged to limit themselves to the standard ASCII letters.
+
+\subsubsection{Reserved words} \label{sec:syntax.lex.reserved}
+
+\begin{grammar}
+<reserved-word> ::=
+"char" $|$ "class" $|$ "code" $|$ "const" $|$ "double" $|$ "enum" $|$
+"extern" $|$ "float" $|$ "import" $|$ "int" $|$ "lisp" $|$ "load" $|$ "long"
+$|$ "restrict" $|$ "short" $|$ "signed" $|$ "struct" $|$ "typename" $|$
+"union" $|$ "unsigned" $|$ "void" $|$ "volatile"
+\end{grammar}
+
+Many of these are borrowed from~C; however, some (e.g., @"import" and
+@"lisp") are not, and some C reserved words are not reserved (e.g.,
+@"static").
+
+\subsubsection{String and character literals} \label{sec:syntax.lex.string}
+
+\begin{grammar}
+<string-literal> ::= "\"" <string-literal-char>$^*$ "\""
+
+<char-literal> ::= "'" <char-literal-char> "'"
+
+<string-literal-char> ::= any character other than "\\" or "\""
+\alt "\\" <char>
+
+<char-literal-char> ::= any character other than "\\" or "'"
+\alt "\\" <char>
+
+<char> ::= any single character
+\end{grammar}
+
+The syntax for string and character literals differs from~C. In particular,
+escape sequences such as @`\textbackslash n' are not recognized. The use
+of string and character literals in Sod, outside of C~fragments, is limited,
+and the simple syntax seems adequate. For the sake of future compatibility,
+the use of character sequences which resemble C escape sequences is
+discouraged.
+
+\subsubsection{Integer literals} \label{sec:syntax.lex.int}
+
+\begin{grammar}
+<integer-literal> ::= <decimal-integer>
+\alt <binary-integer>
+\alt <octal-integer>
+\alt <hex-integer>
+
+<decimal-integer> ::= <nonzero-digit-char> <digit-char>$^*$
+
+<binary-integer> ::= "0" $($"b"$|$"B"$)$ <binary-digit-char>$^+$
+
+<binary-digit-char> ::= "0" $|$ "1"
+
+<octal-integer> ::= "0" $[$"o"$|$"O"$]$ <octal-digit-char>$^+$
+
+<octal-digit-char> ::= "0" $|$ "1" $| \cdots |$ "7"
+
+<hex-integer> ::= "0" $($"x"$|$"X"$)$ <hex-digit-char>$^+$
+
+<hex-digit-char> ::= <digit-char>
+\alt "A" $|$ "B" $|$ "C" $|$ "D" $|$ "E" $|$ "F"
+\alt "a" $|$ "b" $|$ "c" $|$ "d" $|$ "e" $|$ "f"
+\end{grammar}
+
+Sod understands only integers, not floating-point numbers; its integer syntax
+goes slightly beyond C in allowing a @`0o' prefix for octal and @`0b' for
+binary. However, length and signedness indicators are not permitted.
+
+\subsubsection{Punctuation} \label{sec:syntax.lex.punct}
+
+\begin{grammar}
+<punctuation> ::= any character other than "\"" or "'"
+\end{grammar}
+
+Due to the `maximal munch' rule, @<punctuation> tokens cannot be
+alphanumeric.
+
+\subsubsection{Comments} \label{sec:lex-comment}
+
+\begin{grammar}
+<comment> ::= <block-comment>
+\alt <line-comment>
+
+<block-comment> ::=
+ "/*"
+ <not-star>$^*$ $($<star>$^+$ <not-star-or-slash> <not-star>$^*)^*$
+ <star>$^*$
+ "*/"
+
+<star> ::= "*"
+
+<not-star> ::= any character other than "*"
+
+<not-star-or-slash> ::= any character other than "*" or "/"
+
+<line-comment> ::= "//" <not-newline>$^*$ <newline>
+
+<newline> ::= a newline character
+
+<not-newline> ::= any character other than newline
+\end{grammar}
+
+Comments are exactly as in C99: both traditional block comments `\texttt{/*}
+\dots\ \texttt{*/}' and \Cplusplus-style `\texttt{//} \dots' comments are
+permitted and ignored.
+
+\subsection{Special nonterminals}
+\label{sec:special-nonterminals}
+
+Aside from the lexical syntax presented above (\xref{sec:lexical-syntax}),
+two special nonterminals occur in the module syntax.
+
+\subsubsection{S-expressions} \label{sec:syntax-sexp}
+
+\begin{grammar}
+<s-expression> ::= an S-expression, as parsed by the Lisp reader
+\end{grammar}
+
+When an S-expression is expected, the Sod parser simply calls the host Lisp
+system's \textsf{read} function. Sod modules are permitted to modify the
+read table to extend the S-expression syntax.
+
+S-expressions are self-delimiting, so no end-marker is needed.
+
+\subsubsection{C fragments} \label{sec:syntax.lex.cfrag}
+
+\begin{grammar}
+<c-fragment> ::= a sequence of C tokens, with matching brackets
+\end{grammar}
+
+Sequences of C code are simply stored and written to the output unchanged
+during translation. They are read using a simple scanner which nonetheless
+understands C comments and string and character literals.
+
+A C fragment is terminated by one of a small number of delimiter characters
+determined by the immediately surrounding context -- usually a closing brace
+or bracket. The first such delimiter character which is not enclosed in
+brackets, braces or parenthesis ends the fragment.
+
+\subsection{Module syntax} \label{sec:syntax-module}
+
+\begin{grammar}
+<module> ::= <definition>$^*$
+
+<definition> ::= <import-definition>
+\alt <load-definition>
+\alt <lisp-definition>
+\alt <code-definition>
+\alt <typename-definition>
+\alt <class-definition>
+\end{grammar}
+
+A module is the top-level syntactic item. A module consists of a sequence of
+definitions.
+
+\subsection{Simple definitions} \label{sec:syntax.defs}
+
+\subsubsection{Importing modules} \label{sec:syntax.defs.import}
+
+\begin{grammar}
+<import-definition> ::= "import" <string> ";"
+\end{grammar}
+
+The module named @<string> is processed and its definitions made available.
+
+A search is made for a module source file as follows.
+\begin{itemize}
+\item The module name @<string> is converted into a filename by appending
+ @`.sod', if it has no extension already.\footnote{%
+ Technically, what happens is \textsf{(merge-pathnames name (make-pathname
+ :type "SOD" :case :common))}, so exactly what this means varies
+ according to the host system.} %
+\item The file is looked for relative to the directory containing the
+ importing module.
+\item If that fails, then the file is looked for in each directory on the
+ module search path in turn.
+\item If the file still isn't found, an error is reported and the import
+ fails.
+\end{itemize}
+At this point, if the file has previously been imported, nothing further
+happens.\footnote{%
+ This check is done using \textsf{truename}, so it should see through simple
+ tricks like symbolic links. However, it may be confused by fancy things
+ like bind mounts and so on.} %
+
+Recursive imports, either direct or indirect, are an error.
+
+\subsubsection{Loading extensions} \label{sec:syntax.defs.load}
+
+\begin{grammar}
+<load-definition> ::= "load" <string> ";"
+\end{grammar}
+
+The Lisp file named @<string> is loaded and evaluated.
+
+A search is made for a Lisp source file as follows.
+\begin{itemize}
+\item The name @<string> is converted into a filename by appending @`.lisp',
+ if it has no extension already.\footnote{%
+ Technically, what happens is \textsf{(merge-pathnames name (make-pathname
+ :type "LISP" :case :common))}, so exactly what this means varies
+ according to the host system.} %
+\item A search is then made in the same manner as for module imports
+ (\xref{sec:syntax-module}).
+\end{itemize}
+If the file is found, it is loaded using the host Lisp's \textsf{load}
+function.
+
+Note that Sod doesn't attempt to compile Lisp files, or even to look for
+existing compiled files. The right way to package a substantial extension to
+the Sod translator is to provide the extension as a standard ASDF system (or
+similar) and leave a dropping @"foo-extension.lisp" in the module path saying
+something like
+\begin{listing}
+(asdf:operate 'asdf:load-op :foo-extension)
+\end{listing}
+which will arrange for the extension to be compiled if necessary.
+
+(This approach means that the language doesn't need to depend on any
+particular system definition facility. It's bad enough already that it
+depends on Common Lisp.)
+
+\subsubsection{Lisp escapes} \label{sec:syntax.defs.lisp}
+
+\begin{grammar}
+<lisp-definition> ::= "lisp" <s-expression> ";"
+\end{grammar}
+
+The @<s-expression> is evaluated immediately. It can do anything it likes.
+
+\textbf{Warning!} This means that hostile Sod modules are a security hazard.
+Lisp code can read and write files, start other programs, and make network
+connections. Don't install Sod modules from sources that you don't
+trust.\footnote{%
+ Presumably you were going to run the corresponding code at some point, so
+ this isn't as unusually scary as it sounds. But please be careful.} %
+
+\subsubsection{Declaring type names} \label{sec:syntax.defs.typename}
+
+\begin{grammar}
+<typename-definition> ::=
+ "typename" <identifier-list> ";"
+\end{grammar}
+
+Each @<identifier> is declared as naming a C type. This is important because
+the C type syntax -- which Sod uses -- is ambiguous, and disambiguation is
+done by distinguishing type names from other identifiers.
+
+Don't declare class names using @"typename"; use @"class" forward
+declarations instead.
+
+\subsection{Literal code} \label{sec:syntax-code}
+
+\begin{grammar}
+<code-definition> ::=
+ "code" <identifier> ":" <identifier> $[$<constraints>$]$
+ "{" <c-fragment> "}"
+
+<constraints> ::= "[" <constraint-list> "]"
+
+<constraint> ::= <identifier>$^+$
+\end{grammar}
+
+The @<c-fragment> will be output unchanged to one of the output files.
+
+The first @<identifier> is the symbolic name of an output file. Predefined
+output file names are @"c" and @"h", which are the implementation code and
+header file respectively; other output files can be defined by extensions.
+
+The second @<identifier> provides a name for the output item. Several C
+fragments can have the same name: they will be concatenated together in the
+order in which they were encountered.
+
+The @<constraints> provide a means for specifying where in the output file
+the output item should appear. (Note the two kinds of square brackets shown
+in the syntax: square brackets must appear around the constraints if they are
+present, but that they may be omitted.) Each comma-separated @<constraint>
+is a sequence of identifiers naming output items, and indicates that the
+output items must appear in the order given -- though the translator is free
+to insert additional items in between them. (The particular output items
+needn't be defined already -- indeed, they needn't be defined ever.)
+
+There is a predefined output item @"includes" in both the @"c" and @"h"
+output files which is a suitable place for inserting @"\#include"
+preprocessor directives in order to declare types and functions for use
+elsewhere in the generated output files.
+
+\subsection{Property sets} \label{sec:syntax.propset}
+
+\begin{grammar}
+<properties> ::= "[" <property-list> "]"
+
+<property> ::= <identifier> "=" <expression>
+\end{grammar}
+
+Property sets are a means for associating miscellaneous information with
+classes and related items. By using property sets, additional information
+can be passed to extensions without the need to introduce idiosyncratic
+syntax.
+
+A property has a name, given as an @<identifier>, and a value computed by
+evaluating an @<expression>. The value can be one of a number of types,
+though the only operators currently defined act on integer values only.
+
+\subsubsection{The expression evaluator} \label{sec:syntax.propset.expr}
+
+\begin{grammar}
+<expression> ::= <term> | <expression> "+" <term> | <expression> "-" <term>
+
+<term> ::= <factor> | <term> "*" <factor> | <term> "/" <factor>
+
+<factor> ::= <primary> | "+" <factor> | "-" <factor>
+
+<primary> ::=
+ <integer-literal> | <string-literal> | <char-literal> | <identifier>
+\alt "?" <s-expression>
+\alt "(" <expression> ")"
+\end{grammar}
+
+The arithmetic expression syntax is simple and standard; there are currently
+no bitwise, logical, or comparison operators.
+
+A @<primary> expression may be a literal or an identifier. Note that
+identifiers stand for themselves: they \emph{do not} denote values. For more
+fancy expressions, the syntax
+\begin{quote}
+ @"?" @<s-expression>
+\end{quote}
+causes the @<s-expression> to be evaluated using the Lisp \textsf{eval}
+function.
+%%% FIXME crossref to extension docs
+
+\subsection{C types} \label{sec:syntax.c-types}
+
+Sod's syntax for C types closely mirrors the standard C syntax. A C type has
+two parts: a sequence of @<declaration-specifier>s and a @<declarator>. In
+Sod, a type must contain at least one @<declaration-specifier> (i.e.,
+`implicit @"int"' is forbidden), and storage-class specifiers are not
+recognized.
+
+\subsubsection{Declaration specifiers} \label{sec:syntax.c-types.declspec}
+
+\begin{grammar}
+<declaration-specifier> ::= <type-name>
+\alt "struct" <identifier> | "union" <identifier> | "enum" <identifier>
+\alt "void" | "char" | "int" | "float" | "double"
+\alt "short" | "long"
+\alt "signed" | "unsigned"
+\alt <qualifier>
+
+<qualifier> ::= "const" | "volatile" | "restrict"
+
+<type-name> ::= <identifier>
+\end{grammar}
+
+A @<type-name> is an identifier which has been declared as being a type name,
+using the @"typename" or @"class" definitions.
+
+Declaration specifiers may appear in any order. However, not all
+combinations are permitted. A declaration specifier must consist of zero or
+more @<qualifiers>, and one of the following, up to reordering.
+\begin{itemize}
+\item @<type-name>
+\item @"struct" <identifier>, @"union" <identifier>, @"enum" <identifier>
+\item @"void"
+\item @"char", @"unsigned char", @"signed char"
+\item @"short", @"unsigned short", @"signed short"
+\item @"short int", @"unsigned short int", @"signed short int"
+\item @"int", @"unsigned int", @"signed int", @"unsigned", @"signed"
+\item @"long", @"unsigned long", @"signed long"
+\item @"long int", @"unsigned long int", @"signed long int"
+\item @"long long", @"unsigned long long", @"signed long long"
+\item @"long long int", @"unsigned long long int", @"signed long long int"
+\item @"float", @"double", @"long double"
+\end{itemize}
+All of these have their usual C meanings.
+
+\subsubsection{Declarators} \label{sec:syntax.c-types.declarator}
+
+\begin{grammar}
+<declarator> ::=
+ <pointer>$^*$ <inner-declarator> <declarator-suffix>$^*$
+
+<inner-declarator> ::= <identifier> | <qualified-identifier>
+\alt "(" <declarator> ")"
+
+<qualified-identifier> ::= <identifier> "." <identifier>
+
+<pointer> ::= "*" <qualifier>$^*$
+
+<declarator-suffix> ::= "[" <c-fragment> "]"
+\alt "(" <arguments> ")"
+
+<arguments> ::= <empty> | "..."
+\alt <argument-list> $[$"," "..."$]$
+
+<argument> ::= <declaration-specifier>$^+$ <argument-declarator>
+
+<argument-declarator> ::= <declarator> | $[$<abstract-declarator>$]$
+
+<abstract-declarator> ::=
+ <pointer>$^+$ | <pointer>$^*$ <inner-abstract-declarator>
+
+<inner-abstract-declarator> ::= "(" <abstract-declarator> ")"
+\alt $[$<inner-abstract-declarator>$]$ <declarator-suffix>$^+$
+\end{grammar}
+
+The declarator syntax is taken from C, but with some differences.
+\begin{itemize}
+\item Array dimensions are uninterpreted @<c-fragments>, terminated by a
+ closing square bracket. This allows array dimensions to contain arbitrary
+ constant expressions.
+\item A declarator may have either a single @<identifier> at its centre or a
+ pair of @<identifier>s separated by a @`.'; this is used to refer to
+ slots or messages defined in superclasses.
+\end{itemize}
+The remaining differences are (I hope) a matter of presentation rather than
+substance.
+
+\subsection{Defining classes} \label{sec:syntax.class}
+
+\begin{grammar}
+<class-definition> ::= <class-forward-declaration>
+\alt <full-class-definition>
+\end{grammar}
+
+\subsubsection{Forward declarations} \label{sec:class.class.forward}
+
+\begin{grammar}
+<class-forward-declaration> ::= "class" <identifier> ";"
+\end{grammar}
+
+A @<class-forward-declaration> informs Sod that an @<identifier> will be used
+to name a class which is currently undefined. Forward declarations are
+necessary in order to resolve certain kinds of circularity. For example,
+\begin{listing}
+class Sub;
+
+class Super : SodObject {
+ Sub *sub;
+};
+
+class Sub : Super {
+ /* ... */
+};
+\end{listing}
+
+\subsubsection{Full class definitions} \label{sec:class.class.full}
+
+\begin{grammar}
+<full-class-definition> ::=
+ $[$<properties>$]$
+ "class" <identifier> ":" <identifier-list>
+ "{" <class-item>$^*$ "}"
+
+<class-item> ::= <slot-item> ";"
+\alt <message-item>
+\alt <method-item>
+\alt <initializer-item> ";"
+\end{grammar}
+
+A full class definition provides a complete description of a class.
+
+The first @<identifier> gives the name of the class. It is an error to
+give the name of an existing class (other than a forward-referenced class),
+or an existing type name. It is conventional to give classes `MixedCase'
+names, to distinguish them from other kinds of identifiers.
+
+The @<identifier-list> names the direct superclasses for the new class. It
+is an error if any of these @<identifier>s does not name a defined class.
+
+The @<properties> provide additional information. The standard class
+properties are as follows.
+\begin{description}
+\item[@"lisp_class"] The name of the Lisp class to use within the translator
+ to represent this class. The property value must be an identifier; the
+ default is @"sod_class". Extensions may define classes with additional
+ behaviour, and may recognize additional class properties.
+\item[@"metaclass"] The name of the Sod metaclass for this class. In the
+ generated code, a class is itself an instance of another class -- its
+ \emph{metaclass}. The metaclass defines which slots the class will have,
+ which messages it will respond to, and what its behaviour will be when it
+ receives them. The property value must be an identifier naming a defined
+ subclass of @"SodClass". The default metaclass is @"SodClass".
+ %%% FIXME xref to theory
+\item[@"nick"] A nickname for the class, to be used to distinguish it from
+ other classes in various limited contexts. The property value must be an
+ identifier; the default is constructed by forcing the class name to
+ lower-case.
+\end{description}
+
+The class body consists of a sequence of @<class-item>s enclosed in braces.
+These items are discussed on the following sections.
+
+\subsubsection{Slot items} \label{sec:sntax.class.slot}
+
+\begin{grammar}
+<slot-item> ::=
+ $[$<properties>$]$
+ <declaration-specifier>$^+$ <init-declarator-list>
+
+<init-declarator> ::= <declarator> $[$"=" <initializer>$]$
+\end{grammar}
+
+A @<slot-item> defines one or more slots. All instances of the class and any
+subclass will contain these slot, with the names and types given by the
+@<declaration-specifiers> and the @<declarators>. Slot declarators may not
+contain qualified identifiers.
+
+It is not possible to declare a slot with function type: such an item is
+interpreted as being a @<message-item> or @<method-item>. Pointers to
+functions are fine.
+
+An @<initializer>, if present, is treated as if a separate
+@<initializer-item> containing the slot name and initializer were present.
+For example,
+\begin{listing}
+[nick = eg]
+class Example : Super {
+ int foo = 17;
+};
+\end{listing}
+means the same as
+\begin{listing}
+[nick = eg]
+class Example : Super {
+ int foo;
+ eg.foo = 17;
+};
+\end{listing}
+
+\subsubsection{Initializer items} \label{sec:syntax.class.init}
+
+\begin{grammar}
+<initializer-item> ::= $[$"class"$]$ <slot-initializer-list>
+
+<slot-initializer> ::= <qualified-identifier> "=" <initializer>
+
+<initializer> :: "{" <c-fragment> "}" | <c-fragment>
+\end{grammar}
+
+An @<initializer-item> provides an initial value for one or more slots. If
+prefixed by @"class", then the initial values are for class slots (i.e.,
+slots of the class object itself); otherwise they are for instance slots.
+
+The first component of the @<qualified-identifier> must be the nickname of
+one of the class's superclasses (including itself); the second must be the
+name of a slot defined in that superclass.
+
+The initializer has one of two forms.
+\begin{itemize}
+\item A @<c-fragment> enclosed in braces denotes an aggregate initializer.
+ This is suitable for initializing structure, union or array slots.
+\item A @<c-fragment> \emph{not} beginning with an open brace is a `bare'
+ initializer, and continues until the next @`,' or @`;' which is not within
+ nested brackets. Bare initializers are suitable for initializing scalar
+ slots, such as pointers or integers, and strings.
+\end{itemize}
+
+\subsubsection{Message items} \label{sec:syntax.class.message}
+
+\begin{grammar}
+<message-item> ::=
+ $[$<properties>$]$
+ <declaration-specifier>$^+$ <declarator> $[$<method-body>$]$
+\end{grammar}
+
+\subsubsection{Method items} \label{sec:syntax.class.method}
+
+\begin{grammar}
+<method-item> ::=
+ $[$<properties>$]$
+ <declaration-specifier>$^+$ <declarator> <method-body>
+
+<method-body> ::= "{" <c-fragment> "}" | "extern" ";"
+\end{grammar}
+
+%%%--------------------------------------------------------------------------
+\section{Class objects}
+
+\begin{listing}
+typedef struct SodClass__ichain_obj SodClass;
+
+struct sod_chain {
+ size_t n_classes; /* Number of classes in chain */
+ const SodClass *const *classes; /* Vector of classes, head first */
+ size_t off_ichain; /* Offset of ichain from instance base */
+ const struct sod_vtable *vt; /* Vtable pointer for chain */
+ size_t ichainsz; /* Size of the ichain structure */
+};
+
+struct sod_vtable {
+ SodClass *_class; /* Pointer to instance's class */
+ size_t _base; /* Offset to instance base */
+};
+
+struct SodClass__islots {
+
+ /* Basic information */
+ const char *name; /* The class's name as a string */
+ const char *nick; /* The nickname as a string */
+
+ /* Instance allocation and initialization */
+ size_t instsz; /* Instance layout size in bytes */
+ void *(*imprint)(void *); /* Stamp instance with vtable ptrs */
+ void *(*init)(void *); /* Initialize instance */
+
+ /* Superclass structure */
+ size_t n_supers; /* Number of direct superclasses */
+ const SodClass *const *supers; /* Vector of direct superclasses */
+ size_t n_cpl; /* Length of class precedence list */
+ const SodClass *const *cpl; /* Vector for class precedence list */
+
+ /* Chain structure */
+ const SodClass *link; /* Link to next class in chain */
+ const SodClass *head; /* Pointer to head of chain */
+ size_t level; /* Index of class in its chain */
+ size_t n_chains; /* Number of superclass chains */
+ const sod_chain *chains; /* Vector of chain structures */
+
+ /* Layout */
+ size_t off_islots; /* Offset of islots from ichain base */
+ size_t islotsz; /* Size of instance slots */
+};
+
+struct SodClass__ichain_obj {
+ const SodClass__vt_obj *_vt;
+ struct SodClass__islots cls;
+};
+
+struct sod_instance {
+ struct sod_vtable *_vt;
+};
+\end{listing}
+
+\begin{listing}
+void *sod_convert(const SodClass *cls, const void *obj)
+{
+ const struct sod_instance *inst = obj;
+ const SodClass *real = inst->_vt->_cls;
+ const struct sod_chain *chain;
+ size_t i, index;
+
+ for (i = 0; i < real->cls.n_chains; i++) {
+ chain = &real->cls.chains[i];
+ if (chain->classes[0] == cls->cls.head) {
+ index = cls->cls.index;
+ if (index < chain->n_classes && chain->classes[index] == cls)
+ return ((char *)cls - inst->_vt._base + chain->off_ichain);
+ else
+ return (0);
+ }
+ }
+ return (0);
+}
+\end{listing}
+
+%%%--------------------------------------------------------------------------
+\section{Classes}
+
+\subsection{Classes and superclasses}
+
+A @<full-class-definition> must list one or more existing classes to be the
+\emph{direct superclasses} for the new class being defined. We make the
+following definitions.
+\begin{itemize}
+\item The \emph{superclasses} of a class consist of the class itself together
+ with the superclasses of its direct superclasses.
+\item The \emph{proper superclasses} of a class are its superclasses other
+ than itself.
+\item If $C$ is a (proper) superclass of $D$ then $D$ is a (\emph{proper})
+ \emph{subclass} of $C$.
+\end{itemize}
+The predefined class @|SodObject| has no direct superclasses; it is unique in
+this respect. All classes are subclasses of @|SodObject|.
+
+\subsection{The class precedence list}
+
+Let $C$ be a class. The superclasses of $C$ form a directed graph, with an
+edge from each class to each of its direct superclasses. This is the
+\emph{superclass graph of $C$}.
+
+In order to resolve inheritance of items, we define a \emph{class precedence
+ list} (or CPL) for each class, which imposes a total order on that class's
+superclasses. The default algorithm for computing the CPL is the \emph{C3}
+algorithm \cite{fixme-c3}, though extensions may implement other algorithms.
+
+The default algorithm works as follows. Let $C$ be the class whose CPL we
+are to compute. Let $X$ and $Y$ be two of $C$'s superclasses.
+\begin{itemize}
+\item $C$ must appear first in the CPL.
+\item If $X$ appears before $Y$ in the CPL of one of $C$'s direct
+ superclasses, then $X$ appears before $Y$ in the $C$'s CPL.
+\item If the above rules don't suffice to order $X$ and $Y$, then whichever
+ of $X$ and $Y$ has a subclass which appears further left in the list of
+ $C$'s direct superclasses will appear earlier in the CPL.
+\end{itemize}
+This last rule is sufficient to disambiguate because if both $X$ and $Y$ are
+superclasses of the same direct superclass of $C$ then that direct
+superclass's CPL will order $X$ and $Y$.
+
+We say that \emph{$X$ is more specific than $Y$ as a superclass of $C$} if
+$X$ is earlier than $Y$ in $C$'s class precedence list. If $C$ is clear from
+context then we omit it, saying simply that $X$ is more specific than $Y$.
+
+\subsection{Instances and metaclasses}
+
+A class defines the structure and behaviour of its \emph{instances}: run-time
+objects created (possibly) dynamically. An instance is an instance of only
+one class, though structurally it may be used in place of an instance of any
+of that class's superclasses. It is possible, with care, to change the class
+of an instance at run-time.
+
+Classes are themselves represented as instances -- called \emph{class
+ objects} -- in the running program. Being instances, they have a class,
+called the \emph{metaclass}. The metaclass defines the structure and
+behaviour of the class object.
+
+The predefined class @|SodClass| is the default metaclass for new classes.
+@|SodClass| has @|SodObject| as its only direct superclass. @|SodClass| is
+its own metaclass.
+
+\subsection{Items and inheritance}
+
+A class definition also declares \emph{slots}, \emph{messages},
+\emph{initializers} and \emph{methods} -- collectively referred to as
+\emph{items}. In addition to the items declared in the class definition --
+the class's \emph{direct items} -- a class also \emph{inherits} items from
+its superclasses.
+
+The precise rules for item inheritance vary according to the kinds of items
+involved.
+
+Some object systems have a notion of `repeated inheritance': if there are
+multiple paths in the superclass graph from a class to one of its
+superclasses then items defined in that superclass may appear duplicated in
+the subclass. Sod does not have this notion.
+
+\subsubsection{Slots}
+A \emph{slot} is a unit of state. In other object systems, slots may be
+called `fields', `member variables', or `instance variables'.
+
+A slot has a \emph{name} and a \emph{type}. The name serves only to
+distinguish the slot from other direct slots defined by the same class. A
+class inherits all of its proper superclasses' slots. Slots inherited from
+superclasses do not conflict with each other or with direct slots, even if
+they have the same names.
+
+At run-time, each instance of the class holds a separate value for each slot,
+whether direct or inherited. Changing the value of an instance's slot
+doesn't affect other instances.
+
+\subsubsection{Initializers}
+Mumble.
+
+\subsubsection{Messages}
+A \emph{message} is the stimulus for behaviour. In Sod, a class must define,
+statically, the name and format of the messages it is able to receive and the
+values it will return in reply. In this respect, a message is similar to
+`abstract member functions' or `interface member functions' in other object
+systems.
+
+Like slots, a message has a \emph{name} and a \emph{type}. Again, the name
+serves only to distinguish the message from other direct messages defined by
+the same class. Messages inherited from superclasses do not conflict with
+each other or with direct messages, even if they have the same name.
+
+At run-time, one sends a message to an instance by invoking a function
+obtained from the instance's \emph{vtable}: \xref{sec:fixme-vtable}.
+
+\subsubsection{Methods}
+A \emph{method} is a unit of behaviour. In other object systems, methods may
+be called `member functions'.
+
+A method is associated with a message. When a message is received by an
+instance, all of the methods associated with that message on the instance's
+class or any of its superclasses are \emph{applicable}. The details of how
+the applicable methods are invoked are described fully in
+\xref{sec:fixme-method-combination}.
+
+\subsection{Chains and instance layout}
+
+
+
+\end{document}
+\f
+%%% Local variables:
+%%% mode: LaTeX
+%%% TeX-PDF-mode: t
+%%% End:
;;;--------------------------------------------------------------------------
;;; List utilities.
+(defun mappend (function list &rest more-lists)
+ "Like a nondestructive MAPCAN.
+
+ Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
+ and return the result of appending all of the resulting lists."
+ (reduce #'append (apply #'mapcar function list more-lists) :from-end t))
+
(define-condition inconsistent-merge-error (error)
((candidates :initarg :candidates
:reader merge-error-candidates))
;; we can build the list up forwards, so as not to make the PICK function
;; interface be weird. HEAD is a dummy cons cell inserted before the list,
;; which gives TAIL something to point to initially. (If we had locatives,
- ;; I'd have TAIL point to the thing holding the final NIL, but we haven't.)
+ ;; I'd have TAIL point to the thing holding the final NIL, but we haven't;
+ ;; instead, it points to the cons cell whose cdr holds the final NIL --
+ ;; which means that we need to invent a cons cell if the list is empty.)
(do* ((head (cons nil nil))
(tail head))
((null lists) (cdr head))
(t nil)))
;;;--------------------------------------------------------------------------
+;;; Symbols.
+
+(defun symbolicate (&rest symbols)
+ "Return a symbol named after the concatenation of the names of the SYMBOLS.
+
+ The symbol is interned in the current *PACKAGE*. Trad."
+ (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
+
+;;;--------------------------------------------------------------------------
+;;; Object printing.
+
+(defmacro maybe-print-unreadable-object
+ ((object stream &rest args) &body body)
+ "Print helper for usually-unreadable objects.
+
+ If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY.
+ Otherwise just print using BODY."
+ (let ((func (gensym "PRINT")))
+ `(flet ((,func () ,@body))
+ (if *print-escape*
+ (print-unreadable-object (,object ,stream ,@args)
+ (,func))
+ (,func)))))
+
+;;;--------------------------------------------------------------------------
;;; Keyword arguments and lambda lists.
(eval-when (:compile-toplevel :load-toplevel :execute)
OBJECT except where overridden by INITARGS."
(apply #'copy-instance-using-class (class-of object) object initargs))
+(defmacro default-slot ((instance slot) &body value &environment env)
+ "If INSTANCE's SLOT is unbound, set it to VALUE.
+
+ Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only
+ evaluated if it's needed."
+
+ (let* ((quotep (constantp slot env))
+ (instancevar (gensym "INSTANCE"))
+ (slotvar (if quotep slot (gensym "SLOT"))))
+ `(let ((,instancevar ,instance)
+ ,@(and (not quotep) `((,slotvar ,slot))))
+ (unless (slot-boundp ,instancevar ,slotvar)
+ (setf (slot-value ,instancevar ,slotvar)
+ (progn ,@value))))))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / commitdiff