From 1f1d88f5234188f70548a04fd117ac6e251fe8de Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Wed, 14 Oct 2009 01:17:21 +0100 Subject: [PATCH] Very ragged work-in-progress. Most parts are in place. Much rearrangement is needed. --- .gitignore | 5 + c-types.lisp | 529 ++++++++++++++------------- class-builder.lisp | 417 ++++++++++++++++++--- class-defs.lisp | 580 +++++++++++------------------ class-finalize.lisp | 274 ++++++++++++++ class-layout.lisp | 639 ++++++++++++++++++++++++++++++++ class-output.lisp | 314 ++++++++++++++++ codegen.lisp | 470 ++++++++++++++++++++++++ combination.lisp | 131 +++++++ cpl.lisp | 7 +- cutting-room-floor.lisp | 104 +++++- examples.lisp | 60 +++ layout.lisp | 84 ----- lex.lisp | 79 +++- methods.lisp | 721 ++++++++++++++++++++++++++++++++++++ module.lisp | 2 +- output.lisp | 133 ++++++- parse-c-types.lisp | 18 +- posn-stream.lisp | 12 +- pset.lisp | 36 +- sod-tut.tex | 228 ++++++++++++ sod.asd | 16 +- sod.h | 152 ++++++++ sod.tex | 942 ++++++++++++++++++++++++++++++++++++++++++++++++ utilities.lisp | 51 ++- 25 files changed, 5185 insertions(+), 819 deletions(-) create mode 100644 class-finalize.lisp create mode 100644 class-layout.lisp create mode 100644 class-output.lisp create mode 100644 codegen.lisp create mode 100644 combination.lisp create mode 100644 examples.lisp delete mode 100644 layout.lisp create mode 100644 methods.lisp create mode 100644 sod-tut.tex create mode 100644 sod.h create mode 100644 sod.tex diff --git a/.gitignore b/.gitignore index 3d894d7..9fa0c7e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,7 @@ *~ *.fasl +*.pdf +*.out +*.log +*.dvi +*.aux diff --git a/c-types.lisp b/c-types.lisp index acf2db8..fe56ecd 100644 --- a/c-types.lisp +++ b/c-types.lisp @@ -37,13 +37,6 @@ ;; 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.")) @@ -55,14 +48,25 @@ (: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 @@ -71,30 +75,37 @@ (defmethod print-object ((object c-type) stream) (if *print-escape* (format stream "~:@" 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. @@ -117,34 +128,21 @@ (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. @@ -152,16 +150,23 @@ 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. @@ -169,13 +174,16 @@ 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. @@ -200,15 +208,6 @@ (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))) @@ -226,43 +225,6 @@ (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). @@ -279,17 +241,19 @@ "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)) @@ -299,22 +263,25 @@ (declare (ignore colon atsign)) (let* ((name (c-type-name type)) (symbol (gethash name *simple-type-map*))) - (if symbol - (princ symbol stream) - (format stream "~:@" 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") @@ -366,46 +333,34 @@ "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)) @@ -413,21 +368,10 @@ (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. @@ -441,13 +385,21 @@ (: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)) @@ -456,17 +408,19 @@ (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. @@ -483,13 +437,18 @@ (: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)) @@ -500,63 +459,35 @@ (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) @@ -565,6 +496,52 @@ (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) @@ -579,25 +556,65 @@ #.(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 -------------------------------------------------- diff --git a/class-builder.lisp b/class-builder.lisp index 8c945ab..4e05a64 100644 --- a/class-builder.lisp +++ b/class-builder.lisp @@ -30,16 +30,21 @@ (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))) @@ -103,7 +108,7 @@ ((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) @@ -119,30 +124,26 @@ (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. @@ -306,15 +307,15 @@ (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)) @@ -354,7 +355,7 @@ 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, @@ -414,7 +415,7 @@ ((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 @@ -436,50 +437,352 @@ (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 -------------------------------------------------- diff --git a/class-defs.lisp b/class-defs.lisp index 570322b..279af8c 100644 --- a/class-defs.lisp +++ b/class-defs.lisp @@ -26,7 +26,7 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- -;;; Class definitions. +;;; Classes. (defclass sod-class () ((name :initarg :name @@ -42,9 +42,9 @@ (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) @@ -75,13 +75,17 @@ (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: @@ -112,23 +116,22 @@ 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; @@ -162,11 +165,173 @@ 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 @@ -219,6 +384,13 @@ 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 @@ -294,114 +466,11 @@ 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. @@ -431,7 +500,9 @@ (defmethod print-c-type (stream (type c-class-type) &optional colon atsign) (declare (ignore colon atsign)) - (format stream "~:@" (c-type-name type))) + (format stream "~:@" + (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. @@ -455,18 +526,19 @@ "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 @@ -487,226 +559,14 @@ (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 -------------------------------------------------- diff --git a/class-finalize.lisp b/class-finalize.lisp new file mode 100644 index 0000000..cf1ff73 --- /dev/null +++ b/class-finalize.lisp @@ -0,0 +1,274 @@ +;;; -*-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 -------------------------------------------------- diff --git a/class-layout.lisp b/class-layout.lisp new file mode 100644 index 0000000..d342e5e --- /dev/null +++ b/class-layout.lisp @@ -0,0 +1,639 @@ +;;; -*-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 -------------------------------------------------- diff --git a/class-output.lisp b/class-output.lisp new file mode 100644 index 0000000..8fdcc82 --- /dev/null +++ b/class-output.lisp @@ -0,0 +1,314 @@ +;;; -*-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 "~@~%" + (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 -------------------------------------------------- diff --git a/codegen.lisp b/codegen.lisp new file mode 100644 index 0000000..6419c0f --- /dev/null +++ b/codegen.lisp @@ -0,0 +1,470 @@ +;;; -*-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 -------------------------------------------------- diff --git a/combination.lisp b/combination.lisp new file mode 100644 index 0000000..be5257e --- /dev/null +++ b/combination.lisp @@ -0,0 +1,131 @@ +;;; -*-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 -------------------------------------------------- diff --git a/cpl.lisp b/cpl.lisp index 5a8c7c1..041e8e7 100644 --- a/cpl.lisp +++ b/cpl.lisp @@ -82,11 +82,8 @@ (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))) diff --git a/cutting-room-floor.lisp b/cutting-room-floor.lisp index 1781f98..2f82c65 100644 --- a/cutting-room-floor.lisp +++ b/cutting-room-floor.lisp @@ -8,7 +8,7 @@ #+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 @@ -91,3 +91,105 @@ (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)))) diff --git a/examples.lisp b/examples.lisp new file mode 100644 index 0000000..92489dd --- /dev/null +++ b/examples.lisp @@ -0,0 +1,60 @@ +(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=))) + diff --git a/layout.lisp b/layout.lisp deleted file mode 100644 index d077fe2..0000000 --- a/layout.lisp +++ /dev/null @@ -1,84 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/lex.lisp b/lex.lisp index 46b951d..cd0a5a8 100644 --- a/lex.lisp +++ b/lex.lisp @@ -235,7 +235,8 @@ ;; 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" @@ -284,7 +285,7 @@ ;; 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) @@ -292,7 +293,7 @@ (flet ((getch () (setf ch (next-char lexer)) (when (null ch) - (cerror* floc + (cerror* "Unexpected end of file in string/character constant") (return)))) (getch) @@ -349,8 +350,18 @@ ;; 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. @@ -434,19 +445,46 @@ 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. @@ -597,7 +635,7 @@ ;; 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) @@ -608,6 +646,9 @@ (next-char lexer) (scan-c-fragment lexer '(#\})))) +#+interactive +(set-dispatch-macro-character #\# #\{ 'c-fragment-reader) + ;;;-------------------------------------------------------------------------- ;;; Testing cruft. @@ -615,6 +656,8 @@ (with-input-from-string (in " { foo } 'x' /?/***/! 123 0432 0b010123 0xc0ffee __burp_32 class + +0xturning 0xfattening ... class integer : integral_domain { diff --git a/methods.lisp b/methods.lisp new file mode 100644 index 0000000..4a3b52d --- /dev/null +++ b/methods.lisp @@ -0,0 +1,721 @@ +;;; -*-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 -------------------------------------------------- diff --git a/module.lisp b/module.lisp index 2575b39..bcfc912 100644 --- a/module.lisp +++ b/module.lisp @@ -169,7 +169,7 @@ ;; 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) diff --git a/output.lisp b/output.lisp index 44ec6e2..67d2907 100644 --- a/output.lisp +++ b/output.lisp @@ -26,6 +26,135 @@ (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)) @@ -90,7 +219,7 @@ (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. ;; @@ -137,7 +266,7 @@ (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. ;; diff --git a/parse-c-types.lisp b/parse-c-types.lisp index 702ae77..d273045 100644 --- a/parse-c-types.lisp +++ b/parse-c-types.lisp @@ -407,6 +407,9 @@ (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)) @@ -438,7 +441,6 @@ ;; 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)) @@ -449,6 +451,9 @@ ;; 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)) @@ -486,7 +491,8 @@ (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 @@ -498,10 +504,10 @@ (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 -------------------------------------------------- diff --git a/posn-stream.lisp b/posn-stream.lisp index b687ad0..6aa1a1f 100644 --- a/posn-stream.lisp +++ b/posn-stream.lisp @@ -89,11 +89,13 @@ (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 "~:[~;~:*~A~]~@[:~D~]~@[:~D~]" - pathname line column)))) + (maybe-print-unreadable-object (object stream :type t) + (with-slots (pathname line column) object + (format stream "~:[~;~:*~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. diff --git a/pset.lisp b/pset.lisp index f1c1172..67a77fc 100644 --- a/pset.lisp +++ b/pset.lisp @@ -39,11 +39,13 @@ (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-) @@ -87,7 +89,6 @@ 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) @@ -120,18 +121,17 @@ "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) @@ -158,10 +158,10 @@ 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))) @@ -182,7 +182,7 @@ (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. @@ -190,8 +190,8 @@ (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: @@ -283,7 +283,7 @@ ;; 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) diff --git a/sod-tut.tex b/sod-tut.tex new file mode 100644 index 0000000..cff9859 --- /dev/null +++ b/sod-tut.tex @@ -0,0 +1,228 @@ +%%% -*-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 +\#include +\} + +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 + +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 + \#include % +\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 @ : @
\{ + \> @ + \} % +\end{prog} +The @ is either @"c" or @"h", and says which output file the code +wants to be written to. The @
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: diff --git a/sod.asd b/sod.asd index 932b611..54214fc 100644 --- a/sod.asd +++ b/sod.asd @@ -71,13 +71,19 @@ (: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 -------------------------------------------------- diff --git a/sod.h b/sod.h new file mode 100644 index 0000000..7b1b7fa --- /dev/null +++ b/sod.h @@ -0,0 +1,152 @@ +/* -*-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 +#include + +#include + +/*----- 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 diff --git a/sod.tex b/sod.tex new file mode 100644 index 0000000..6b8275f --- /dev/null +++ b/sod.tex @@ -0,0 +1,942 @@ +\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[@] The full name of the `focus' class: the one for which we are + generating name. +\item[@] The nickname of a superclass. +\item[@] 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 $[$@$]$ means an optional @: + \begin{quote} + \syntax{$[$$]$ ::= $\epsilon$ | } + \end{quote} +\item @$^*$ means a sequence of zero or more @s: + \begin{quote} + \syntax{$^*$ ::= $\epsilon$ | $^*$ } + \end{quote} +\item @$^+$ means a sequence of one or more @s: + \begin{quote} + \syntax{$^+$ ::= $^*$} + \end{quote} +\item @ means a sequence of one or more @s separated + by commas: + \begin{quote} + \syntax{ ::= | "," } + \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} + ::= +\alt +\alt +\alt +\alt +\alt +\end{grammar} + +This syntax is slightly ambiguous. The following two rules serve to +disambiguate: +\begin{enumerate} +\item Reserved words take precedence. All @s are + syntactically @s; Sod resolves the ambiguity in favour of + @. +\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} + ::= $^*$ + + ::= $|$ "_" + + ::= $|$ + + ::= "A" $|$ "B" $|$ \dots\ $|$ "Z" +\alt "a" $|$ "b" $|$ \dots\ $|$ "z" +\alt + + ::= "0" $|$ + + ::= "1" $|$ "2" $| \cdots |$ "9" +\end{grammar} + +The precise definition of @ 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} + ::= +"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} + ::= "\"" $^*$ "\"" + + ::= "'" "'" + + ::= any character other than "\\" or "\"" +\alt "\\" + + ::= any character other than "\\" or "'" +\alt "\\" + + ::= 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} + ::= +\alt +\alt +\alt + + ::= $^*$ + + ::= "0" $($"b"$|$"B"$)$ $^+$ + + ::= "0" $|$ "1" + + ::= "0" $[$"o"$|$"O"$]$ $^+$ + + ::= "0" $|$ "1" $| \cdots |$ "7" + + ::= "0" $($"x"$|$"X"$)$ $^+$ + + ::= +\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} + ::= any character other than "\"" or "'" +\end{grammar} + +Due to the `maximal munch' rule, @ tokens cannot be +alphanumeric. + +\subsubsection{Comments} \label{sec:lex-comment} + +\begin{grammar} + ::= +\alt + + ::= + "/*" + $^*$ $($$^+$ $^*)^*$ + $^*$ + "*/" + + ::= "*" + + ::= any character other than "*" + + ::= any character other than "*" or "/" + + ::= "//" $^*$ + + ::= a newline character + + ::= 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} + ::= 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} + ::= 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} + ::= $^*$ + + ::= +\alt +\alt +\alt +\alt +\alt +\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" ";" +\end{grammar} + +The module named @ is processed and its definitions made available. + +A search is made for a module source file as follows. +\begin{itemize} +\item The module name @ 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" ";" +\end{grammar} + +The Lisp file named @ is loaded and evaluated. + +A search is made for a Lisp source file as follows. +\begin{itemize} +\item The name @ 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" ";" +\end{grammar} + +The @ 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" ";" +\end{grammar} + +Each @ 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" ":" $[$$]$ + "{" "}" + + ::= "[" "]" + + ::= $^+$ +\end{grammar} + +The @ will be output unchanged to one of the output files. + +The first @ 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 @ 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 @ 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 @ +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} + ::= "[" "]" + + ::= "=" +\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 @, and a value computed by +evaluating an @. 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} + ::= | "+" | "-" + + ::= | "*" | "/" + + ::= | "+" | "-" + + ::= + | | | +\alt "?" +\alt "(" ")" +\end{grammar} + +The arithmetic expression syntax is simple and standard; there are currently +no bitwise, logical, or comparison operators. + +A @ 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} + @"?" @ +\end{quote} +causes the @ 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 @s and a @. In +Sod, a type must contain at least one @ (i.e., +`implicit @"int"' is forbidden), and storage-class specifiers are not +recognized. + +\subsubsection{Declaration specifiers} \label{sec:syntax.c-types.declspec} + +\begin{grammar} + ::= +\alt "struct" | "union" | "enum" +\alt "void" | "char" | "int" | "float" | "double" +\alt "short" | "long" +\alt "signed" | "unsigned" +\alt + + ::= "const" | "volatile" | "restrict" + + ::= +\end{grammar} + +A @ 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 @, and one of the following, up to reordering. +\begin{itemize} +\item @ +\item @"struct" , @"union" , @"enum" +\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} + ::= + $^*$ $^*$ + + ::= | +\alt "(" ")" + + ::= "." + + ::= "*" $^*$ + + ::= "[" "]" +\alt "(" ")" + + ::= | "..." +\alt $[$"," "..."$]$ + + ::= $^+$ + + ::= | $[$$]$ + + ::= + $^+$ | $^*$ + + ::= "(" ")" +\alt $[$$]$ $^+$ +\end{grammar} + +The declarator syntax is taken from C, but with some differences. +\begin{itemize} +\item Array dimensions are uninterpreted @, terminated by a + closing square bracket. This allows array dimensions to contain arbitrary + constant expressions. +\item A declarator may have either a single @ at its centre or a + pair of @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} + ::= +\alt +\end{grammar} + +\subsubsection{Forward declarations} \label{sec:class.class.forward} + +\begin{grammar} + ::= "class" ";" +\end{grammar} + +A @ informs Sod that an @ 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} + ::= + $[$$]$ + "class" ":" + "{" $^*$ "}" + + ::= ";" +\alt +\alt +\alt ";" +\end{grammar} + +A full class definition provides a complete description of a class. + +The first @ 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 @ names the direct superclasses for the new class. It +is an error if any of these @s does not name a defined class. + +The @ 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 @s enclosed in braces. +These items are discussed on the following sections. + +\subsubsection{Slot items} \label{sec:sntax.class.slot} + +\begin{grammar} + ::= + $[$$]$ + $^+$ + + ::= $[$"=" $]$ +\end{grammar} + +A @ 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 +@ and the @. 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 @ or @. Pointers to +functions are fine. + +An @, if present, is treated as if a separate +@ 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} + ::= $[$"class"$]$ + + ::= "=" + + :: "{" "}" | +\end{grammar} + +An @ 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 @ 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 @ enclosed in braces denotes an aggregate initializer. + This is suitable for initializing structure, union or array slots. +\item A @ \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} + ::= + $[$$]$ + $^+$ $[$$]$ +\end{grammar} + +\subsubsection{Method items} \label{sec:syntax.class.method} + +\begin{grammar} + ::= + $[$$]$ + $^+$ + + ::= "{" "}" | "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 @ 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} + +%%% Local variables: +%%% mode: LaTeX +%%% TeX-PDF-mode: t +%%% End: diff --git a/utilities.lisp b/utilities.lisp index d61bb00..7e9e092 100644 --- a/utilities.lisp +++ b/utilities.lisp @@ -28,6 +28,13 @@ ;;;-------------------------------------------------------------------------- ;;; 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)) @@ -63,7 +70,9 @@ ;; 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)) @@ -150,6 +159,31 @@ (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) @@ -359,4 +393,19 @@ 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 -------------------------------------------------- -- 2.11.0