Much needs to be done.
--- /dev/null
+*~
+*.fasl
--- /dev/null
+;;; -*-emacs-lisp-*-
+
+(setq skel-alist
+ (append
+ '((author . "Straylight/Edgeware")
+ (full-title . "the Simple Object Definition system")
+ (program . "SOD")
+ (licence-text . skelrc-gpl))
+ skel-alist))
--- /dev/null
+* Stuff from the ABI spec
+
+** Notation
+
+ * sizeof(O) :: size of an object O
+ * align(O) :: alignment of the object O
+ * offset(C) :: offset of the component C within O
+ * dsize(O) :: data size of the object O (without tail padding)
+ * nvsize(O) :: the /non-virtual/ size of the object O (i.e.,
+ without virtual bases)
+ * nvalign(O) :: the non-virtual alignment of the object O
+
+** Other concepts
+
+ * POD for the purpose of layout ::
+
+
+* Order of stuff in output files
+
+** Header
+
+ * Multiple inclusion and C++ guards
+ * Forward declarations of structs and typedef names.
+ * User code
+ * Structure definitions
+ * Macros
+ * Function declarations for methods
+
+** Implementation
+
+ * User code
+ * Method and table definitions
+
+* COMMENT
+
+# Local variables:
+# mode: org
+# End:
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Dealing with C types
+;;;
+;;; (c) 2008 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)
+
+;;;--------------------------------------------------------------------------
+;;; Plain old C types.
+
+;; Class definition.
+
+(defclass c-type ()
+ ()
+ (:documentation
+ "Base class for C type objects."))
+
+;; 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."))
+
+(defgeneric c-type-equal-p (type-a type-b)
+ (:method-combination and)
+ (:documentation
+ "Answers whether two types TYPE-A and TYPE-B are, in fact, equal.")
+ (:method and (type-a type-b)
+ (eql (class-of type-a) (class-of type-b))))
+
+(defgeneric c-declarator-priority (type)
+ (: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))
+
+(defgeneric print-c-type (stream type &optional colon atsign)
+ (:documentation
+ "Print an abbreviated syntax for TYPE to the STREAM."))
+
+(defmethod print-object ((object c-type) stream)
+ (if *print-escape*
+ (format stream "~:@<C-TYPE ~/sod::print-c-type/~:>" object)
+ (multiple-value-bind (base decl) (c-declaration object "")
+ (format stream "~A~:[~; ~A~]" base (plusp (length decl)) decl))))
+
+;; Utility functions.
+
+(defun maybe-parenthesize (decl me him)
+ "Wrap parens around DECL, maybe, according to priorities of ME and HIM.
+
+ 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)))
+
+(defun compound-type-declaration (type format-control &rest format-args)
+ "Convenience function for implementating compound types.
+
+ 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))))
+
+;; S-expression syntax machinery.
+
+(defun c-name-case (name)
+ "Convert NAME to suitable case.
+
+ Strings are returned as-is; symbols are squashed to lower-case and hyphens
+ are replaced by underscores."
+ (typecase name
+ (symbol (with-output-to-string (out)
+ (loop for ch across (symbol-name name)
+ do (cond ((alpha-char-p ch)
+ (write-char (char-downcase ch) out))
+ ((or (digit-char-p ch)
+ (char= ch #\_))
+ (write-char ch out))
+ ((char= ch #\-)
+ (write-char #\_ out))
+ (t
+ (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))))))
+
+(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))
+
+(defmacro define-c-type-syntax (name bvl &rest body)
+ "Define a C-type syntax function.
+
+ A function defined by BODY and with lambda-list BVL is associated with the
+ NAME. When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this
+ function with the argument list STUFF."
+ `(progn
+ (setf (get ',name 'c-type) (lambda ,bvl ,@body))
+ ',name))
+
+(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)))))
+
+(defmacro defctype (names value)
+ "Define NAMES all to describe the C-type VALUE.
+
+ NAMES can be a symbol (treated as a singleton list), or a list of symbols.
+ The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE. It will
+ be expanded once at run-time."
+ (unless (listp names)
+ (setf names (list names)))
+ (let ((ty (gensym)))
+ `(let ((,ty (expand-c-type ',value)))
+ (setf (get ',(car names) 'c-type) (lambda () ,ty))
+ ,@(and (cdr names)
+ `((c-type-alias ,(car names) ,@(cdr names)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Types which can accept qualifiers.
+
+;; Basic definitions.
+
+(defclass qualifiable-c-type (c-type)
+ ((qualifiers :initarg :qualifiers
+ :type list
+ :initform nil
+ :accessor c-type-qualifiers))
+ (:documentation
+ "Base class for C types which can be qualified."))
+
+(defun format-qualifiers (quals)
+ "Return a string listing QUALS, with a space after each."
+ (format nil "~{~(~A~) ~}" quals))
+
+(defmethod c-type-equal-p and ((type-a qualifiable-c-type)
+ (type-b qualifiable-c-type))
+ (flet ((fix (type)
+ (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)))
+ (defun qualify-type (c-type qualifiers)
+ "Returns a qualified version of C-TYPE.
+
+ Maintains a cache of qualified types so that we don't have to run out of
+ memory. This can also speed up type comparisons."
+ (if (null qualifiers)
+ c-type
+ (let ((key (cons c-type qualifiers)))
+ (unless (typep c-type 'qualifiable-c-type)
+ (error "~A isn't qualifiable." (class-name (class-of c-type))))
+ (or (gethash key cache)
+ (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).
+
+(defvar *simple-type-map* (make-hash-table :test #'equal)
+ "A hash table mapping type strings to Lisp symbols naming them.")
+
+;; Basic definitions.
+
+(defclass simple-c-type (qualifiable-c-type)
+ ((name :initarg :name
+ :type string
+ :reader c-type-name))
+ (:documentation
+ "C types with simple forms."))
+
+(let ((cache (make-hash-table :test #'equal)))
+ (defun make-simple-type (name)
+ "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))
+
+(defmethod c-type-equal-p and ((type-a simple-c-type)
+ (type-b simple-c-type))
+ (string= (c-type-name type-a) (c-type-name type-b)))
+
+(defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)
+ (declare (ignore colon atsign))
+ (let* ((name (c-type-name type))
+ (symbol (gethash name *simple-type-map*)))
+ (if symbol
+ (princ symbol stream)
+ (format stream "~:@<SIMPLE-C-TYPE ~@_~S~:>" name))))
+
+;; 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)))
+
+(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))))
+
+(define-simple-c-type void "void")
+
+(define-simple-c-type char "char")
+(define-simple-c-type (unsigned-char uchar) "unsigned char")
+(define-simple-c-type (signed-char schar) "signed char")
+
+(define-simple-c-type (int signed signed-int sint) "int")
+(define-simple-c-type (unsigned unsigned-int uint) "unsigned")
+
+(define-simple-c-type (short signed-short short-int signed-short-int sshort)
+ "short")
+(define-simple-c-type (unsigned-short unsigned-short-int ushort)
+ "unsigned short")
+
+(define-simple-c-type (long signed-long long-int signed-long-int slong)
+ "long")
+(define-simple-c-type (unsigned-long unsigned-long-int ulong)
+ "unsigned long")
+
+(define-simple-c-type (long-long signed-long-long long-long-int
+ signed-long-long-int llong sllong)
+ "long long")
+(define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong)
+ "unsigned long long")
+
+(define-simple-c-type float "float")
+(define-simple-c-type double "double")
+(define-simple-c-type long-double "long double")
+
+(define-simple-c-type va-list "va_list")
+(define-simple-c-type size-t "size_t")
+(define-simple-c-type ptrdiff-t "ptrdiff_t")
+
+;;;--------------------------------------------------------------------------
+;;; Tag types (structs, unions and enums).
+
+;; Definitions.
+
+(defclass tagged-c-type (qualifiable-c-type)
+ ((tag :initarg :tag
+ :type string
+ :reader c-type-tag))
+ (:documentation
+ "C types with tags."))
+
+(defgeneric c-tagged-type-kind (type)
+ (:documentation
+ "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)))))
+ `(progn
+ (defclass ,type (tagged-c-type) ()
+ (:documentation ,(format nil "C ~a types." what)))
+ (defmethod c-tagged-type-kind ((type ,type))
+ ,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))
+
+(defmethod c-type-equal-p and ((type-a tagged-c-type)
+ (type-b tagged-c-type))
+ (string= (c-type-tag type-a) (c-type-tag type-b)))
+
+(defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
+ (declare (ignore colon atsign))
+ (format stream "~:@<~A ~A~:>"
+ (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)))
+
+;;;--------------------------------------------------------------------------
+;;; Pointer types.
+
+;; Definitions.
+
+(defclass c-pointer-type (qualifiable-c-type)
+ ((subtype :initarg :subtype
+ :type c-type
+ :reader c-type-subtype))
+ (: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))
+
+(defmethod c-type-equal-p and ((type-a c-pointer-type)
+ (type-b c-pointer-type))
+ (c-type-equal-p (c-type-subtype type-a)
+ (c-type-subtype type-b)))
+
+(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)))
+
+;; S-expression syntax.
+
+(define-c-type-syntax pointer (sub)
+ "Return the type of pointer-to-SUB."
+ (make-instance 'c-pointer-type :subtype (expand-c-type sub)))
+(c-type-alias pointer * ptr)
+
+(defctype string (* char))
+
+;;;--------------------------------------------------------------------------
+;;; Array types.
+
+;; Definitions.
+
+(defclass c-array-type (c-type)
+ ((subtype :initarg :subtype
+ :type c-type
+ :reader c-type-subtype)
+ (dimensions :initarg :dimensions
+ :type list
+ :reader c-array-dimensions))
+ (:documentation
+ "C array types."))
+
+(defmethod c-declarator-priority ((type c-array-type)) 2)
+
+(defmethod c-declaration ((type c-array-type) decl)
+ (compound-type-declaration type
+ "~A~{[~@[~A~]]~}"
+ decl
+ (c-array-dimensions type)))
+
+(defmethod c-type-equal-p and ((type-a c-array-type)
+ (type-b c-array-type))
+ (and (c-type-equal-p (c-type-subtype type-a)
+ (c-type-subtype type-b))
+ (equal (c-array-dimensions type-a)
+ (c-array-dimensions type-b))))
+
+(defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
+ (declare (ignore colon atsign))
+ (format stream "~:@<[] ~@_~:I~/sod::print-c-type/~{ ~_~A~}~:>"
+ (c-type-subtype type)
+ (c-array-dimensions type)))
+
+;; S-expression syntax.
+
+(define-c-type-syntax array (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)
+
+;;;--------------------------------------------------------------------------
+;;; 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)
+
+(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)
+ (and (= (length list-a) (length list-b))
+ (every (lambda (arg-a arg-b)
+ (if (eq arg-a :ellipsis)
+ (eq arg-b :ellipsis)
+ (c-type-equal-p (argument-type arg-a)
+ (argument-type arg-b))))
+ list-a list-b)))
+
+(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)
+ (c-type-subtype type-b))
+ (arguments-lists-equal-p (c-function-arguments type-a)
+ (c-function-arguments type-b))))
+
+(defmethod print-c-type
+ (stream (type c-function-type) &optional colon atsign)
+ (declare (ignore colon atsign))
+ (format stream
+ #.(concatenate 'string
+ "~:@<"
+ "FUN ~@_~:I~/sod::print-c-type/"
+ "~{ ~_~:<~A ~@_~/sod::print-c-type/~:>~}"
+ "~:>")
+ (c-type-subtype type)
+ (c-function-arguments type)))
+
+;; S-expression syntax.
+
+(define-c-type-syntax function (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)
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Equipment for building classes and friends
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Finding things by name
+
+(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)))
+
+(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))))
+
+ (defun find-instance-slot-by-name (class super-nick slot-name)
+ (let ((super (find-superclass-by-nick class super-nick)))
+ (find-item-by-name "slot" super (sod-class-slots super)
+ slot-name #'sod-slot-name)))
+
+ (defun find-class-slot-by-name (class super-nick slot-name)
+ (let* ((meta (sod-class-metaclass class))
+ (super (find-superclass-by-nick meta super-nick)))
+ (find-item-by-name "slot" super (sod-class-slots super)
+ slot-name #'sod-slot-name)))
+
+ (defun find-message-by-name (class super-nick message-name)
+ (let ((super (find-superclass-by-nick class super-nick)))
+ (find-item-by-name "message" super (sod-class-messages super)
+ message-name #'sod-message-name))))
+
+;;;--------------------------------------------------------------------------
+;;; Class construction.
+
+(defun make-sod-class (name superclasses pset &optional location)
+ "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
+
+ This is the main constructor function for classes. The protocol works as
+ follows. The :LISP-CLASS property in PSET is checked: if it exists, it
+ must be a symbol naming a (CLOS) class, which is used in place of
+ SOD-CLASS. All of the arguments are then passed to MAKE-INSTANCE; further
+ behaviour is left to the standard CLOS instance construction protocol; for
+ example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE.
+
+ Minimal sanity checking is done during class construction; most of it is
+ left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS).
+
+ Unused properties in PSET are diagnosed as errors."
+
+ (with-default-error-location (location)
+ (let ((class (make-instance (get-property pset :lisp-class :symbol
+ 'sod-class)
+ :name name
+ :superclasses superclasses
+ :location (file-location location)
+ :pset pset)))
+ (check-unused-properties pset)
+ class)))
+
+(defgeneric guess-metaclass (class)
+ (:documentation
+ "Determine a suitable metaclass for the CLASS.
+
+ The default behaviour is to choose the most specific metaclass of any of
+ the direct superclasses of CLASS, or to signal an error if that failed."))
+
+(defmethod guess-metaclass ((class sod-class))
+ "Default metaclass-guessing function for classes.
+
+ Return the most specific metaclass of any of the CLASS's direct
+ superclasses."
+ (do ((supers (sod-class-direct-superclasses class) (cdr supers))
+ (meta nil (let ((candidate (sod-class-metaclass (car supers))))
+ (cond ((null meta) candidate)
+ ((sod-subclass-p meta candidate) meta)
+ ((sod-subclass-p candidate meta) candidate)
+ (t (error "Unable to choose metaclass for `~A'"
+ (sod-class-name class)))))))
+ ((endp supers) meta)))
+
+(defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
+ "Specific behaviour for SOD class initialization.
+
+ Properties inspected are as follows:
+
+ * :METACLASS names the metaclass to use. If unspecified, NIL is stored,
+ and (unless you intervene later) GUESS-METACLASS will be called by
+ FINALIZE-SOD-CLASS to find a suitable default.
+
+ * :NICK provides a nickname for the class. If unspecified, a default
+ (the class's name, forced to lowercase) will be chosen in
+ FINALIZE-SOD-CLASS.
+
+ * :CHAIN 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 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 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)))))
+
+;;;--------------------------------------------------------------------------
+;;; Slot construction.
+
+(defgeneric make-sod-slot (class name type pset &optional location)
+ (:documentation
+ "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
+
+ This is the main constructor function for slots. This is a generic
+ function primarily so that the CLASS can intervene in the construction
+ process. The default method uses the :LISP-CLASS property (defaulting to
+ SOD-SLOT) to choose a (CLOS) class to instantiate. The slot is then
+ constructed by MAKE-INSTANCE passing the arguments as initargs; further
+ behaviour is left to the standard CLOS instance construction protocol; for
+ example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE.
+
+ Unused properties on PSET are diagnosed as errors."))
+
+(defmethod make-sod-slot
+ ((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)
+ :class class
+ :name name
+ :type type
+ :location (file-location location)
+ :pset pset)))
+ (with-slots (slots) class
+ (setf slots (append slots (list slot))))
+ (check-unused-properties pset))))
+
+(defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
+ "This method exists so that it isn't an error to provide a :PSET initarg
+ to (make-instance 'sod-slot ...). It does nothing."
+ (declare (ignore slot-names pset))
+ nil)
+
+;;;--------------------------------------------------------------------------
+;;; Slot initializer construction.
+
+(defgeneric make-sod-instance-initializer
+ (class nick name value-kind value-form pset &optional location)
+ (:documentation
+ "Construct and attach an instance slot initializer, to CLASS.
+
+ This is the main constructor function for instance initializers. This is
+ a generic function primarily so that the CLASS can intervene in the
+ construction process. The default method looks up the slot using
+ FIND-INSTANCE-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to
+ actually make the initializer object, and adds it to the appropriate list
+ in CLASS.
+
+ Unused properties on PSET are diagnosed as errors."))
+
+(defgeneric make-sod-class-initializer
+ (class nick name value-kind value-form pset &optional location)
+ (:documentation
+ "Construct and attach a class slot initializer, to CLASS.
+
+ This is the main constructor function for class initializers. This is a
+ generic function primarily so that the CLASS can intervene in the
+ construction process. The default method looks up the slot using
+ FIND-CLASS-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to actually
+ make the initializer object, and adds it to the appropriate list in CLASS.
+
+ Unused properties on PSET are diagnosed as errors."))
+
+(defgeneric make-sod-initializer-using-slot
+ (class slot init-class value-kind value-form pset location)
+ (:documentation
+ "Common construction protocol for slot initializers.
+
+ This generic function does the common work for constructing instance and
+ class initializers. It can usefully be specialized according to both the
+ class and slot types. The default method uses the :LISP-CLASS property
+ (defaulting to INIT-CLASS) to choose a (CLOS) class to instantiate. The
+ slot is then constructed by MAKE-INSTANCE passing the arguments as
+ initargs; further behaviour is left to the standard CLOS instance
+ construction protocol; for example, SOD-INITIALIZER defines
+ an :AFTER-method on SHARED-INITIALIZE.
+
+ Diagnosing unused properties is left for the caller (usually
+ MAKE-SOD-INSTANCE-INITIALIZER or MAKE-SOD-CLASS-INITIALIZER) to do. The
+ caller is also expected to have set WITH-DEFAULT-ERROR-LOCATION if
+ appropriate.
+
+ You are not expected to call this generic function directly; it's more
+ useful as a place to hang methods for custom initializer classes."))
+
+(defmethod make-sod-instance-initializer
+ ((class sod-class) nick name value-kind value-form pset
+ &optional location)
+ (with-default-error-location (location)
+ (let* ((slot (find-instance-slot-by-name class nick name))
+ (initializer (make-sod-initializer-using-slot
+ class slot 'sod-instance-initializer
+ value-kind value-form pset
+ (file-location location))))
+ (with-slots (instance-initializers) class
+ (setf instance-initializers (append instance-initializers
+ (list initializer))))
+ (check-unused-properties pset))))
+
+(defmethod make-sod-class-initializer
+ ((class sod-class) nick name value-kind value-form pset
+ &optional location)
+ (with-default-error-location (location)
+ (let* ((slot (find-class-slot-by-name class nick name))
+ (initializer (make-sod-initializer-using-slot
+ class slot 'sod-class-initializer
+ value-kind value-form pset
+ (file-location location))))
+ (with-slots (class-initializers) class
+ (setf class-initializers (append class-initializers
+ (list initializer))))
+ (check-unused-properties pset))))
+
+(defmethod make-sod-initializer-using-slot
+ ((class sod-class) (slot sod-slot)
+ init-class value-kind value-form pset location)
+ (make-instance (get-property pset :lisp-class :symbol init-class)
+ :class class
+ :slot slot
+ :value-kind value-kind
+ :value-form value-form
+ :location location
+ :pset pset))
+
+(defmethod shared-initialize :after
+ ((init sod-initializer) slot-names &key pset)
+ "This method exists so that it isn't an error to provide a :PSET initarg
+ to (make-instance 'sod-initializer ...). It does nothing."
+ (declare (ignore slot-names pset))
+ nil)
+
+;;;--------------------------------------------------------------------------
+;;; Message construction.
+
+(defgeneric make-sod-message (class name type pset &optional location)
+ (:documentation
+ "Construct and attach a new message with given NAME and TYPE, to CLASS.
+
+ This is the main constructor function for messages. This is a generic
+ function primarily so that the CLASS can intervene in the construction
+ process. The default method uses the :LISP-CLASS property (defaulting to
+ SOD-MESSAGE) to choose a (CLOS) class to instantiate. The message is then
+ constructed by MAKE-INSTANCE passing the arguments as initargs; further
+ behaviour is left to the standard CLOS instance construction protocol; for
+ example, SOD-MESSAGE defines an :AFTER-method on SHARED-INITIALIZE.
+
+ Unused properties on PSET are diagnosed as errors."))
+
+(defgeneric check-message-type (message type)
+ (:documentation
+ "Check that TYPE is a suitable type for MESSAGE. Signal errors if not.
+
+ This is separated out of SHARED-INITIALIZE, where it's called, so that it
+ can be overridden conveniently by subclasses."))
+
+(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)
+ :class class
+ :name name
+ :type type
+ :location (file-location location)
+ :pset pset)))
+ (with-slots (slots) class
+ (setf slots (append slots (list slot))))
+ (check-unused-properties pset))))
+
+(defmethod check-message-type ((message sod-message) (type c-function-type))
+ nil)
+(defmethod check-message-type ((message sod-message) (type c-type))
+ (error "Messages must have function type, not ~A" type))
+
+(defmethod shared-initialize :after
+ ((message sod-message) slot-names &key pset)
+ (declare (ignore slot-names pset))
+ (with-slots (type) message
+ (check-message-type message type)))
+
+;;;--------------------------------------------------------------------------
+;;; Method construction.
+
+(defgeneric make-sod-method
+ (class nick name type body pset &optional location)
+ (:documentation
+ "Construct and attach a new method to CLASS.
+
+ This is the main constructor function for methods. This is a generic
+ function primarily so that the CLASS can intervene in the message lookup
+ process, though this is actually a fairly unlikely occurrence.
+
+ The default method looks up the message using FIND-MESSAGE-BY-NAME,
+ invokes MAKE-SOD-METHOD-USING-MESSAGE to make the method object, and then
+ adds the method to the class's list of methods. This split allows the
+ message class to intervene in the class selection process, for example.
+
+ Unused properties on PSET are diagnosed as errors."))
+
+(defgeneric make-sod-method-using-message
+ (message class type body pset location)
+ (:documentation
+ "Main construction subroutine for method construction.
+
+ 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)
+ 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,
+ SOD-METHOD defines an :AFTER-method on SHARED-INITIALIZE.
+
+ Diagnosing unused properties is left for the caller (usually
+ MAKE-SOD-METHOD) to do. The caller is also expected to have set
+ WITH-DEFAULT-ERROR-LOCATION if appropriate.
+
+ You are not expected to call this generic function directly; it's more
+ useful as a place to hang methods for custom initializer classes."))
+
+(defgeneric sod-message-method-class (message class pset)
+ (:documentation
+ "Return the preferred class for methods on MESSAGE.
+
+ The message can inspect the PSET to decide on a particular message. A
+ :LISP-CLASS property will usually override this decision: it's then the
+ programmer's responsibility to ensure that the selected method class is
+ appropriate."))
+
+(defgeneric check-method-type (method message type)
+ (:documentation
+ "Check that TYPE is a suitable type for METHOD. Signal errors if not.
+
+ This is separated out of SHARED-INITIALIZE, where it's called, so that it
+ can be overridden conveniently by subclasses."))
+
+(defmethod make-sod-method
+ ((class sod-class) nick name type body pset &optional location)
+ (with-default-error-location (location)
+ (let* ((message (find-message-by-name class nick name))
+ (method (make-sod-method-using-message message class
+ type body pset
+ (file-location location))))
+ (with-slots (methods) class
+ (setf methods (append methods (list method)))))
+ (check-unused-properties pset)))
+
+(defmethod make-sod-method-using-message
+ ((message sod-message) (class sod-class) type body pset location)
+ (make-instance (or (get-property pset :lisp-class :symbol)
+ (sod-message-method-class message class pset))
+ :message message
+ :class class
+ :type type
+ :body body
+ :location location
+ :pset pset))
+
+(defmethod sod-message-method-class
+ ((message sod-message) (class sod-class) pset)
+ (declare (ignore pset))
+ 'sod-method)
+
+(defmethod check-method-type
+ ((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)
+ "Compare argument lists for compatibility.
+
+ Return true if METHOD-ARGS is a suitable method argument list
+ corresponding to the message argument list MESSAGE-ARGS. This is the case
+ if the lists are the same length, each message argument has a
+ corresponding method argument with the same type, and if the message
+ arguments end in an ellpisis, the method arguments must end with a
+ `va_list' argument. (We can't pass actual variable argument lists around,
+ except as `va_list' objects, which are devilish inconvenient things and
+ require much hacking. See the method combination machinery for details.)"
+
+ (and (= (length message-args) (length method-args))
+ (every (lambda (message-arg method-arg)
+ (if (eq message-arg :ellipsis)
+ (eq method-arg (c-type va-list))
+ (c-type-equal-p (argument-type message-arg)
+ (argument-type method-arg))))
+ message-args method-args)))
+
+(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)))
+
+ ;; Check that the arguments are named if we have a method body.
+ (with-slots (body) method
+ (unless (or (not body)
+ (every #'argument-name (c-function-arguments type)))
+ (error "Abstract declarators not permitted in method definitions"))))
+
+(defmethod shared-initialize :after
+ ((method sod-method) slot-names &key pset)
+ (declare (ignore slot-names pset))
+ (with-slots (message type) method
+ (check-method-type method message type)))
+
+;;;--------------------------------------------------------------------------
+;;; Bootstrapping the class graph.
+
+(defun bootstrap-classes ()
+ (let* ((sod-object (make-sod-class "sod_object" nil
+ (make-property-set :nick 'obj)))
+ (sod-class (make-sod-class "sod_class" (list sod-object)
+ (make-property-set :nick 'cls)))
+ (classes (list sod-object sod-class)))
+ (setf (slot-value sod-class 'chained-superclass) sod-object)
+ (dolist (class classes)
+ (setf (slot-value class 'metaclass) sod-class))
+ (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")))
+|#
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Basic definitions for classes, methods and suchlike
+;;;
+;;; (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 definitions.
+
+(defclass sod-class ()
+ ((name :initarg :name
+ :type string
+ :reader sod-class-name)
+ (location :initarg :location
+ :initform (file-location nil)
+ :type file-location
+ :reader file-location)
+ (nickname :initarg :nick
+ :type string
+ :reader sod-class-nickname)
+ (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)
+ (metaclass :initarg :metaclass
+ :type sod-class
+ :reader sod-class-metaclass)
+ (slots :initarg :slots
+ :type list
+ :initform nil
+ :accessor sod-class-slots)
+ (instance-initializers :initarg :instance-initializers
+ :type list
+ :initform nil
+ :accessor sod-class-instance-initializers)
+ (class-initializers :initarg :class-initializers
+ :type list
+ :initform nil
+ :accessor sod-class-class-initializers)
+ (messages :initarg :messages
+ :type list
+ :initform nil
+ :accessor sod-class-messages)
+ (methods :initarg :methods
+ :type list
+ :initform nil
+ :accessor sod-class-methods)
+
+ (class-precedence-list :type list :accessor sod-class-precedence-list)
+
+ (chain-head :type sod-class :accessor sod-class-chain-head)
+ (chain :type list :accessor sod-class-chain)
+ (chains :type list :accessor sod-class-chains)
+
+ (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
+ METACLASS slots are intended to be initialized when the class object is
+ constructed:
+
+ * The NAME is the identifier associated with the class in the user's
+ source file. It is used verbatim in the generated C code as a type
+ name, and must be distinct from other file-scope names in any source
+ file which includes the class definition. Furthermore, other names
+ are derived from the class name (most notably the class object
+ NAME__class), which have external linkage and must therefore be
+ distinct from all other identifiers in the program. It is forbidden
+ for a class NAME to begin with an underscore or to contain two
+ consecutive underscores.
+
+ * The LOCATION identifies where in the source the class was defined. It
+ gets used in error messages.
+
+ * The NICKNAME is a shorter identifier used to name the class in some
+ circumstances. The uniqueness requirements on NICKNAME are less
+ strict, which allows them to be shorter: no class may have two classes
+ with the same nickname on its class precedence list. Nicknames are
+ used (user-visibly) to distinguish slots and messages defined by
+ different classes, and (invisibly) in the derived names of direct
+ methods. It is forbidden for a nickname to begin with an underscore,
+ or to contain two consecutive underscores.
+
+ * The DIRECT-SUPERCLASSES are a list of the class's direct superclasses,
+ in the order that they were declared in the source. The class
+ 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 METACLASS is the class of the class object. Classes are objects
+ in their own right, and therefore must be instances of some class;
+ this class is the metaclass. Metaclasses can define additional slots
+ and methods to be provided by their instances; a class definition can
+ provide (C constant expression) initial values for the metaclass
+ instance.
+
+ The next few slots can't usually be set at object-construction time, since
+ the objects need to contain references to the class object itself.
+
+ * The SLOTS are a list of the slots defined by the class (instances of
+ SOD-SLOT). (The class will also define all of the slots defined by
+ its superclasses.)
+
+ * The INSTANCE-INITIALIZERS and CLASS-INITIALIZERS are lists of
+ initializers for slots (see SOD-INITIALIZER and subclasses), providing
+ initial values for instances of the class, and for the class's class
+ object itself, respectively.
+
+ * The MESSAGES are a list of the messages recognized by the class
+ (instances of SOD-MESSAGE and subclasses). (Note that the message
+ need not have any methods defined on it. The class will also
+ recognize all of the messages defined by its superclasses.)
+
+ * The METHODS are a list of (direct) methods defined on the class
+ (instances of SOD-METHOD and subclasses). Each method provides
+ behaviour to be invoked by a particular message recognized by the
+ class.
+
+ Other slots are computed from these in order to describe the class's
+ layout and effective methods; this is done by FINALIZE-SOD-CLASS.
+
+ FIXME: Add the necessary slots and describe them."))
+
+(defmethod print-object ((class sod-class) stream)
+ (print-unreadable-object (class stream :type t)
+ (prin1 (sod-class-name class) stream)))
+
+(defclass sod-message ()
+ ((name :initarg :name
+ :type string
+ :reader sod-message-name)
+ (location :initarg :location
+ :initform (file-location nil)
+ :type file-location
+ :reader file-location)
+ (class :initarg :class
+ :type sod-class
+ :reader sod-message-class)
+ (type :initarg :type
+ :type c-function-type
+ :reader sod-message-type))
+ (:documentation
+ "Messages the means for stimulating an object to behave.
+
+ SOD is a single-dispatch object system, like Smalltalk, C++, Python and so
+ on, but unlike CLOS and Dylan. Behaviour is invoked by `sending messages'
+ to objects. A message carries a name (distinguishing it from other
+ messages recognized by the same class), and a number of arguments; the
+ object may return a value in response. Sending a message therefore looks
+ very much like calling a function; indeed, each message bears the static
+ TYPE signature of a function.
+
+ An object reacts to being sent a message by executing an `effective
+ method', constructed from the direct methods defined on the recpient's
+ (run-time, not necessarily statically-declared) class and its superclasses
+ according to the message's `method combination'.
+
+ Much interesting work is done by subclasses of SOD-MESSAGE, which (for
+ example) specify method combinations.
+
+ The slots are as follows.
+
+ * The NAME distinguishes the message from others defined by the same
+ class. Unlike most (all?) other object systems, messages defined in
+ different classes are in distinct namespaces. It is forbidden for a
+ message name to begin with an underscore, or to contain two
+ consecutive underscores. (Final underscores are fine.)
+
+ * The LOCATION states where in the user's source the slot was defined.
+ It gets used in error messages.
+
+ * The CLASS states which class defined the message.
+
+ * The TYPE is a function type describing the message's arguments and
+ return type.
+
+ Subclasses can (and probably will) define additional slots."))
+
+(defclass sod-method ()
+ ((message :initarg :message
+ :type sod-message
+ :reader sod-method-message)
+ (location :initarg :location
+ :initform (file-location nil)
+ :type file-location
+ :reader file-location)
+ (class :initarg :class
+ :type sod-class
+ :reader sod-method-class)
+ (type :initarg :type
+ :type c-function-type
+ :reader sod-method-type)
+ (body :initarg :body
+ :type (or c-fragment null)
+ :reader sod-method-body))
+ (:documentation
+ "(Direct) methods are units of behaviour.
+
+ Methods are the unit of behaviour in SOD. Classes define direct methods
+ for particular messages.
+
+ When a message is received by an instance, all of the methods defined for
+ that message on that instance's (run-time, not static) class and its
+ superclasses are `applicable'. The applicable methods are gathered
+ together and invoked in some way; the details of this are left to the
+ `method combination', determined by the subclass of SOD-MESSAGE.
+
+ The slots are as follows.
+
+ * The MESSAGE describes which meessage invokes the method's behaviour.
+ The method is combined with other methods on the same message
+ according to the message's method combination, to form an `effective
+ method'.
+
+ * The LOCATION states where, in the user's source, the method was
+ defined. This gets used in error messages. (Depending on the user's
+ coding style, this location might be subtly different from the BODY's
+ location.)
+
+ * The CLASS specifies which class defined the method. This will be
+ either the class of the message, or one of its descendents.
+
+ * The TYPE gives the type of the method, including its arguments. This
+ will, in general, differ from the type of the message for several
+ reasons.
+
+ -- Firstly, the method type must include names for all of the
+ method's parameters. The message definition can omit the
+ parameter names (in the same way as a function declaration can).
+ Formally, the message definition can contain abstract
+ declarators, whereas method definitions must not.
+
+ -- Method combinations may require different parameter or return
+ types. For example, `before' and `after' methods don't
+ contribute to the message's return value, so they must be defined
+ as returning `void'.
+
+ -- Method combinations may permit methods whose parameter and/or
+ return types don't exactly match the corresponding types of the
+ message. For example, one might have methods with covariant
+ return types and contravariant parameter types. (This sounds
+ nice, but it doesn't actually seem like such a clever idea when
+ you consider that the co-/contravariance must hold among all the
+ applicable methods ordered according to the class precedence
+ list. As a result, a user might have to work hard to build
+ subclasses whose CPLs match the restrictions implied by the
+ method types.)
+
+ Method objects are fairly passive in the SOD translator. However,
+ subclasses of SOD-MESSAGE may (and probably will) construct instances of
+ 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."))
+
+;;;--------------------------------------------------------------------------
+;;; Classes as C types.
+
+(defclass c-class-type (simple-c-type)
+ ((class :initarg :class
+ :type (or null sod-class)
+ :accessor c-type-class))
+ (:documentation
+ "A SOD class, as a C type.
+
+ One usually handles classes as pointers, but the type refers to the actual
+ instance structure itself. Or, in fact, just the primary chain of the
+ instance (i.e., the one containing the class's own direct slots) -- which
+ is why dealing with the instance structure directly doesn't make much
+ sense.
+
+ The CLASS slot will be NIL if the class isn't defined yet, i.e., this
+ entry was constructed by a forward reference operation.
+
+ The NAME slot inherited from SIMPLE-C-TYPE is here so that we can print
+ the type even when it's a forward reference."))
+
+(defmethod c-type-equal-p and ((type-a c-class-type)
+ (type-b c-class-type))
+ (eql (c-type-class type-a) (c-type-class type-b)))
+
+(defmethod print-c-type (stream (type c-class-type) &optional colon atsign)
+ (declare (ignore colon atsign))
+ (format stream "~:@<CLASS ~@_~S~:>" (c-type-name type)))
+
+(defun find-class-type (name &optional floc)
+ "Look up NAME and return the corresponding C-CLASS-TYPE.
+
+ Returns two values: TYPE and WINP.
+
+ * If the type was found, and was a class, returns TYPE.
+
+ * If no type was found at all, returns NIL.
+
+ * If a type was found, but it wasn't a class, signals an error at FLOC."
+
+ (with-default-error-location (floc)
+ (let ((type (gethash name *type-map*)))
+ (typecase type
+ (null nil)
+ (c-class-type type)
+ (t (error "Type `~A' (~A) is not a class" name type))))))
+
+(defun make-class-type (name &optional floc)
+ "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))))))
+
+(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)
+ (cond ((not type) (error "Type `~A' not known" name))
+ (t (let ((class (c-type-class type)))
+ (unless class
+ (error "Class `~A' is incomplete" name))
+ class))))))
+
+(defun record-sod-class (class &optional (floc class))
+ "Record CLASS as being a class definition.
+
+ FLOC is the location to use in error reports."
+ (with-default-error-location (floc)
+ (let* ((name (sod-class-name class))
+ (type (make-class-type name floc)))
+ (cond ((null type) nil)
+ ((c-type-class type)
+ (cerror* "Class `~A' already defined at ~A"
+ name (file-location (c-type-class type))))
+ (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
+
+ * 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))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Computing class precedence lists
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Linearizations.
+
+;; Just for fun, we implement a wide selection. C3 seems to be clearly the
+;; best, with fewer sharp edges for the unwary.
+;;
+;; The extended precedence graph (EPG) is constructed by adding edges to the
+;; superclass graph. If A and B are classes, then write A < B if A is a
+;; (maybe indirect) subclass of B. For every two classes A and B, and for
+;; every /maximal/ subclass of both A and B (i.e., every C for which C < A
+;; and C < B, but there does not exist D such that D < A, D < B and C < D):
+;; if A precedes B in C's direct superclass list, then draw an edge A -> B,
+;; otherwise draw the edge B -> A.
+;;
+;; A linearization respects the EPG if, whenever A precedes B in the
+;; linearization, there is a path from A to B. The EPG can be cyclic; in
+;; that case, we don't care which order the classes in the cycle are
+;; linearized.
+;;
+;; See Barrett, Cassels, Haahr, Moon, Playford, Withington, `A Monotonic
+;; Superclass Linearization for Dylan' for more detail.
+;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html
+
+(defun clos-tiebreaker (candidates so-far)
+ "The CLOS linearization tiebreaker function.
+
+ Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which
+ has a direct subclass furthest to the right in the list SO-FAR.
+
+ This must disambiguate. The SO-FAR list cannot be empty, since the class
+ under construction precedes all of the others. If two classes share a
+ direct subclass then that subclass's direct superclasses list must order
+ them relative to each other."
+
+ (let (winner)
+ (dolist (class so-far)
+ (dolist (candidate candidates)
+ (when (member candidate (sod-class-direct-superclasses class))
+ (setf winner candidate))))
+ (unless winner
+ (error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
+ winner))
+
+(defun clos-cpl (class)
+ "Compute the class precedence list of CLASS using CLOS linearization rules.
+
+ We merge the direct-superclass lists of all of CLASS's superclasses,
+ disambiguating using CLOS-TIEBREAKER.
+
+ The CLOS linearization preserves local class ordering, but is not
+ monotonic, and does not respect the extended precedence graph. CLOS
+ linearization will succeed whenever Dylan or C3 linearization succeeds;
+ the converse is not true."
+
+ (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))))))
+ (merge-lists (mapcar (lambda (class)
+ (cons class
+ (sod-class-direct-superclasses class)))
+ (superclasses class))
+ :pick #'clos-tiebreaker)))
+
+(defun dylan-cpl (class)
+ "Compute the class precedence list of CLASS using Dylan linearization
+ rules.
+
+ We merge the direct-superclass list of CLASS with the full class
+ precedence lists of its direct superclasses, disambiguating using
+ CLOS-TIEBREAKER. (Inductively, these lists will be consistent with the
+ CPLs of indirect superclasses, since those CPLs' orderings are reflected
+ in the CPLs of the direct superclasses.)
+
+ The Dylan linearization preserves local class ordering and is monotonic,
+ but does not respect the extended precedence graph.
+
+ Note that this will merge the CPLs of superclasses /as they are/, not
+ necessarily as Dylan would have computed them. This ensures monotonicity
+ assuming that the superclass CPLs are already monotonic. If they aren't,
+ you're going to lose anyway."
+
+ (let ((direct-supers (sod-class-direct-superclasses class)))
+ (merge-lists (cons (cons class direct-supers)
+ (mapcar #'sod-class-precedence-list direct-supers))
+ :pick #'clos-tiebreaker)))
+
+(defun c3-tiebreaker (candidates cpls)
+ "The C3 linearization tiebreaker function.
+
+ Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which
+ appears in the earliest element of CPLS, which should be the list of the
+ class precedence lists of the direct superclasses of the class in
+ question, in the order specified in the class declaration.
+
+ The only class in the class precedence list which does not appear in one
+ of these lists is the new class itself, which must precede all of the
+ others.
+
+ This must disambiguate, since if two classes are in the same class
+ precedence list, then one must appear in it before the other, which
+ provides an ordering between them. (In this situation we return the one
+ that matches earliest anyway, which would still give the right answer.)
+
+ Note that this will merge the CPLs of superclasses /as they are/, not
+ necessarily as C3 would have computed them. This ensures monotonicity
+ assuming that the superclass CPLs are already monotonic. If they aren't,
+ you're going to lose anyway."
+
+ (dolist (cpl cpls)
+ (dolist (candidate candidates)
+ (when (member candidate cpl)
+ (return-from c3-tiebreaker candidate))))
+ (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
+
+(defun c3-cpl (class)
+ "Compute the class precedence list of CLASS using C3 linearization rules.
+
+ We merge the direct-superclass list of CLASS with the full class
+ precedence lists of its direct superclasses, disambiguating using
+ C3-TIEBREAKER.
+
+ The C3 linearization preserves local class ordering, is monotonic, and
+ respects the extended precedence graph. It is the linearization used in
+ Python, Perl 6 and other languages. It is the recommended linearization
+ for SOD."
+
+ (let* ((direct-supers (sod-class-direct-superclasses class))
+ (cpls (mapcar #'sod-class-precedence-list direct-supers)))
+ (merge-lists (cons (cons class direct-supers) cpls)
+ :pick (lambda (candidates so-far)
+ (declare (ignore so-far))
+ (c3-tiebreaker candidates cpls)))))
+
+(defun flavors-cpl (class)
+ "Compute the class precedence list of CLASS using Flavors linearization
+ rules.
+
+ We do a depth-first traversal of the superclass graph, ignoring duplicates
+ of classes we've already visited. Interestingly, this has the property of
+ being able to tolerate cyclic superclass graphs, though defining cyclic
+ graphs is syntactically impossible in SOD.
+
+ This linearization has few other redeeming features, however. In
+ particular, the top class tends not to be at the end of the CPL, despite
+ it being unequivocally less specific than any other class."
+
+ (let ((done nil))
+ (labels ((walk (class)
+ (unless (member class done)
+ (push class done)
+ (dolist (super (sod-class-direct-superclasses class))
+ (walk super)))))
+ (walk class)
+ (nreverse done))))
+
+(defun python-cpl (class)
+ "Compute the class precedence list of CLASS using the documented Python 2.2
+ linearization rules.
+
+ We do a depth-first traversal of the superclass graph, retaining only the
+ last occurrence of each class visited.
+
+ This linearization has few redeeming features. It was never actually
+ implemented; the true Python 2.2 linearization seems closer to (but
+ different from) L*LOOPS."
+
+ (let ((done nil))
+ (labels ((walk (class)
+ (push class done)
+ (dolist (super (sod-class-direct-superclasses class))
+ (walk super))))
+ (walk class)
+ (delete-duplicates (nreverse done)))))
+
+(defun l*loops-cpl (class)
+ "Compute the class precedence list of CLASS using L*LOOPS linearization
+ rules.
+
+ We merge the class precedence lists of the direct superclasses of CLASS,
+ disambiguating by choosing the earliest candidate which appears in a
+ depth-first walk of the superclass graph.
+
+ The L*LOOPS rules are monotonic and respect the extended precedence
+ graph. However (unlike Dylan and CLOS) they don't respect local
+ precedence order i.e., the direct-superclasses list orderings."
+
+ (let ((dfs (flavors-cpl class)))
+ (cons class (merge-lists (mapcar #'sod-class-precedence-list
+ (sod-class-direct-superclasses class))
+ :pick (lambda (candidates so-far)
+ (declare (ignore so-far))
+ (dolist (class dfs)
+ (when (member class candidates)
+ (return class))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Class protocol.
+
+(defgeneric compute-cpl (class)
+ (:documentation
+ "Returns the class precedence list for CLASS."))
+
+(defmethod compute-cpl ((class sod-class))
+ (handler-case (c3-cpl class)
+ (inconsistent-merge-error ()
+ (error "Failed to compute class precedence list for `~A'"
+ (sod-class-name class)))))
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
+
+#+test
+(progn
+ (defclass test-class ()
+ ((name :initarg :name :accessor sod-class-name)
+ (direct-superclasses :initarg :superclasses
+ :accessor sod-class-direct-superclasses)
+ (class-precedence-list)))
+
+ (defmethod print-object ((class test-class) stream)
+ (if *print-escape*
+ (print-unreadable-object (class stream :type t :identity nil)
+ (princ (sod-class-name class) stream))
+ (princ (sod-class-name class) stream)))
+
+ (defvar *test-linearization*)
+
+ (defmethod sod-class-precedence-list ((class test-class))
+ (if (slot-boundp class 'class-precedence-list)
+ (slot-value class 'class-precedence-list)
+ (setf (slot-value class 'class-precedence-list)
+ (funcall *test-linearization* class)))))
+
+#+test
+(defun test-cpl (linearization heterarchy)
+ (let* ((*test-linearization* linearization)
+ (classes (make-hash-table :test #'equal)))
+ (dolist (class heterarchy)
+ (let ((name (car class)))
+ (setf (gethash (car class) classes)
+ (make-instance 'test-class :name name))))
+ (dolist (class heterarchy)
+ (setf (sod-class-direct-superclasses (gethash (car class) classes))
+ (mapcar (lambda (super) (gethash super classes)) (cdr class))))
+ (mapcar (lambda (class)
+ (handler-case
+ (mapcar #'sod-class-name
+ (sod-class-precedence-list (gethash (car class)
+ classes)))
+ (inconsistent-merge-error ()
+ (list (car class) :error))))
+ heterarchy)))
+
+#+test
+(progn
+ (defparameter *confused-heterarchy*
+ '((object) (grid-layout object)
+ (horizontal-grid grid-layout) (vertical-grid grid-layout)
+ (hv-grid horizontal-grid vertical-grid)
+ (vh-grid vertical-grid horizontal-grid)
+ (confused-grid hv-grid vh-grid)))
+ (defparameter *boat-heterarchy*
+ '((object)
+ (boat object)
+ (day-boat boat)
+ (wheel-boat boat)
+ (engine-less day-boat)
+ (small-multihull day-boat)
+ (pedal-wheel-boat engine-less wheel-boat)
+ (small-catamaran small-multihull)
+ (pedalo pedal-wheel-boat small-catamaran)))
+ (defparameter *menu-heterarchy*
+ '((object)
+ (choice-widget object)
+ (menu choice-widget)
+ (popup-mixin object)
+ (popup-menu menu popup-mixin)
+ (new-popup-menu menu popup-mixin choice-widget)))
+ (defparameter *pane-heterarchy*
+ '((pane) (scrolling-mixin) (editing-mixin)
+ (scrollable-pane pane scrolling-mixin)
+ (editable-pane pane editing-mixin)
+ (editable-scrollable-pane scrollable-pane editable-pane)))
+ (defparameter *baker-nonmonotonic-heterarchy*
+ '((z) (x z) (y) (b y) (a b x) (c a b x y)))
+ (defparameter *baker-nonassociative-heterarchy*
+ '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
+ (defparameter *distinguishing-heterarchy*
+ '((object)
+ (a object) (b object) (c object)
+ (p a b) (q a c)
+ (u p) (v q)
+ (x u v)
+ (y x b c)
+ (z x c b)))
+ (defparameter *python-heterarchy*
+ '((object)
+ (a object) (b object) (c object) (d object) (e object)
+ (k1 a b c)
+ (k2 d b e)
+ (k3 d a)
+ (z k1 k2 k3))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;;--------------------------------------------------------------------------
+;;; C types stuff.
+
+(cl:defpackage #:c-types
+ (:use #:common-lisp
+ #+sbcl #:sb-mop
+ #+(or cmu clisp) #:mop
+ #+ecl #:clos)
+ (:export #:c-type
+ #:c-declarator-priority #:maybe-parenthesize
+ #:c-declaration
+ #:c-type-subtype #:compount-type-declaration
+ #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
+ #:simple-c-type #:c-type-name
+ #:c-pointer-type
+ #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
+ #:tagged-c-type-kind
+ #:c-array-type #:c-array-dimensions
+ #:make-argument #:argument-name #:argument-type
+ #:c-function-type #:c-function-arguments
+
+ #:define-c-type-syntax #:c-type-alias #:defctype
+ #:print-c-type
+ #:qualifier #:declare-qualifier
+ #:define-simple-c-type
+
+ #:const #:volatile #:static #:restrict
+ #:char #:unsigned-char #:uchar #:signed-char #:schar
+ #:int #:signed #:signed-int #:sint
+ #:unsigned #:unsigned-int #:uint
+ #:short #:signed-short #:short-int #:signed-short-int #:sshort
+ #:unsigned-short #:unsigned-short-int #:ushort
+ #:long #:signed-long #:long-int #:signed-long-int #:slong
+ #:unsigned-long #:unsigned-long-int #:ulong
+ #:float #:double #:long-double
+ #:pointer #:ptr
+ #:[] #:vec
+ #:fun #:func #:fn))
+
+
+;;;--------------------------------------------------------------------------
+;;; Convenient syntax for C types.
+
+;; Basic machinery.
+
+;; Qualifiers. They have hairy syntax and need to be implemented by hand.
+
+;; Simple types.
+
+;; Pointers.
+
+;; Tagged types.
+
+;; Arrays.
+
+;; Functions.
+
+
+(progn
+ (defconstant q-byte (byte 3 0))
+ (defconstant q-const 1)
+ (defconstant q-volatile 2)
+ (defconstant q-restrict 4)
+
+ (defconstant z-byte (byte 3 3))
+ (defconstant z-unspec 0)
+ (defconstant z-short 1)
+ (defconstant z-long 2)
+ (defconstant z-long-long 3)
+ (defconstant z-double 4)
+ (defconstant z-long-double 5)
+
+ (defconstant s-byte (byte 2 6))
+ (defconstant s-unspec 0)
+ (defconstant s-signed 1)
+ (defconstant s-unsigned 2)
+
+ (defconstant t-byte (byte 3 8))
+ (defconstant t-unspec 0)
+ (defconstant t-int 1)
+ (defconstant t-char 2)
+ (defconstant t-float 3)
+ (defconstant t-user 4))
+
+(defun make-type-flags (size sign type &rest quals)
+ (let ((flags 0))
+ (dolist (qual quals)
+ (setf flags (logior flags qual)))
+ (setf (ldb z-byte flags) size
+ (ldb s-byte flags) sign
+ (ldb t-byte flags) type)
+ flags))
+
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Error types and handling utilities
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Enclosing conditions.
+
+(define-condition enclosing-condition (condition)
+ ((enclosed-condition :initarg :condition
+ :type condition
+ :reader enclosed-condition))
+ (:documentation
+ "A condition which encloses another condition
+
+ This is useful if one wants to attach additional information to an
+ existing condition. The enclosed condition can be obtained using the
+ ENCLOSED-CONDITION function.")
+ (:report (lambda (condition stream)
+ (princ (enclosed-condition condition) stream))))
+
+;;;--------------------------------------------------------------------------
+;;; Conditions with location information.
+
+(define-condition condition-with-location (condition)
+ ((location :initarg :location
+ :reader file-location
+ :type file-location))
+ (:documentation
+ "A condition which has some location information attached."))
+
+(define-condition enclosing-condition-with-location
+ (condition-with-location enclosing-condition)
+ ())
+
+(define-condition error-with-location (condition-with-location error)
+ ())
+
+(define-condition warning-with-location (condition-with-location warning)
+ ())
+
+(define-condition enclosing-error-with-location
+ (enclosing-condition-with-location error)
+ ())
+
+(define-condition enclosing-warning-with-location
+ (enclosing-condition-with-location warning)
+ ())
+
+(define-condition simple-condition-with-location
+ (condition-with-location simple-condition)
+ ())
+
+(define-condition simple-error-with-location
+ (error-with-location simple-error)
+ ())
+
+(define-condition simple-warning-with-location
+ (warning-with-location simple-warning)
+ ())
+
+;;;--------------------------------------------------------------------------
+;;; Error reporting functions.
+
+(defun make-condition-with-location (default-type floc datum &rest arguments)
+ "Construct a CONDITION-WITH-LOCATION given a condition designator.
+
+ The returned condition will always be a CONDITION-WITH-LOCATION. The
+ process consists of two stages. In the first stage, a condition is
+ constructed from the condition designator DATUM and ARGUMENTS with default
+ type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM:
+
+ * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an
+ empty list.
+
+ * If DATUM is a symbol, then it must name a condition type. An instance
+ of this class is constructed using ARGUMENTS as initargs, i.e., as
+ if (apply #'make-condition ARGUMENTS); if the type is a subtype of
+ CONDITION-WITH-LOCATION then FLOC is attached as the location.
+
+ * If DATUM is a format control (i.e., a string or function), then the
+ condition is constructed as if, instead, DEFAULT-TYPE had been
+ supplied as DATUM, and the list (:format-control DATUM
+ :format-arguments ARGUMENTS) supplied as ARGUMENTS.
+
+ In the second stage, the condition constructed by the first stage is
+ converted into a CONDITION-WITH-LOCATION. If the condition already has
+ type CONDITION-WITH-LOCATION then it is returned as is. Otherwise it is
+ wrapped in an appropriate subtype of ENCLOSING-CONDITION-WITH-LOCATION:
+ if the condition was a subtype of ERROR or WARNING then the resulting
+ condition will also be subtype of ERROR or WARNING as appropriate."
+
+ (labels ((wrap (condition)
+ (make-condition
+ (etypecase condition
+ (error 'enclosing-error-with-location)
+ (warning 'enclosing-warning-with-location)
+ (condition 'enclosing-condition-with-location))
+ :condition condition
+ :location (file-location floc)))
+ (make (type &rest initargs)
+ (if (subtypep type 'condition-with-location)
+ (apply #'make-condition type
+ :location (file-location floc)
+ initargs)
+ (wrap (apply #'make-condition type initargs)))))
+ (etypecase datum
+ (condition-with-location datum)
+ (condition (wrap datum))
+ (symbol (apply #'make arguments))
+ ((or string function) (make default-type
+ :format-control datum
+ :format-arguments arguments)))))
+
+(defun error-with-location (floc datum &rest arguments)
+ "Report an error with attached location information."
+ (error (apply #'make-condition-with-location
+ 'simple-error-with-location
+ floc datum arguments)))
+
+(defun warn-with-location (floc datum &rest arguments)
+ "Report a warning with attached location information."
+ (warn (apply #'make-condition-with-location
+ 'simple-warning-with-location
+ floc datum arguments)))
+
+(defun cerror-with-location (floc continue-string datum &rest arguments)
+ "Report a continuable error with attached location information."
+ (cerror continue-string
+ (apply #'make-condition-with-location
+ 'simple-error-with-location
+ floc datum arguments)))
+
+(defun cerror* (datum &rest arguments)
+ (apply #'cerror "Continue" datum arguments))
+
+(defun cerror*-with-location (floc datum &rest arguments)
+ (apply #'cerror-with-location floc "Continue" datum arguments))
+
+(defun count-and-report-errors* (thunk)
+ "Invoke THUNK in a dynamic environment which traps and reports errors.
+
+ See the COUNT-AND-REPORT-ERRORS macro for more detais."
+
+ (let ((errors 0)
+ (warnings 0))
+ (handler-bind
+ ((error (lambda (error)
+ (let ((fatal (not (find-restart 'continue error))))
+ (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%"
+ (file-location error)
+ fatal
+ error)
+ (incf errors)
+ (if fatal
+ (return-from count-and-report-errors*
+ (values nil errors warnings))
+ (invoke-restart 'continue)))))
+ (warning (lambda (warning)
+ (format *error-output* "~&~A: Warning: ~A~%"
+ (file-location warning)
+ warning)
+ (incf warnings)
+ (invoke-restart 'muffle-warning))))
+ (values (funcall thunk)
+ errors
+ warnings))))
+
+(defmacro count-and-report-errors (() &body body)
+ "Evaluate BODY in a dynamic environment which traps and reports errors.
+
+ The BODY is evaluated. If an error or warning is signalled, it is
+ reported (using its report function), and counted. Warnings are otherwise
+ muffled; continuable errors (i.e., when a CONTINUE restart is defined) are
+ continued; non-continuable errors cause an immediate exit from the BODY.
+
+ The final value consists of three values: the primary value of the BODY
+ (or NIL if a non-continuable error occurred), the number of errors
+ reported, and the number of warnings reported."
+ `(count-and-report-errors* (lambda () ,@body)))
+
+(defun with-default-error-location* (floc thunk)
+ "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and
+ other conditions) which do not have file location information attached to
+ them already.
+
+ See the WITH-DEFAULT-ERROR-LOCATION macro for more details."
+
+ (if floc
+ (handler-bind
+ ((condition-with-location (lambda (condition)
+ (declare (ignore condition))
+ :decline))
+ (condition (lambda (condition)
+ (signal (make-condition-with-location nil
+ floc
+ condition)))))
+ (funcall thunk))
+ (funcall thunk)))
+
+(defmacro with-default-error-location ((floc) &body body)
+ "Evaluate BODY in a dynamic environment which attaches FLOC to errors (and
+ other conditions) which do not have file location information attached to
+ them already.
+
+ If a condition other than a CONDITION-WITH-LOCATION is signalled during
+ the evaluation of the BODY, then an instance of an appropriate subtype of
+ ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the original
+ condition, and signalled. If the original condition was a subtype of
+ ERROR or WARNING, then the new condition will also be a subtype of ERROR
+ or WARNING as appropriate.
+
+ The FLOC argument is coerced to a FILE-LOCATION object each time a
+ condition is signalled. For example, if FLOC is a lexical analyser object
+ which reports its current position in response to FILE-LOCATION, then each
+ condition will be reported as arising at the lexer's current position at
+ that time, rather than all being reported at the same position.
+
+ If the new enclosing condition is not handled, the handler established by
+ this macro will decline to handle the original condition. Typically,
+ however, the new condition will be handled by COUNT-AND-REPORT-ERRORS."
+ `(with-default-error-location* ,floc (lambda () ,@body)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Layout for instances and vtables
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; 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 --------------------------------------------------
--- /dev/null
+* Instance layout
+
+This is fairly easy. The superclasses are partitioned into chains.
+Each chain is named after its head class (i.e., the class with no
+successor).
+
+** Things in instance layouts
+
+An instance layout contains a chunk for each component chain.
+
+ struct CLASS__ilayout {
+ struct CLASS__ichain_CHAINn NICKn;
+ /* ... */
+ };
+
+An ilayout is a C structure consisting of an ichain for each of the
+class's chains, with the primary chain first. The others are in
+direct-superclass order.
+
+** Instance slots
+
+An islots structure is a C structure consisting of a class's instance
+slots, in order.
+
+ struct CLASS__islots {
+ TYPEn SLOTn;
+ /* ... */
+ };
+
+If a class defines no slots then it has no islots structure.
+
+** Instance chains
+
+ struct CLASS__ichain_CHAIN {
+ const struct CLASS__vt_CHAIN *_vt;
+ struct SUPERn__islots NICKn;
+ /* ... */
+ };
+
+A ichain is a C structure consisting of:
+
+ * A pointer `_vt' to the chain's vtable structure.
+
+ * An islots substructure, named after the class's nick for each class
+ on the chain, least-specific first.
+
+Because of the chain invariant, all of a class's ichains are prefixes of
+the corresponding ichains of any of its subclasses.
+
+The type CLASS is an alias for the class's primary ichain
+CLASS__ichain_CHAIN. One needs to do a cross-chain upcast to find slots
+in non-primary chains.
+
+* Vtable layout
+
+This is more complicated. The vtable for a chain doesn't just contain
+things directly relevant to the classes on the chain: because a vtable
+is (assumed) immutable, we can have copies of values from other chains
+where this is convenient.
+
+Note that effective methods are customized for particular classes: they
+can assume that their argument points to a specific ichain of a an
+instance of a specific class. This makes conversions in effective
+methods very cheap. By including apparently effective-method pointers
+for messages defined in other chains, we can speed up dispatch.
+
+** Things in a vtable chain
+
+There are three kinds of items to store in a vtable chain.
+
+ * Class pointers
+ * The base offset
+ * Chain offsets
+ * Effective method pointers
+
+ struct CLASS__vt_CHAIN {
+ struct METACLASS__ichain_sod_object *_class;
+ size_t _base;
+ struct METACLASS__ichain_METACHAINn *_cls_NICKn;
+ ptrdiff_t _off_CHAINn;
+ struct SUPERn__vtmsgs NICKn;
+ };
+
+A class has a separate vtable chain for each of its chains.
+
+** The base offset
+
+There is a single member _base which is the offset of the chain's ichain
+in the overall ilayout structure. This lets you find the bottom of the
+ilayout given a pointer to any ichain as
+
+ (CLASS__ilayout *)((char *)p - p->_vt._base)
+
+** Class pointers
+
+The class's metaclass may have multiple chains. For each chain of the
+metaclass, there is a separate pointer to that metaclass's ichain, named
+_cls_NICKn after the metaclass's chain head. Exception: _cls_cls is
+called _class instead.
+
+** Chain offsets
+
+For each other chain, there is a member _off_NICKn named after the
+chain's head giving the offset of that ichain from the current chain's
+ichain. (There's a long way around, exploring the class's layout
+information, but this provides a much easier way of doing cross-chain
+upcasts.)
+
+** Effective method pointers
+
+For each class, there may be a structure
+
+ struct CLASS__vtmsgs {
+ TYPEn (*MSGn)(ARGnn *, ...);
+ /* ... */
+ };
+
+of pointers to effective methods for the messages defined by the class.
+If a class defines no messages then it won't have a vtmsgs structure.
+
+** Layout order
+
+The first two items are always _class and _base. After that:
+
+ * for each class in the chain, from least to most specific,
+
+ * for each of that class's superclasses, in reverse class-precedence-
+ list order, which has not yet been processed:
+
+ * if the class is in a chain which hasn't been seen before (it must be
+ the chain head!), emit a chain offset for it;
+
+ * if the class has a metaclass chain which hasn't been seen before,
+ emit a class pointer for it;
+
+ * if the class has a vtmsgs structure, emit it.
+
+* Questions
+
+Are class-slot initializers inherited? No. We have instance
+initializers on metaclasses for that.
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Lexical analysis of a vaguely C-like language
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Basic lexical analyser infrastructure.
+
+;; Class definition.
+
+(defclass lexer ()
+ ((stream :initarg :stream
+ :type stream
+ :reader lexer-stream)
+ (char :initform nil
+ :type (or character null)
+ :reader lexer-char)
+ (pushback-chars :initform nil
+ :type list)
+ (token-type :initform nil
+ :accessor token-type)
+ (token-value :initform nil
+ :accessor token-value)
+ (pushback-tokens :initform nil
+ :type list))
+ (:documentation
+ "Base class for lexical analysers.
+
+ The lexer reads characters from STREAM, which, for best results, wants to
+ be a POSITION-AWARE-INPUT-STREAM.
+
+ The lexer provides one-character lookahead by default: the current
+ lookahead character is available to subclasses in the slot CHAR. Before
+ beginning lexical analysis, the lookahead character needs to be
+ established with NEXT-CHAR. If one-character lookahead is insufficient,
+ the analyser can push back an arbitrary number of characters using
+ PUSHBACK-CHAR.
+
+ The NEXT-TOKEN function scans and returns the next token from the STREAM,
+ and makes it available as TOKEN-TYPE and TOKEN-VALUE, providing one-token
+ lookahead. A parser using the lexical analyser can push back tokens using
+ PUSHBACK-TOKENS.
+
+ For convenience, the lexer implements a FILE-LOCATION method (delegated to
+ the underlying stream)."))
+
+;; Lexer protocol.
+
+(defgeneric scan-token (lexer)
+ (:documentation
+ "Internal function for scanning tokens from an input stream.
+
+ Implementing a method on this function is the main responsibility of LEXER
+ subclasses; it is called by the user-facing NEXT-TOKEN function.
+
+ The method should consume characters (using NEXT-CHAR) as necessary, and
+ return two values: a token type and token value. These will be stored in
+ the corresponding slots in the lexer object in order to provide the user
+ with one-token lookahead."))
+
+(defgeneric next-token (lexer)
+ (:documentation
+ "Scan a token from an input stream.
+
+ This function scans a token from an input stream. Two values are
+ returned: a `token type' and a `token value'. These are opaque to the
+ LEXER base class, but the intent is that the token type be significant to
+ determining the syntax of the input, while the token value carries any
+ additional information about the token's semantic content. The token type
+ and token value are also made available for lookahead via accessors
+ TOKEN-TYPE and TOKEN-NAME on the LEXER object.
+
+ If tokens have been pushed back (see PUSHBACK-TOKEN) then they are
+ returned one by one instead of scanning the stream.")
+
+ (:method ((lexer lexer))
+ (with-slots (pushback-tokens token-type token-value) lexer
+ (setf (values token-type token-value)
+ (if pushback-tokens
+ (let ((pushback (pop pushback-tokens)))
+ (values (car pushback) (cdr pushback)))
+ (scan-token lexer))))))
+
+(defgeneric pushback-token (lexer token-type &optional token-value)
+ (:documentation
+ "Push a token back into the lexer.
+
+ Make the given TOKEN-TYPE and TOKEN-VALUE be the current lookahead token.
+ The previous lookahead token is pushed down, and will be made available
+ agan once this new token is consumed by NEXT-TOKEN. The FILE-LOCATION is
+ not affected by pushing tokens back. The TOKEN-TYPE and TOKEN-VALUE be
+ anything at all: for instance, they need not be values which can actually
+ be returned by NEXT-TOKEN.")
+
+ (:method ((lexer lexer) new-token-type &optional new-token-value)
+ (with-slots (pushback-tokens token-type token-value) lexer
+ (push (cons token-type token-value) pushback-tokens)
+ (setf token-type new-token-type
+ token-value new-token-value))))
+
+(defgeneric next-char (lexer)
+ (:documentation
+ "Fetch the next character from the LEXER's input stream.
+
+ Read a character from the input stream, and store it in the LEXER's CHAR
+ slot. The character stored is returned. If characters have been pushed
+ back then pushed-back characters are used instead of the input stream.
+
+ (This function is primarily intended for the use of lexer subclasses.)")
+
+ (:method ((lexer lexer))
+ (with-slots (stream char pushback-chars) lexer
+ (setf char (if pushback-chars
+ (pop pushback-chars)
+ (read-char stream nil))))))
+
+(defgeneric pushback-char (lexer char)
+ (:documentation
+ "Push the CHAR back into the lexer.
+
+ Make CHAR be the current lookahead character (stored in the LEXER's CHAR
+ slot). The previous lookahead character is pushed down, and will be made
+ available again once this character is consumed by NEXT-CHAR.
+
+ (This function is primarily intended for the use of lexer subclasses.)")
+
+ (:method ((lexer lexer) new-char)
+ (with-slots (char pushback-chars) lexer
+ (push char pushback-chars)
+ (setf char new-char))))
+
+(defgeneric fixup-stream* (lexer thunk)
+ (:documentation
+ "Helper function for WITH-LEXER-STREAM.
+
+ This function does the main work for WITH-LEXER-STREAM. The THUNK is
+ invoked on a single argument, the LEXER's underlying STREAM.")
+
+ (:method ((lexer lexer) thunk)
+ (with-slots (stream char pushback-chars) lexer
+ (when pushback-chars
+ (error "Lexer has pushed-back characters."))
+ (unread-char char stream)
+ (unwind-protect
+ (funcall thunk stream)
+ (setf char (read-char stream nil))))))
+
+(defmacro with-lexer-stream ((streamvar lexer) &body body)
+ "Evaluate BODY with STREAMVAR bound to the LEXER's input stream.
+
+ The STREAM is fixed up so that the next character read (e.g., using
+ READ-CHAR) will be the lexer's current lookahead character. Once the BODY
+ completes, the next character in the stream is read and set as the
+ lookahead character. It is an error if the lexer has pushed-back
+ characters (since these can't be pushed back into the input stream
+ properly)."
+
+ `(fixup-stream* ,lexer
+ (lambda (,streamvar)
+ ,@body)))
+
+(defmethod file-location ((lexer lexer))
+ (with-slots (stream) lexer
+ (file-location stream)))
+
+(defgeneric skip-spaces (lexer)
+ (:documentation
+ "Skip over whitespace characters in the LEXER.")
+ (:method ((lexer lexer))
+ (do ((ch (lexer-char lexer) (next-char lexer)))
+ ((not (whitespace-char-p ch))))))
+
+;;;--------------------------------------------------------------------------
+;;; Lexer utilities.
+
+(defun require-token
+ (lexer wanted-token-type &key (errorp t) (consumep t) default)
+ (with-slots (token-type token-value) lexer
+ (cond ((eql token-type wanted-token-type)
+ (prog1 token-value
+ (when consumep (next-token lexer))))
+ (errorp
+ (cerror* "Expected ~A but found ~A"
+ (format-token wanted-token-type)
+ (format-token token-type token-value))
+ default)
+ (t
+ default))))
+
+;;;--------------------------------------------------------------------------
+;;; Our main lexer.
+
+(defun make-keyword-table (&rest keywords)
+ "Construct a keyword table for the lexical analyser.
+
+ The KEYWORDS arguments are individual keywords, either as strings or as
+ (WORD . VALUE) pairs. A string argument is equivalent to a pair listing
+ the string itself as WORD and the corresponding keyword symbol (forced to
+ uppercase) as the VALUE."
+
+ (let ((table (make-hash-table :test #'equal)))
+ (dolist (item keywords)
+ (multiple-value-bind (word keyword)
+ (if (consp item)
+ (values (car item) (cdr item))
+ (values item (intern (string-upcase item) :keyword)))
+ (setf (gethash word table) keyword)))
+ table))
+
+(defparameter *sod-keywords*
+ (make-keyword-table
+
+ ;; Words with important meanings to us.
+ "class"
+ "import" "load" "lisp" "typename"
+ "source" "header"
+
+ ;; Words with a meaning to C's type system.
+ "char" "int" "float" "void"
+ "long" "short" "signed" "unsigned" "double"
+ "const" "volatile" "restrict"
+ "struct" "union" "enum"))
+
+(defclass sod-lexer (lexer)
+ ((keywords :initarg :keywords
+ :initform *sod-keywords*
+ :type hash-table
+ :reader lexer-keywords))
+ (:documentation
+ "Lexical analyser for the SOD lanuage.
+
+ See the LEXER class for the gory details about the lexer protocol."))
+
+(defun format-token (token-type &optional token-value)
+ (when (typep token-type 'lexer)
+ (let ((lexer token-type))
+ (setf token-type (token-type lexer)
+ token-value (token-value lexer))))
+ (etypecase token-type
+ ((eql :eof) "<end-of-file>")
+ ((eql :string) "<string-literal>")
+ ((eql :char) "<character-literal>")
+ ((eql :id) (format nil "<identifier~@[ `~A'~]>" token-value))
+ (keyword (format nil "`~(~A~)'" token-type))
+ (character (format nil "~:[<~:C>~;`~C'~]"
+ (and (graphic-char-p token-type)
+ (char/= token-type #\space))
+ token-type))))
+
+(defmethod scan-token ((lexer sod-lexer))
+ (with-slots (stream char keywords) lexer
+ (prog ((ch char))
+
+ consider
+ (cond
+
+ ;; End-of-file brings its own peculiar joy.
+ ((null ch) (return (values :eof t)))
+
+ ;; Ignore whitespace and continue around for more.
+ ((whitespace-char-p ch) (go scan))
+
+ ;; Strings.
+ ((or (char= ch #\") (char= ch #\'))
+ (with-default-error-location (file-location lexer)
+ (let* ((quote ch)
+ (string
+ (with-output-to-string (out)
+ (loop
+ (flet ((getch ()
+ (setf ch (next-char lexer))
+ (when (null ch)
+ (cerror* floc
+ "Unexpected end of file in string/character constant")
+ (return))))
+ (getch)
+ (cond ((char= ch quote) (return))
+ ((char= ch #\\) (getch)))
+ (write-char ch out))))))
+ (setf ch (next-char lexer))
+ (ecase quote
+ (#\" (return (values :string string)))
+ (#\' (case (length string)
+ (0 (cerror* "Empty character constant")
+ (return (values :char #\?)))
+ (1 (return (values :char (char string 0))))
+ (t (cerror*
+ "Multiple characters in character constant")
+ (return (values :char (char string 0))))))))))
+
+ ;; Pick out identifiers and keywords.
+ ((or (alpha-char-p ch) (char= ch #\_))
+
+ ;; Scan a sequence of alphanumerics and underscores. We could
+ ;; allow more interesting identifiers, but it would damage our C
+ ;; lexical compatibility.
+ (let ((id (with-output-to-string (out)
+ (loop
+ (write-char ch out)
+ (setf ch (next-char lexer))
+ (when (or (null ch)
+ (not (or (alphanumericp ch)
+ (char= ch #\_))))
+ (return))))))
+
+ ;; Check to see whether we match any keywords.
+ (multiple-value-bind (keyword foundp) (gethash id keywords)
+ (return (values (if foundp keyword :id) id)))))
+
+ ;; Pick out numbers. Currently only integers, but we support
+ ;; multiple bases.
+ ((digit-char-p ch)
+
+ ;; Sort out the prefix. If we're looking at `0b', `0o' or `0x'
+ ;; (maybe uppercase) then we've got a funny radix to deal with.
+ ;; Otherwise, a leading zero signifies octal (daft, I know), else
+ ;; we're left with decimal.
+ (multiple-value-bind (radix skip-char)
+ (if (char/= ch #\0)
+ (values 10 nil)
+ (case (and (setf ch (next-char lexer))
+ (char-downcase ch))
+ (#\b (values 2 t))
+ (#\o (values 8 t))
+ (#\x (values 16 t))
+ (t (values 8 nil))))
+
+ ;; If we last munched an interesting letter, we need to skip over
+ ;; it. That's what the SKIP-CHAR flag is for.
+ (when skip-char
+ (setf ch (next-char lexer)))
+
+ ;; Scan an integer. While there are digits, feed them into the
+ ;; accumulator.
+ (do ((accum 0 (+ (* accum radix) digit))
+ (digit (and ch (digit-char-p ch radix))
+ (and ch (digit-char-p ch radix))))
+ ((null digit) (return-from scan-token
+ (values :integer accum)))
+ (setf ch (next-char lexer)))))
+
+ ;; A slash might be the start of a comment.
+ ((char= ch #\/)
+ (setf ch (next-char lexer))
+ (case ch
+
+ ;; Comment up to the end of the line.
+ (#\/
+ (loop
+ (setf ch (next-char lexer))
+ (when (or (null ch) (char= ch #\newline))
+ (go scan))))
+
+ ;; Comment up to the next `*/'.
+ (#\*
+ (tagbody
+ top
+ (case (setf ch (next-char lexer))
+ (#\* (go star))
+ ((nil) (go done))
+ (t (go top)))
+ star
+ (case (setf ch (next-char lexer))
+ (#\* (go star))
+ (#\/ (setf ch (next-char lexer))
+ (go done))
+ ((nil) (go done))
+ (t (go top)))
+ done)
+ (go consider))
+
+ ;; False alarm. (The next character is already set up.)
+ (t
+ (return (values #\/ t)))))
+
+ ;; A dot: might be `...'. Tread carefully! We need more lookahead
+ ;; than is good for us.
+ ((char= ch #\.)
+ (setf ch (next-char lexer))
+ (cond ((eql ch #\.)
+ (setf ch (next-char lexer))
+ (cond ((eql ch #\.) (return (values :ellpisis nil)))
+ (t (pushback-char lexer #\.)
+ (return (values #\. t)))))
+ (t
+ (return (values #\. t)))))
+
+ ;; Anything else is a lone delimiter.
+ (t
+ (return (multiple-value-prog1
+ (values ch t)
+ (next-char lexer)))))
+
+ scan
+ ;; Scan a new character and try again.
+ (setf ch (next-char lexer))
+ (go consider))))
+
+;;;--------------------------------------------------------------------------
+;;; C fragments.
+
+(defclass c-fragment ()
+ ((location :initarg :location
+ :type file-location
+ :accessor c-fragment-location)
+ (text :initarg :text
+ :type string
+ :accessor c-fragment-text))
+ (:documentation
+ "Represents a fragment of C code to be written to an output file.
+
+ 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 scan-c-fragment (lexer end-chars)
+ "Snarfs a sequence of C tokens with balanced brackets.
+
+ Reads and consumes characters from the LEXER's stream, and returns them as
+ a string. The string will contain whole C tokens, up as far as an
+ occurrence of one of the END-CHARS (a list) which (a) is not within a
+ string or character literal or comment, and (b) appears at the outer level
+ of nesting of brackets (whether round, curly or square -- again counting
+ only brackets which aren't themselves within string/character literals or
+ comments. The final END-CHAR is not consumed.
+
+ An error is signalled if either the stream ends before an occurrence of
+ one of the END-CHARS, or if mismatching brackets are encountered. No
+ other attempt is made to ensure that the characters read are in fact a
+ valid C fragment.
+
+ Both original /*...*/ and new //... comments are recognized. Trigraphs
+ and digraphs are currently not recognized."
+
+ (let ((output (make-string-output-stream))
+ (ch (lexer-char lexer))
+ (start-floc (file-location lexer))
+ (delim nil)
+ (stack nil))
+
+ ;; Main loop. At the top of this loop, we've already read a
+ ;; character into CH. This is usually read at the end of processing
+ ;; the individual character, though sometimes (following `/', for
+ ;; example) it's read speculatively because we need one-character
+ ;; lookahead.
+ (block loop
+ (labels ((getch ()
+ "Read the next character into CH; complain if we hit EOF."
+ (unless (setf ch (next-char lexer))
+ (cerror*-with-location start-floc
+ "Unexpected end-of-file in C fragment")
+ (return-from loop))
+ ch)
+ (putch ()
+ "Write the character to the output buffer."
+ (write-char ch output))
+ (push-delim (d)
+ "Push a closing delimiter onto the stack."
+ (push delim stack)
+ (setf delim d)
+ (getch)))
+
+ ;; Hack: if the first character is a newline, discard it. Otherwise
+ ;; (a) the output fragment will look funny, and (b) the location
+ ;; information will be wrong.
+ (when (eql ch #\newline)
+ (getch))
+
+ ;; And fetch characters.
+ (loop
+
+ ;; Here we're outside any string or character literal, though we
+ ;; may be nested within brackets. So, if there's no delimiter, and
+ ;; we've found the end character, we're done.
+ (when (and (null delim) (member ch end-chars))
+ (return))
+
+ ;; Otherwise take a copy of the character, and work out what to do
+ ;; next.
+ (putch)
+ (case ch
+
+ ;; Starting a literal. Continue until we find a matching
+ ;; character not preceded by a `\'.
+ ((#\" #\')
+ (let ((quote ch))
+ (loop
+ (getch)
+ (putch)
+ (when (eql ch quote)
+ (return))
+ (when (eql ch #\\)
+ (getch)
+ (putch)))
+ (getch)))
+
+ ;; Various kinds of opening bracket. Stash the current
+ ;; delimiter, and note that we're looking for a new one.
+ (#\( (push-delim #\)))
+ (#\[ (push-delim #\]))
+ (#\{ (push-delim #\}))
+
+ ;; Various kinds of closing bracket. If it matches the current
+ ;; delimeter then unstack the next one along. Otherwise
+ ;; something's gone wrong: C syntax doesn't allow unmatched
+ ;; brackets.
+ ((#\) #\] #\})
+ (if (eql ch delim)
+ (setf delim (pop stack))
+ (cerror* "Unmatched `~C'." ch))
+ (getch))
+
+ ;; A slash. Maybe a comment next. But maybe not...
+ (#\/
+
+ ;; Examine the next character to find out how to proceed.
+ (getch)
+ (case ch
+
+ ;; A second slash -- eat until the end of the line.
+ (#\/
+ (putch)
+ (loop
+ (getch)
+ (putch)
+ (when (eql ch #\newline)
+ (return)))
+ (getch))
+
+ ;; A star -- eat until we find a star-slash. Since the star
+ ;; might be preceded by another star, we use a little state
+ ;; machine.
+ (#\*
+ (putch)
+ (tagbody
+
+ main
+ ;; Main state. If we read a star, switch to star state;
+ ;; otherwise eat the character and try again.
+ (getch)
+ (putch)
+ (case ch
+ (#\* (go star))
+ (t (go main)))
+
+ star
+ ;; Star state. If we read a slash, we're done; if we read
+ ;; another star, stay in star state; otherwise go back to
+ ;; main.
+ (getch)
+ (putch)
+ (case ch
+ (#\* (go star))
+ (#\/ (go done))
+ (t (go main)))
+
+ done
+ (getch)))))
+
+ ;; Something else. Eat it and continue.
+ (t (getch)))))
+
+ ;; Return the fragment we've collected.
+ (make-instance 'c-fragment
+ :location floc
+ :text (get-output-stream-string output)))))
+
+(defun c-fragment-reader (stream char arg)
+ "Reader for C-fragment syntax #{ ... stuff ... }."
+ (declare (ignore char arg))
+ (let ((lexer (make-instance 'sod-lexer
+ :stream stream)))
+ (next-char lexer)
+ (scan-c-fragment lexer '(#\}))))
+
+;;;--------------------------------------------------------------------------
+;;; Testing cruft.
+
+#+test
+(with-input-from-string (in "
+{ foo } 'x' /?/***/!
+123 0432 0b010123 0xc0ffee __burp_32 class
+...
+
+class integer : integral_domain {
+ something here;
+}
+
+")
+ (let* ((stream (make-instance 'position-aware-input-stream
+ :stream in
+ :file #p"magic"))
+ (lexer (make-instance 'sod-lexer
+ :stream stream
+ :keywords *sod-keywords*))
+ (list nil))
+ (next-char lexer)
+ (loop
+ (multiple-value-bind (tokty tokval) (next-token lexer)
+ (push (list tokty tokval) list)
+ (when (eql tokty :eof)
+ (return))))
+ (nreverse list)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Modules and module parser
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; File searching.
+
+(defparameter *module-dirs* nil
+ "A list of directories (as pathname designators) to search for files.
+
+ Both SOD module files and Lisp extension files are searched for in this
+ list. The search works by merging the requested pathname with each
+ element of this list in turn. The list is prefixed by the pathname of the
+ requesting file, so that it can refer to other files relative to wherever
+ it was found.
+
+ See FIND-FILE for the grubby details.")
+
+(defun find-file (lexer name what thunk)
+ "Find a file called NAME on the module search path, and call THUNK on it.
+
+ The file is searched for relative to the LEXER's current file, and also in
+ the directories mentioned in the *MODULE-DIRS* list. If the file is
+ found, then THUNK is invoked with two arguments: the name we used to find
+ it (which might be relative to the starting directory) and the truename
+ found by PROBE-FILE.
+
+ If the file wasn't found, or there was some kind of error, then an error
+ is signalled; WHAT should be a noun phrase describing the kind of thing we
+ were looking for, suitable for inclusion in the error message.
+
+ While FIND-FILE establishes condition handlers for its own purposes, THUNK
+ is not invoked with any additional handlers defined."
+
+ (handler-case
+ (dolist (dir (cons (stream-pathname (lexer-stream lexer))
+ *module-dirs*)
+ (values nil nil))
+ (let* ((path (merge-pathnames name dir))
+ (probe (probe-file path)))
+ (when probe
+ (return (values path probe)))))
+ (file-error (error)
+ (error "Error searching for ~A ~S: ~A" what (namestring name) error))
+ (:no-error (path probe)
+ (cond ((null path)
+ (error "Failed to find ~A ~S" what name))
+ (t
+ (funcall thunk path probe))))))
+
+;;;--------------------------------------------------------------------------
+;;; Modules.
+
+(defclass module ()
+ ((name :initarg :name
+ :type pathname
+ :accessor module-name)
+ (plist :initform nil
+ :initarg :plist
+ :type list
+ :accessor module-plist)
+ (classes :initform nil
+ :initarg :classes
+ :type list
+ :accessor module-classes)
+ (source-fragments :initform nil
+ :initarg :source-fragments
+ :type list
+ :accessor module-source-fragments)
+ (header-fragments :initform nil
+ :initarg :header-fragments
+ :type list
+ :accessor module-header-fragments)
+ (dependencies :initform nil
+ :initarg :dependencies
+ :type list
+ :accessor module-dependencies))
+ (:documentation
+ "A module is a container for the definitions made in a source file.
+
+ Modules are the fundamental units of translation. The main job of a
+ module is to remember which definitions it contains, so that they can be
+ translated and written to output files. The module contains the following
+ handy bits of information:
+
+ * A (path) name, which is the filename we used to find it. The default
+ output filenames are derived from this. (We use the file's truename
+ as the hash key to prevent multiple inclusion, and that's a different
+ thing.)
+
+ * A property list containing other useful things.
+
+ * A list of the classes defined in the source file.
+
+ * Lists of C fragments to be included in the output header and C source
+ files.
+
+ * A list of other modules that this one depends on.
+
+ Modules are usually constructed by the PARSE-MODULE function, which is in
+ turn usually invoked by IMPORT-MODULE, though there's nothing to stop
+ fancy extensions building modules programmatically."))
+
+(defun import-module (pathname &key (truename (truename pathname)))
+ "Import a module.
+
+ The module is returned if all went well; NIL is returned if an error
+ occurred.
+
+ The PATHNAME argument is the file to read. TRUENAME should be the file's
+ truename, if known: often, the file will have been searched for using
+ PROBE-FILE or similar, which drops the truename into your lap."
+
+ (let ((module (gethash truename *module-map*)))
+ (cond
+
+ ;; The module's not there. (The *MODULE-MAP* never maps things to
+ ;; NIL.)
+ ((null module)
+
+ ;; Mark the module as being in progress. Another attempt to import it
+ ;; will fail.
+ (setf (gethash truename *module-map*) :in-progress)
+
+ ;; Be careful to restore the state of the module map on exit.
+ (unwind-protect
+
+ ;; Open the module file and parse it.
+ (with-open-file (f-stream pathname :direction :input)
+ (let* ((pai-stream (make-instance 'position-aware-input-stream
+ :stream f-stream
+ :file pathname))
+ (lexer (make-instance 'sod-lexer :stream pai-stream)))
+ (with-default-error-location (lexer)
+ (restart-case
+ (progn
+ (next-char lexer)
+ (next-token lexer)
+ (setf module (parse-module lexer)))
+ (continue ()
+ :report "Ignore the import and continue"
+ nil))))))
+
+ ;; If we successfully parsed the module, then store it in the table;
+ ;; otherwise remove it because we might want to try again. (That
+ ;; might not work very well, but it could be worth a shot.)
+ (if module
+ (setf (gethash truename *module-map*) module)
+ (remhash truename *module-map*))))
+
+ ;; A module which is being read can't be included again.
+ ((eql module :in-progress)
+ (error "Cyclic module dependency involving module ~A" pathname))
+
+ ;; A module which was successfully read. Just return it.
+ (t
+ module))))
+
+(defun parse-module (lexer)
+ "Parse a module from the given LEXER.
+
+ The newly constructed module is returned. This is the top-level parsing
+ function."
+
+ (let ((hfrags nil)
+ (cfrags nil)
+ (classes nil)
+ (plist nil)
+ (deps nil))
+
+ (labels ((fragment (func)
+ (next-token lexer)
+ (when (require-token lexer #\{ :consumep nil)
+ (let ((frag (scan-c-fragment lexer '(#\}))))
+ (next-token lexer)
+ (require-token lexer #\})
+ (funcall func frag)))))
+
+ (tagbody
+
+ top
+ ;; module : empty | module-def module
+ ;;
+ ;; Just read module-defs until we reach the end of the file.
+ (case (token-type lexer)
+
+ (:eof
+ (go done))
+ (#\;
+ (next-token lexer)
+ (go top))
+
+ ;; module-def : `import' string `;'
+ ;;
+ ;; Read another module of definitions from a file.
+ (:import
+ (next-token lexer)
+ (let ((name (require-token lexer :string)))
+ (when name
+ (find-file lexer
+ (merge-pathnames name (make-pathname
+ :type "SOD"
+ :case :common))
+ "module"
+ (lambda (path true)
+ (handler-case
+ (let ((module (import-module path
+ :truename true)))
+ (when module
+ (push module deps)))
+ (file-error (error)
+ (cerror* "Error reading module ~S: ~A"
+ path error)))))))
+ (go semicolon))
+
+ ;; module-def : `load' string `;'
+ ;;
+ ;; Load a Lisp extension from a file.
+ (:load
+ (next-token lexer)
+ (let ((name (require-token lexer :string)))
+ (when name
+ (find-file lexer
+ (merge-pathnames name
+ (make-pathname :type "LISP"
+ :case :common))
+ "Lisp file"
+ (lambda (path true)
+ (handler-case (load true
+ :verbose nil
+ :print nil)
+ (error (error)
+ (cerror* "Error loading Lisp file ~S: ~A"
+ path error)))))))
+ (go semicolon))
+
+ ;; module-def : `lisp' sexp
+ ;;
+ ;; Process an in-line Lisp form immediately.
+ (:lisp
+ (let ((form (with-lexer-stream (stream lexer)
+ (read stream t))))
+ (handler-case
+ (eval form)
+ (error (error)
+ (cerror* "Error in Lisp form: ~A" error))))
+ (next-token lexer)
+ (go top))
+
+ ;; module-def : `typename' ids `;'
+ ;; ids : id | ids `,' id
+ ;;
+ ;; Add ids as registered type names. We don't need to know what
+ ;; they mean at this level.
+ (:typename
+ (next-token lexer)
+ (loop
+ (let ((id (require-token lexer :id)))
+ (cond ((null id)
+ (return))
+ ((gethash id *type-map*)
+ (cerror* "Type ~A is already defined" id))
+ (t
+ (setf (gethash id *type-map*)
+ (make-instance 'simple-c-type :name id))))
+ (unless (eql (token-type lexer) #\,)
+ (return))
+ (next-token lexer)))
+ (go semicolon))
+
+ ;; module-def : `source' `{' c-stuff `}'
+ ;; module-def : `header' `{' c-stuff `}'
+ (:source
+ (fragment (lambda (frag) (push frag cfrags)))
+ (go top))
+ (:header
+ (fragment (lambda (frag) (push frag hfrags)))
+ (go top))
+
+ ;; Anything else is an error.
+ (t
+ (cerror* "Unexpected token ~A ignored" (format-token lexer))
+ (next-token lexer)
+ (go top)))
+
+ semicolon
+ ;; Scan a terminating semicolon.
+ (require-token lexer #\;)
+ (go top)
+
+ done)
+
+ ;; Assemble the module and we're done.
+ (make-instance 'module
+ :name (stream-pathname (lexer-stream lexer))
+ :plist plist
+ :classes classes
+ :header-fragments hfrags
+ :source-fragments cfrags
+ :dependencies deps))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Output driver for SOD translator
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun banner (title output &key (blank-line-p t))
+ (format output "~&~%/*----- ~A ~A*/~%"
+ title
+ (make-string (- 77 2 5 1 (length title) 1 2)
+ :initial-element #\-))
+ (when blank-line-p
+ (terpri output)))
+
+;;;--------------------------------------------------------------------------
+;;; Header output.
+
+(defun write-module-header (module)
+ (let* ((file (merge-pathnames (make-pathname :type "H" :case :common)
+ (module-name module)))
+ (fakename (make-pathname :name (pathname-name file)
+ :type (pathname-type file))))
+ (with-open-file (uoutput file
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (let ((output (make-instance 'position-aware-output-stream
+ :stream uoutput
+ :file fakename)))
+
+ ;; Format the header and guards.
+ (format output "~
+/* -*-c-*-
+ *
+ * Header file generated by SOD for ~A
+ */
+
+#ifndef ~A
+#define ~:*~A
+
+#ifdef __cplusplus
+ extern \"C\" {
+#endif~%"
+ (namestring (module-name module))
+ (or (getf (module-plist module) 'include-guard)
+ (with-output-to-string (guard)
+ (let ((name (namestring file))
+ (uscore t))
+ (dotimes (i (length name))
+ (let ((ch (char name i)))
+ (cond ((alphanumericp ch)
+ (write-char (char-upcase ch) guard)
+ (setf uscore nil))
+ ((not uscore)
+ (write-char #\_ guard)
+ (setf uscore t)))))))))
+
+ ;; Forward declarations of all the structures and types. Nothing
+ ;; interesting gets said here; this is just so that the user code
+ ;; can talk meainingfully about the things we're meant to be
+ ;; defining here.
+ ;;
+ ;; FIXME
+
+ ;; The user fragments.
+ (when (module-header-fragments module)
+ (banner "User code" output)
+ (dolist (frag (module-header-fragments module))
+ (write-fragment frag output)))
+
+ ;; The definitions of the necessary structures.
+ ;;
+ ;; FIXME
+
+ ;; The definitions of the necessary direct-methods.
+ ;;
+ ;; FIXME
+
+ ;; The trailer section.
+ (banner "That's all, folks" output)
+ (format output "~
+#ifdef __cplusplus
+ }
+#endif
+
+#endif~%")))))
+
+;;;--------------------------------------------------------------------------
+;;; Source output.
+
+(defun write-module-source (module)
+ (let* ((file (merge-pathnames (make-pathname :type "C" :case :common)
+ (module-name module)))
+ (fakename (make-pathname :name (pathname-name file)
+ :type (pathname-type file))))
+ (with-open-file (uoutput file
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (let ((output (make-instance 'position-aware-output-stream
+ :stream uoutput
+ :file fakename)))
+
+ ;; Format the header.
+ (format output "~
+/* -*-c-*-
+ *
+ * Source file generated by SOD for ~A
+ */~%"
+ (namestring (module-name module)))
+
+ ;; The user fragments.
+ (when (module-source-fragments module)
+ (banner "User code" output)
+ (dolist (frag (module-source-fragments module))
+ (write-fragment frag output)))
+
+ ;; The definitions of the necessary tables.
+ ;;
+ ;; FIXME
+
+ ;; The definitions of the necessary effective-methods.
+ ;;
+ ;; FIXME
+
+ ;; The trailer section.
+ (banner "That's all, folks" output :blank-line-p nil)))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Package definition for SOD utility
+;;;
+;;; (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:defpackage #:sod
+ (:use #:common-lisp
+
+ ;; Find the meta-object protocol. Our demands are not particularly
+ ;; heavy.
+ #+sbcl #:sb-mop
+ #+(or cmu clisp) #:mop
+ #+ecl #:mop
+
+ ;; Try to find Gray streams support from somewhere. ECL tucks them
+ ;; somewhere unhelpful.
+ #+sbcl #:sb-gray
+ #+cmu #:extensions
+ #+ecl #.(if (find-package '#:gray) '#:gray '#:si)
+ #+clisp #:gray
+ #-(or sbcl cmu ecl clisp) ...))
+
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Parser for C types
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Declaration specifiers.
+;;;
+;;; This is a little messy. The C rules, which we're largely following,
+;;; allow declaration specifiers to be written in any oreder, and allows an
+;;; arbitrary number of the things. This is mainly an exercise in
+;;; book-keeping, but we make an effort to categorize the various kinds of
+;;; specifiers rather better than the C standard.
+;;;
+;;; We consider four kinds of declaration specifiers:
+;;;
+;;; * Type qualifiers: `const', `restrict', and `volatile'.
+;;; * Sign specifiers: `signed' and `unsigned'.
+;;; * Size specifiers: `short' and `long'.
+;;; * Type specifiers: `void', `char', `int', `float', and `double',
+;;;
+;;; The C standard acknowledges the category of type qualifiers (6.7.3), but
+;;; groups the other three kinds together and calls them all `type
+;;; specifiers' (6.7.2).
+
+(defstruct (declspec
+ (:predicate declspecp))
+ "Represents a declaration specifier being built."
+ (qualifiers nil :type list)
+ (sign nil :type (member nil :signed :unsigned))
+ (size nil :type (member nil :short :long :long-long))
+ (type nil :type (or (member nil :int :char :float :double :void) c-type)))
+
+(defun check-declspec (spec)
+ "Check that the declaration specifiers in SPEC are a valid combination.
+
+ This is surprisingly hairy.
+
+ It could be even worse: at least validity is monotonic. Consider an
+ alternate language where `double' is a size specifier like `long' rather
+ than being a primary type specifier like `float' (so you'd be able to say
+ things like `long double float'). Then `long float' would be invalid, but
+ `long float double' would be OK. We'd therefore need an additional
+ argument to know whether we were preparing a final set of specifiers (in
+ which case we'd have to reject `long float') or whether this is an
+ intermediate step (in which case we'd have to tentatively allow it in the
+ hope that the user added the necessary `double' later)."
+
+ (let ((sign (declspec-sign spec))
+ (size (declspec-size spec))
+ (type (declspec-type spec)))
+
+ (and (loop for (good-type good-signs good-sizes) in
+
+ ;; The entries in this table have the form (GOOD-TYPE
+ ;; GOOD-SIGNS GOOD-SIZES). The GOOD-TYPE is either a keyword
+ ;; or T (matches anything); the GOOD-SIZES and GOOD-SIGNS are
+ ;; lists. The SPEC must match at least one entry, as follows:
+ ;; the type must be NIL or match GOOD-TYPE; and the size and
+ ;; sign must match one of the elements of the corresponding
+ ;; GOOD list.
+ '((:int (nil :signed :unsigned) (nil :short :long :long-long))
+ (:char (nil :signed :unsigned) (nil))
+ (:double (nil) (nil :long))
+ (t (nil) (nil)))
+
+ thereis (and (or (eq type nil)
+ (eq good-type t)
+ (eq type good-type))
+ (member sign good-signs)
+ (member size good-sizes)))
+ spec)))
+
+(defun update-declspec-qualifiers (spec qual)
+ "Update the qualifiers in SPEC by adding QUAL.
+
+ The new declspec is returned if it's valid; otherwise NIL. SPEC is not
+ modified."
+
+ (let ((new (copy-declspec spec)))
+ (pushnew qual (declspec-qualifiers new))
+ (check-declspec new)))
+
+(defun update-declspec-sign (spec sign)
+ "Update the signedness in SPEC to be SIGN.
+
+ The new declspec is returned if it's valid; otherwise NIL. SPEC is not
+ modified."
+
+ (and (null (declspec-sign spec))
+ (let ((new (copy-declspec spec)))
+ (setf (declspec-sign new) sign)
+ (check-declspec new))))
+
+(defun update-declspec-size (spec size)
+ "Update the size in SPEC according to SIZE.
+
+ The new declspec is returned if it's valid; otherwise NIL. (This is a
+ little subtle because :LONG in particular can modify an existing size
+ entry.) SPEC is not modified."
+
+ (let ((new-size (case (declspec-size spec)
+ ((nil) size)
+ (:long (if (eq size :long) :long-long nil)))))
+ (and new-size
+ (let ((new (copy-declspec spec)))
+ (setf (declspec-size new) new-size)
+ (check-declspec new)))))
+
+(defun update-declspec-type (spec type)
+ "Update the type in SPEC to be TYPE.
+
+ The new declspec is returned if it's valid; otherwise NIL. SPEC is not
+ modified."
+
+ (and (null (declspec-type spec))
+ (let ((new (copy-declspec spec)))
+ (setf (declspec-type new) type)
+ (check-declspec new))))
+
+(defun canonify-declspec (spec)
+ "Transform the declaration specifiers SPEC into a canonical form.
+
+ The idea is that, however grim the SPEC, we can turn it into something
+ vaguely idiomatic, and pick precisely one of the possible synonyms.
+
+ The rules are that we suppress `signed' when it's redundant, and suppress
+ `int' if a size or signedness specifier is present. (Note that `signed
+ char' is not the same as `char', so stripping `signed' is only correct
+ when the type is `int'.)
+
+ The qualifiers are sorted and uniquified here; the relative ordering of
+ the sign/size/type specifiers will be determined by DECLSPEC-KEYWORDS."
+
+ (let ((quals (declspec-qualifiers spec))
+ (sign (declspec-sign spec))
+ (size (declspec-size spec))
+ (type (declspec-type spec)))
+ (cond ((eq type :int)
+ (when (eq sign :signed)
+ (setf (declspec-sign spec) nil))
+ (when (or sign size)
+ (setf (declspec-type spec) nil)))
+ ((not (or sign size type))
+ (setf (declspec-type spec) :int)))
+ (setf (declspec-qualifiers spec)
+ (delete-duplicates (sort (copy-list quals) #'string<)))
+ spec))
+
+(defun declspec-keywords (spec &optional qualsp)
+ "Return a list of strings for the declaration specifiers SPEC.
+
+ If QUALSP then return the type qualifiers as well."
+
+ (let ((quals (declspec-qualifiers spec))
+ (sign (declspec-sign spec))
+ (size (declspec-size spec))
+ (type (declspec-type spec)))
+ (nconc (and qualsp (mapcar #'string-downcase quals))
+ (and sign (list (string-downcase sign)))
+ (case size
+ ((nil) nil)
+ (:long-long (list "long long"))
+ (t (list (string-downcase size))))
+ (etypecase type
+ (null nil)
+ (keyword (list (string-downcase type)))
+ (simple-c-type (list (c-type-name type)))
+ (tagged-c-type (list (string-downcase (c-tagged-type-kind type))
+ (c-type-tag type)))))))
+
+(defun declspec-c-type (spec)
+ "Return a C-TYPE object corresponding to SPEC."
+ (canonify-declspec spec)
+ (let* ((type (declspec-type spec))
+ (base (etypecase type
+ (symbol (make-simple-type
+ (format nil "~{~A~^ ~}"
+ (declspec-keywords spec))))
+ (c-type type))))
+ (qualify-type base (declspec-qualifiers spec))))
+
+(defun declaration-specifier-p (lexer)
+ "Answer whether the current token might be a declaration specifier."
+ (case (token-type lexer)
+ ((:const :volatile :restrict
+ :signed :unsigned
+ :short :long
+ :void :char :int :float :double
+ :enum :struct :union)
+ t)
+ (:id
+ (gethash (token-value lexer) *type-map*))
+ (t
+ nil)))
+
+(defun parse-c-type (lexer)
+ "Parse declaration specifiers from LEXER and return a C-TYPE."
+
+ (let ((spec (make-declspec))
+ (found-any nil))
+ (loop
+ (let ((tok (token-type lexer)))
+ (labels ((update (func value)
+ (let ((new (funcall func spec value)))
+ (cond (new (setf spec new))
+ (t (cerror*
+ "Invalid declaration specifier ~(~A~) after `~{~A~^ ~}' (ignored)"
+ (format-token tok (token-value lexer))
+ (declspec-keywords spec t))
+ nil))))
+ (tagged (class)
+ (let ((kind tok))
+ (setf tok (next-token lexer))
+ (if (eql tok :id)
+ (when (update #'update-declspec-type
+ (make-instance
+ class
+ :tag (token-value lexer)))
+ (setf found-any t))
+ (cerror* "Expected ~(~A~) tag; found ~A"
+ kind (format-token lexer))))))
+ (case tok
+ ((:const :volatile :restrict)
+ (update #'update-declspec-qualifiers tok))
+ ((:signed :unsigned)
+ (when (update #'update-declspec-sign tok)
+ (setf found-any t)))
+ ((:short :long)
+ (when (update #'update-declspec-size tok)
+ (setf found-any t)))
+ ((:void :char :int :float :double)
+ (when (update #'update-declspec-type tok)
+ (setf found-any t)))
+ (:enum (tagged 'c-enum-type))
+ (:struct (tagged 'c-struct-type))
+ (:union (tagged 'c-union-type))
+ (:id
+ (let ((ty (gethash (token-value lexer) *type-map*)))
+ (when (or found-any (not ty))
+ (return))
+ (when (update #'update-declspec-type ty)
+ (setf found-any t))))
+ (t
+ (return))))
+ (setf tok (next-token lexer))))
+ (unless found-any
+ (cerror* "Missing type name (guessing at `int')"))
+ (declspec-c-type spec)))
+
+;;;--------------------------------------------------------------------------
+;;; Parsing declarators.
+;;;
+;;; This is a whole different ball game. The syntax is simple enough, but
+;;; the semantics is inside-out in a particularly unpleasant way.
+;;;
+;;; The basic idea is that declarator operators closer to the identifier (or
+;;; where the identifier would be) should be applied last (with postfix
+;;; operators being considered `closer' than prefix).
+;;;
+;;; One might thing that we can process prefix operators immediately. For
+;;; outer prefix operators, this is indeed correct, but in `int (*id)[]', for
+;;; example, we must wait to process the array before applying the pointer.
+;;;
+;;; We can translate each declarator operator into a function which, given a
+;;; type, returns the appropriate derived type. If we can arrange these
+;;; functions in the right order during the parse, we have only to compose
+;;; them together and apply them to the base type in order to finish the job.
+;;;
+;;; Consider the following skeletal declarator, with <> as a parenthesized
+;;; subdeclarator within.
+;;;
+;;; * * <> [] [] ---> a b d c z
+;;; a b z c d
+;;;
+;;; The algorithm is therefore as follows. We first read the prefix
+;;; operators, translate them into closures, and push them onto a list. Each
+;;; parenthesized subdeclarator gets its own list, and we push those into a
+;;; stack each time we encounter a `('. We then parse the middle bit, which
+;;; is a little messy (see the comment there), and start an empty final list
+;;; of operators. Finally, we scan postfix operators; these get pushed onto
+;;; the front of the operator list as we find them. Each time we find a `)',
+;;; we reverse the current prefix-operators list, and attach it to the front
+;;; of the operator list, and pop a new prefix list off the stack: at this
+;;; point, the operator list reflects the type of the subdeclarator we've
+;;; just finished. Eventually we should reach the end with an empty stack
+;;; and a prefix list, which again we reverse and attach to the front of the
+;;; list.
+;;;
+;;; Finally, we apply the operator functions in order.
+
+(defun parse-c-declarator (lexer type &key abstractp dottedp)
+ "Parse a declarator. Return two values: the complete type, and the name.
+
+ Parse a declarator from LEXER. The base type is given by TYPE. If
+ ABSTRACTP is NIL, then require a name; if T then forbid a name; if :MAYBE
+ then don't care either way. If no name is given, return NIL.
+
+ If DOTTEDP then the name may be a dotted item name `NICK.NAME', returned
+ as a cons (NICK . NAME)."
+
+ (let ((ops nil)
+ (item nil)
+ (stack nil)
+ (prefix nil))
+
+ ;; Scan prefix operators.
+ (loop
+ (case (token-type lexer)
+
+ ;; Star: a pointer type.
+ (#\* (let ((quals nil)
+ (tok (next-token lexer)))
+
+ ;; Gather following qualifiers.
+ (loop
+ (case tok
+ ((:const :volatile :restrict)
+ (pushnew tok quals))
+ (t
+ (return))))
+
+ ;; And stash the item.
+ (setf quals (sort quals #'string<))
+ (push (lambda (ty)
+ (make-instance 'c-pointer-type
+ :qualifiers quals
+ :subtype ty))
+ prefix)))
+
+ ;; An open-paren: start a new level of nesting. Maybe. There's an
+ ;; unpleasant ambiguity (DR9, DR249) between a parenthesized
+ ;; subdeclarator and a postfix function argument list following an
+ ;; omitted name. If the next thing looks like it might appear as a
+ ;; declaration specifier then assume it is one, push the paren back,
+ ;; and leave; do the same if the parens are empty, because that's not
+ ;; allowed otherwise.
+ (#\( (let ((tok (next-token lexer)))
+ (when (and abstractp
+ (or (eql tok #\))
+ (declaration-specifier-p lexer)))
+ (pushback-token lexer #\()
+ (return))
+ (push prefix stack)
+ (setf prefix nil)))
+
+ ;; Anything else: we're done.
+ (t (return))))
+
+ ;; We're now at the middle of the declarator. If there's an item name
+ ;; here, we want to snarf it.
+ (when (and (not (eq abstractp t))
+ (eq (token-type lexer) :id))
+ (let ((name (token-value lexer)))
+ (next-token lexer)
+ (cond ((and dottedp
+ (eq (token-type lexer) #\.))
+ (let ((sub (require-token :id :default (gensym))))
+ (setf item (cons name sub))))
+ (t
+ (setf item name)))))
+
+ ;; If we were meant to have a name, but weren't given one, make one up.
+ (when (and (null item)
+ (not abstractp))
+ (cerror* "Missing name; inventing one")
+ (setf item (gensym)))
+
+ ;; Finally scan the postfix operators.
+ (loop
+ (case (token-type lexer)
+
+ ;; Open-bracket: an array. The dimensions are probably some
+ ;; gods-awful C expressions which we'll just tuck away rather than
+ ;; thinking about too carefully. Our representation of C types is
+ ;; capable of thinking about multidimensional arrays, so we slurp up
+ ;; as many dimensions as we can.
+ (#\[ (let ((dims nil))
+ (loop
+ (let* ((frag (scan-c-fragment lexer '(#\])))
+ (dim (c-fragment-text frag)))
+ (push (if (plusp (length dim)) dim nil) dims))
+ (next-token lexer)
+ (unless (eq (next-token lexer) #\[)
+ (return)))
+ (setf dims (nreverse dims))
+ (push (lambda (ty)
+ (make-instance 'c-array-type
+ :dimensions dims
+ :subtype ty))
+ ops)))
+
+ ;; Open-paren: a function with arguments.
+ (#\( (let ((args nil))
+ (unless (eql (next-token lexer) #\))
+ (loop
+
+ ;; Grab an argument and stash it.
+ (cond ((eql (token-type lexer) :ellipsis)
+ (push :ellipsis args))
+ (t
+ (let ((base-type (parse-c-type lexer)))
+ (multiple-value-bind (type name)
+ (parse-c-declarator lexer base-type
+ :abstractp :maybe)
+ (push (make-argument name type) args)))))
+
+ ;; Decide whether to take another one.
+ (case (token-type lexer)
+ (#\) (return))
+ (#\, (next-token lexer))
+ (t (cerror* "Missing `)' inserted before ~A"
+ (format-token lexer))
+ (return)))))
+ (next-token lexer)
+
+ ;; 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))
+ (eq (argument-type (car args)) (c-type void))
+ (not (argument-name (car args))))
+ nil
+ (nreverse args)))
+
+ ;; Stash the operator.
+ (push (lambda (ty)
+ (make-instance 'c-function-type
+ :arguments args
+ :subtype ty))
+ ops)))
+
+ ;; Close-paren: exit a level of nesting. Prepend the current prefix
+ ;; list and pop a new level. If there isn't one, this isn't our
+ ;; paren, so we're done.
+ (#\) (unless stack
+ (return))
+ (setf ops (nreconc prefix ops)
+ prefix (pop stack))
+ (next-token lexer))
+
+ ;; Anything else means we've finished.
+ (t (return))))
+
+ ;; If we still have operators stacked then something went wrong.
+ (setf ops (nreconc prefix ops))
+ (when stack
+ (cerror* "Missing `)'(s) inserted before ~A"
+ (format-token lexer))
+ (dolist (prefix stack)
+ (setf ops (nreconc prefix ops))))
+
+ ;; Finally, grind through the list of operations.
+ (do ((ops ops (cdr ops))
+ (type type (funcall (car ops) type)))
+ ((endp ops) (values type item)))))
+
+;;;--------------------------------------------------------------------------
+;;; Testing cruft.
+
+#+test
+(with-input-from-string (in "
+// int stat(struct stat *st)
+// void foo(void)
+ int vsnprintf(size_t n, char *buf, va_list ap)
+// int (*signal(int sig, int (*handler)(int s)))(int t)
+")
+ (let* ((stream (make-instance 'position-aware-input-stream
+ :file "<string>"
+ :stream in))
+ (lex (make-instance 'sod-lexer :stream stream
+ :keywords *sod-keywords*)))
+ (next-char lex)
+ (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)
+ (format-token lex)))))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Position-aware stream type
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Compatibility hacking.
+
+;; ECL doesn't clobber the standard CLOSE and STREAM-ELEMENT-TYPE functions
+;; with the Gray generic versions.
+#-ecl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (fdefinition 'stream-close) #'cl:close
+ (fdefinition 'stream-elt-type) #'cl:stream-element-type))
+
+;;;--------------------------------------------------------------------------
+;;; File names.
+
+(defgeneric stream-pathname (stream)
+ (:documentation
+ "Returns the pathname of the file that STREAM is open on.
+
+ If STREAM is open on a file, then return the pathname of that file.
+ Otherwise return NIL.")
+
+ ;; Provide some default methods. Most streams don't have a pathname.
+ ;; File-based streams provide a pathname, but it's usually been TRUENAMEd,
+ ;; which isn't ideal. We'll hack around this later.
+ (:method ((stream stream))
+ nil)
+ (:method ((stream file-stream))
+ (pathname stream)))
+
+;;;--------------------------------------------------------------------------
+;;; Locations.
+
+(defclass file-location ()
+ ((pathname :initarg :pathname
+ :type (or pathname null)
+ :accessor file-location-pathname)
+ (line :initarg :line
+ :type (or fixnum null)
+ :accessor file-location-line)
+ (column :initarg :column
+ :type (or fixnum null)
+ :accessor file-location-column))
+ (:documentation
+ "A simple structure containing file location information.
+
+ Construct using MAKE-FILE-LOCATION; the main useful function is
+ ERROR-FILE-LOCATION."))
+
+(defun make-file-location (pathname line column)
+ "Constructor for FILE-LOCATION objects.
+
+ Returns a FILE-LOCATION object with the given contents."
+ (make-instance 'file-location
+ :pathname (and pathname (pathname pathname))
+ :line line :column column))
+
+(defgeneric file-location (thing)
+ (:documentation
+ "Convert THING into a FILE-LOCATION, if possible.")
+ (:method ((thing null)) (make-file-location nil nil nil))
+ (:method ((thing file-location)) thing)
+ (:method ((stream stream))
+ (make-file-location (stream-pathname stream) nil nil)))
+
+(defmethod print-object ((object file-location) stream)
+ (if *print-escape*
+ (call-next-method)
+ (with-slots (pathname line column) object
+ (format stream "~:[<unnamed>~;~:*~A~]~@[:~D~]~@[:~D~]"
+ pathname line column))))
+
+;;;--------------------------------------------------------------------------
+;;; Proxy streams.
+
+;; Base classes for proxy streams.
+
+(defclass proxy-stream (fundamental-stream)
+ ((ustream :initarg :stream
+ :type stream
+ :reader position-aware-stream-underlying-stream))
+ (:documentation
+ "Base class for proxy streams.
+
+ A proxy stream is one that works by passing most of its work to an
+ underlying stream. We provide some basic functionality for the later
+ classes."))
+
+(defmethod stream-close ((stream proxy-stream) &key abort)
+ (with-slots (ustream) stream
+ (close ustream :abort abort)))
+
+(defmethod stream-elt-type ((stream proxy-stream))
+ (with-slots (ustream) stream
+ (stream-elt-type ustream)))
+
+(defmethod stream-file-position
+ ((stream proxy-stream) &optional (position nil posp))
+ (with-slots (ustream) stream
+ (if posp
+ (file-position ustream position)
+ (file-position ustream))))
+
+(defmethod stream-pathname ((stream proxy-stream))
+ (with-slots (ustream) stream
+ (stream-pathname ustream)))
+
+;; Base class for input streams.
+
+(defclass proxy-input-stream (proxy-stream fundamental-input-stream)
+ ()
+ (:documentation
+ "Base class for proxy input streams."))
+
+(defmethod stream-clear-input ((stream proxy-input-stream))
+ (with-slots (ustream) stream
+ (clear-input ustream)))
+
+(defmethod stream-read-sequence
+ ((stream proxy-input-stream) seq &optional (start 0) end)
+ (with-slots (ustream) stream
+ (read-sequence seq ustream :start start :end end)))
+
+;; Base class for output streams.
+
+(defclass proxy-output-stream (proxy-stream fundamental-output-stream)
+ ()
+ (:documentation
+ "Base class for proxy output streams."))
+
+(defmethod stream-clear-output ((stream proxy-output-stream))
+ (with-slots (ustream) stream
+ (clear-output ustream)))
+
+(defmethod stream-finish-output ((stream proxy-output-stream))
+ (with-slots (ustream) stream
+ (finish-output ustream)))
+
+(defmethod stream-force-output ((stream proxy-output-stream))
+ (with-slots (ustream) stream
+ (force-output ustream)))
+
+(defmethod stream-write-sequence
+ ((stream proxy-output-stream) seq &optional (start 0) end)
+ (with-slots (ustream) stream
+ (write-sequence seq ustream :start start :end end)))
+
+;; Character input streams.
+
+(defclass proxy-character-input-stream
+ (proxy-input-stream fundamental-character-input-stream)
+ ()
+ (:documentation
+ "A character-input-stream which is a proxy for an existing stream.
+
+ This doesn't actually change the behaviour of the underlying stream very
+ much, but it's a useful base to work on when writing more interesting
+ classes."))
+
+(defmethod stream-read-char ((stream proxy-character-input-stream))
+ (with-slots (ustream) stream
+ (read-char ustream nil :eof nil)))
+
+(defmethod stream-read-line ((stream proxy-character-input-stream))
+ (with-slots (ustream) stream
+ (read-line ustream nil "" nil)))
+
+(defmethod stream-unread-char ((stream proxy-character-input-stream) char)
+ (with-slots (ustream) stream
+ (unread-char char ustream)))
+
+;; Character output streams.
+
+(defclass proxy-character-output-stream
+ (proxy-stream fundamental-character-output-stream)
+ ()
+ (:documentation
+ "A character-output-stream which is a proxy for an existing stream.
+
+ This doesn't actually change the behaviour of the underlying stream very
+ much, but it's a useful base to work on when writing more interesting
+ classes."))
+
+(defmethod stream-line-column ((stream proxy-character-output-stream))
+ nil)
+
+(defmethod stream-line-length ((stream proxy-character-output-stream))
+ nil)
+
+(defmethod stream-terpri ((stream proxy-character-output-stream))
+ (with-slots (ustream) stream
+ (terpri ustream)))
+
+(defmethod stream-write-char ((stream proxy-character-output-stream) char)
+ (with-slots (ustream) stream
+ (write-char char ustream)))
+
+(defmethod stream-write-string
+ ((stream proxy-character-output-stream) string &optional (start 0) end)
+ (with-slots (ustream) stream
+ (write-string string ustream :start start :end end)))
+
+;;;--------------------------------------------------------------------------
+;;; The position-aware stream.
+
+;; Base class.
+
+(defclass position-aware-stream (proxy-stream)
+ ((file :initarg :file
+ :initform nil
+ :type pathname
+ :accessor position-aware-stream-file)
+ (line :initarg :line
+ :initform 1
+ :type fixnum
+ :accessor position-aware-stream-line)
+ (column :initarg :column
+ :initform 0
+ :type fixnum
+ :accessor position-aware-stream-column))
+ (:documentation
+ "Character stream which keeps track of the line and column position.
+
+ A position-aware-stream wraps an existing character stream and tracks the
+ line and column position of the current stream position. A newline
+ character increases the line number by one and resets the column number to
+ zero; most characters advance the column number by one, but tab advances
+ to the next multiple of eight. (This is consistent with Emacs, at least.)
+ The position can be read using STREAM-LINE-AND-COLUMN.
+
+ This is a base class; you probably want POSITION-AWARE-INPUT-STREAM or
+ POSITION-AWARE-OUTPUT-STREAM."))
+
+(defgeneric stream-line-and-column (stream)
+ (:documentation
+ "Returns the current stream position of STREAM as line/column numbers.
+
+ Returns two values: the line and column numbers of STREAM's input
+ position.")
+ (:method ((stream stream))
+ (values nil nil))
+ (:method ((stream position-aware-stream))
+ (with-slots (line column) stream
+ (values line column))))
+
+(defmethod stream-pathname ((stream position-aware-stream))
+ "Return the pathname corresponding to a POSITION-AWARE-STREAM.
+
+ A POSITION-AWARE-STREAM can be given an explicit pathname, which is
+ returned in preference to the pathname of the underlying stream. This is
+ useful in two circumstances. Firstly, the pathname associated with a file
+ stream will have been subjected to TRUENAME, and may be less pleasant to
+ present back to a user. Secondly, a name can be attached to a stream
+ which doesn't actually have a file backing it."
+
+ (with-slots (file) stream
+ (or file (call-next-method))))
+
+(defmethod file-location ((stream position-aware-stream))
+ (multiple-value-bind (line column) (stream-line-and-column stream)
+ (make-file-location (stream-pathname stream) line column)))
+
+;; Utilities.
+
+(declaim (inline update-position))
+(defun update-position (char line column)
+ "Updates LINE and COLUMN according to the character CHAR.
+
+ Returns the new LINE and COLUMN numbers resulting from having read CHAR."
+ (case char
+ ((#\newline #\vt #\page)
+ (values (1+ line) 0))
+ ((#\tab)
+ (values line (logandc2 (+ column 7) 7)))
+ (t
+ (values line (1+ column)))))
+
+(defmacro with-position ((stream) &body body)
+ "Convenience macro for tracking the read position.
+
+ Within the BODY, the macro (update CHAR) is defined to update the STREAM's
+ position according to the character CHAR.
+
+ The position is actually cached in local variables, but will be written
+ back to the stream even in the case of non-local control transfer from the
+ BODY. What won't work well is dynamically nesting WITH-POSITION forms."
+
+ (let ((streamvar (gensym "STREAM"))
+ (linevar (gensym "LINE"))
+ (colvar (gensym "COLUMN"))
+ (charvar (gensym "CHAR")))
+ `(let* ((,streamvar ,stream)
+ (,linevar (position-aware-stream-line ,streamvar))
+ (,colvar (position-aware-stream-column ,streamvar)))
+ (macrolet ((update (,charvar)
+ ;; This gets a little hairy. Hold tight.
+ `(multiple-value-setq (,',linevar ,',colvar)
+ (update-position ,,charvar ,',linevar ,',colvar))))
+ (unwind-protect
+ (progn ,@body)
+ (setf (position-aware-stream-line ,streamvar) ,linevar
+ (position-aware-stream-column ,streamvar) ,colvar))))))
+
+;; Input stream.
+
+(defclass position-aware-input-stream
+ (position-aware-stream proxy-character-input-stream)
+ ()
+ (:documentation
+ "A character input stream which tracks the input position.
+
+ This is particularly useful for parsers and suchlike, which want to
+ produce accurate error-location information."))
+
+(defmethod stream-unread-char ((stream position-aware-input-stream) char)
+
+ ;; Tweak the position so that the next time the character is read, it will
+ ;; end up here. This isn't perfect: if the character doesn't actually
+ ;; match what was really read then it might not actually be possible: for
+ ;; example, if we push back a newline while in the middle of a line, or a
+ ;; tab while not at a tab stop. In that case, we'll just lose, but
+ ;; hopefully not too badly.
+ (with-slots (line column) stream
+ (case char
+
+ ;; In the absence of better ideas, I'll set the column number to zero.
+ ;; This is almost certainly wrong, but with a little luck nobody will
+ ;; ask and it'll be all right soon.
+ ((#\newline #\vt #\page)
+ (decf line)
+ (setf column 0))
+
+ ;; Winding back a single space is sufficient. If the position is
+ ;; currently on a tab stop then it'll advance back here next time. If
+ ;; not, we're going to lose anyway.
+ (#\tab
+ (decf column))
+
+ ;; Anything else: just decrement the column and cross fingers.
+ (t
+ (decf column))))
+
+ ;; And actually do it. (I could have written this as a :before or :after
+ ;; method, but I think this is the right answer. All of the other methods
+ ;; have to be primary (or around) methods, so at least it's consistent.)
+ (call-next-method))
+
+(defmethod stream-read-sequence
+ ((stream position-aware-input-stream) seq &optional (start 0) end)
+ (declare (ignore end))
+ (let ((pos (call-next-method)))
+ (with-position (stream)
+ (dosequence (ch seq :start start :end pos)
+ (update ch)))
+ pos))
+
+(defmethod stream-read-char ((stream position-aware-input-stream))
+ (let ((char (call-next-method)))
+ (with-position (stream)
+ (update char))
+ char))
+
+(defmethod stream-read-line ((stream position-aware-input-stream))
+ (multiple-value-bind (line eofp) (call-next-method)
+ (if eofp
+ (with-position (stream)
+ (dotimes (i (length line))
+ (update (char line i))))
+ (with-slots (line column) stream
+ (incf line)
+ (setf column 0)))
+ (values line eofp)))
+
+;; Output stream.
+
+(defclass position-aware-output-stream
+ (position-aware-stream proxy-character-output-stream)
+ ()
+ (:documentation
+ "A character output stream which tracks the output position.
+
+ This is particularly useful when generating C code: the position can be
+ used to generate `#line' directives referring to the generated code after
+ insertion of some user code."))
+
+(defmethod stream-write-sequence
+ ((stream position-aware-output-stream) seq &optional (start 0) end)
+ (with-position (stream)
+ (dosequence (ch seq :start start :end end)
+ (update ch))
+ (call-next-method)))
+
+(defmethod stream-line-column ((stream position-aware-output-stream))
+ (with-slots (column) stream
+ column))
+
+(defmethod stream-start-line-p ((stream position-aware-output-stream))
+ (with-slots (column) stream
+ (zerop column)))
+
+(defmethod stream-terpri ((stream position-aware-output-stream))
+ (with-slots (line column) stream
+ (incf line)
+ (setf column 0))
+ (call-next-method))
+
+(defmethod stream-write-char ((stream position-aware-output-stream) char)
+ (with-position (stream)
+ (update char))
+ (call-next-method))
+
+(defmethod stream-write-string
+ ((stream position-aware-output-stream) string &optional (start 0) end)
+ (with-position (stream)
+ (do ((i start (1+ i))
+ (end (or end (length string))))
+ ((>= i end))
+ (update (char string i))))
+ (call-next-method))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Collections of properties
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Basic definitions.
+
+(defun property-key (name)
+ "Convert NAME into a keyword.
+
+ If NAME isn't a symbol already, then flip its case (using FROB-CASE),
+ replace underscores by hyphens, and intern into the KEYWORD package."
+ (etypecase name
+ (symbol name)
+ (string (intern (substitute #\- #\_ (frob-case name)) :keyword))))
+
+(defun property-type (value)
+ "Guess the right property type to use for VALUE."
+ (etypecase value
+ (symbol :symbol)
+ (integer :integer)
+ (string :string)
+ (c-fragment :frag)))
+
+(defstruct (property
+ (:conc-name p-)
+ (:constructor make-property
+ (name value
+ &key (type (property-type value)) location seenp
+ &aux (key (property-key name)))))
+ "A simple structure for holding a property in a property set.
+
+ The main useful feature is the ability to tick off properties which have
+ been used, so that we can complain about unrecognized properties."
+ (name nil :type (or symbol string))
+ (value nil :type t)
+ (type nil :type symbol)
+ (location (file-location nil) :type file-location)
+ (key nil :type symbol)
+ (seenp nil :type boolean))
+
+(defun make-property-set (&rest plist)
+ "Make a new property set, with given properties.
+
+ This isn't the way to make properties when parsing, but it works well for
+ programmatic generation. The arguments should form a property list
+ (alternating keywords and values is good).
+
+ An attempt is made to guess property types from the Lisp types of the
+ values. This isn't always successful but it's not too bad. The
+ alternative is manufacturing a PROPERTY-VALUE object by hand and stuffing
+ into the set."
+
+ (do ((plist plist (cddr plist))
+ (pset nil (cons (make-property (car plist) (cadr plist)) pset)))
+ ((endp plist) (nreverse pset))))
+
+(defun string-to-symbol (string &optional (package *package*))
+ "Convert STRING to a symbol in PACKAGE.
+
+ If PACKAGE is nil, then parse off a `PACKAGE:' prefix from STRING to
+ identify the package. A doubled colon allows access to internal symbols,
+ and will intern if necessary. Note that escape characters are /not/
+ 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)
+ (cond ((not colon) (values 0 t))
+ ((and (< (1+ colon) length)
+ (char= (char string (1+ colon)) #\:))
+ (values (+ colon 2) t))
+ (t
+ (values (1+ colon) nil)))
+ (when colon
+ (let* ((package-name (subseq string 0 colon))
+ (found (find-package package-name)))
+ (unless found
+ (error "Unknown package `~A'" package-name))
+ (setf package found)))
+ (let ((name (subseq string start)))
+ (multiple-value-bind (symbol status)
+ (funcall (if internalp #'intern #'find-symbol) name package)
+ (cond ((or internalp (eq status :external))
+ symbol)
+ ((not status)
+ (error "Symbol `~A' not found in package `~A'"
+ name (package-name package)))
+ (t
+ (error "Symbol `~A' not external in package `~A'"
+ name (package-name package)))))))))
+
+(defgeneric coerce-property-value (value type wanted)
+ (:documentation
+ "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.
+ (:method (value type wanted)
+ (if (eql type wanted)
+ value
+ (error "Incorrect type: expected ~A but found ~A" wanted type)))
+
+ ;; Keywords.
+ (:method ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
+ value)
+ (:method ((value string) (type (eql :id)) (wanted (eql :keyword)))
+ (string-to-symbol (substitute #\- #\_ (frob-case value)) :keyword))
+ (:method ((value string) (type (eql :string)) (wanted (eql :keyword)))
+ (string-to-symbol (frob-case value) :keyword))
+
+ ;; Symbols.
+ (:method ((value string) (type (eql :id)) (wanted (eql :symbol)))
+ (string-to-symbol (substitute #\- #\_ (frob-case value))))
+ (:method ((value string) (type (eql :string)) (wanted (eql :symbol)))
+ (string-to-symbol (frob-case value)))
+
+ ;; Identifiers.
+ (:method ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
+ (substitute #\_ #\- (frob-case (symbol-name value)))))
+
+(defun get-property (pset name type &optional default)
+ "Fetch a property from a property set.
+
+ If a property NAME is not found in PSET, or if a property is found, but
+ its type doesn't match TYPE, then return DEFAULT and NIL; otherwise return
+ 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."
+
+ (let ((prop (find name pset :key #'p-key)))
+ (with-default-error-location ((and prop (p-location prop)))
+ (cond ((not prop)
+ (values default nil))
+ ((not type)
+ (setf (p-seenp prop) t)
+ (values prop (p-location prop)))
+ (t
+ (setf (p-seenp prop) t)
+ (values (coerce-property-value (p-value prop)
+ (p-type prop)
+ type)
+ (p-location prop)))))))
+
+(defun check-unused-properties (pset)
+ "Issue errors about unused properties in PSET."
+ (dolist (prop pset)
+ (unless (p-seenp prop)
+ (cerror*-with-location (p-location prop) "Unknown property `~A'"
+ (p-name prop)))))a
+
+;;;--------------------------------------------------------------------------
+;;; Property set parsing.
+
+(defun parse-expression (lexer)
+ "Parse an expression from the LEXER.
+
+ The return values are the expression's VALUE and TYPE; currently the
+ types are :ID, :INTEGER and :STRING. If an error prevented a sane value
+ being produced, the TYPE :INVALID is returned.
+
+ Expression syntax is rather limited at the moment:
+
+ expression : term | expression `+' term | expression `-' term
+ term : factor | term `*' factor | term `/' factor
+ factor : primary | `+' factor | `-' factor
+ primary : integer | identifier | string
+ | `(' expression `)'
+ | `?' lisp-expression
+
+ Identifiers are just standalone things. They don't name values. The
+ operators only work on integer values at the moment. (Confusingly, you
+ can manufacture rational numbers using the division operator, but they
+ still get called integers.)"
+
+ (let ((valstack nil)
+ (opstack nil))
+
+ ;; The following is a simple operator-precedence parser: the
+ ;; recursive-descent parser I wrote the first time was about twice the
+ ;; size and harder to extend.
+ ;;
+ ;; The parser flips between two states, OPERAND and OPERATOR. It starts
+ ;; out in OPERAND state, and tries to parse a sequence of prefix
+ ;; operators followed by a primary expression. Once it's found one, it
+ ;; pushes the operand onto the value stack and flips to OPERATOR state;
+ ;; if it fails, it reports a syntax error and exits. The OPERAND state
+ ;; tries to read a sequence of postfix operators followed by an infix
+ ;; operator; if it fails, it assumes that it hit the stuff following the
+ ;; expression and stops.
+ ;;
+ ;; Each operator is pushed onto a stack consisting of lists of the form
+ ;; (FUNC PREC TY*). The PREC is a precedence -- higher numbers mean
+ ;; tighter binding. The TY* are operand types; operands are popped off
+ ;; the operand stack, checked against the requested types, and passed to
+ ;; the FUNC, which returns a new operand to be pushed in their place.
+ ;;
+ ;; Usually, when a binary operator is pushed, existing stacked operators
+ ;; with higher precedence are applied. Whether operators with /equal/
+ ;; precedence are also applied depends on the associativity of the
+ ;; operator: apply equal precedence operators for left-associative
+ ;; operators, don't apply for right-associative. When we reach the end
+ ;; of the expression, all the remaining operators on the stack are
+ ;; applied.
+ ;;
+ ;; Parenthesized subexpressions are implemented using a hack: when we
+ ;; find an open paren in operand position, a fake operator is pushed with
+ ;; an artificially low precedece, which protects the operators beneath
+ ;; from premature application. The fake operator's function reports an
+ ;; error -- this will be triggered only if we reach the end of the
+ ;; expression before a matching close-paren, because the close-paren
+ ;; handler will pop the fake operator before it does any harm.
+
+ (restart-case
+ (labels ((apply-op (op)
+ ;; Apply the single operator list OP to the values on the
+ ;; value stack.
+ (let ((func (pop op))
+ (args nil))
+ (dolist (ty (reverse (cdr op)))
+ (let ((arg (pop valstack)))
+ (cond ((eq (car arg) :invalid)
+ (setf func nil))
+ ((eq (car arg) ty)
+ (push (cdr arg) args))
+ (t
+ (cerror* "Type mismatch: wanted ~A; found ~A"
+ ty (car arg))
+ (setf func nil)))))
+ (if func
+ (multiple-value-bind (type value) (apply func args)
+ (push (cons type value) valstack))
+ (push '(:invalid . nil) valstack))))
+
+ (apply-all (prec)
+ ;; Apply all operators with precedence PREC or higher.
+ (loop
+ (when (or (null opstack) (< (cadar opstack) prec))
+ (return))
+ (apply-op (pop opstack)))))
+
+ (tagbody
+
+ operand
+ ;; Operand state. Push prefix operators, and try to read a
+ ;; primary operand.
+ (case (token-type lexer)
+
+ ;; Aha. A primary. Push it onto the stack, and see if
+ ;; there's an infix operator.
+ ((:integer :id :string)
+ (push (cons (token-type lexer)
+ (token-value lexer))
+ valstack)
+ (go operator))
+
+ ;; Look for a Lisp S-expression.
+ (#\?
+ (with-lexer-stream (stream lexer)
+ (let ((value (eval (read stream t))))
+ (push (cons (property-type value) value) valstack)))
+ (go operator))
+
+ ;; Arithmetic unary operators. Push an operator for `+' for
+ ;; the sake of type-checking.
+ (#\+
+ (push (list (lambda (x) (values :integer x))
+ 10 :integer)
+ opstack))
+ (#\-
+ (push (list (lambda (x) (values :integer (- x)))
+ 10 :integer)
+ opstack))
+
+ ;; The open-paren hack. Push a magic marker which will
+ ;; trigger an error if we hit the end of the expression.
+ ;; Inside the paren, we're still looking for an operand.
+ (#\(
+ (push (list (lambda ()
+ (error "Expected `)' but found ~A"
+ (format-token lexer)))
+ -1)
+ opstack))
+
+ ;; Failed to find anything. Report an error and give up.
+ (t
+ (error "Expected expression but found ~A"
+ (format-token lexer))))
+
+ ;; Assume prefix operators as the default, so go round for more.
+ (next-token lexer)
+ (go operand)
+
+ operator
+ ;; Operator state. Push postfix operators, and try to read an
+ ;; infix operator. It turns out that we're always a token
+ ;; behind here, so catch up.
+ (next-token lexer)
+ (case (token-type lexer)
+
+ ;; Binary operators.
+ (#\+ (apply-all 3)
+ (push (list (lambda (x y) (values :integer (+ x y)))
+ 3 :integer :integer)
+ opstack))
+ (#\- (apply-all 3)
+ (push (list (lambda (x y) (values :integer (- x y)))
+ 3 :integer :integer)
+ opstack))
+ (#\* (apply-all 5)
+ (push (list (lambda (x y) (values :integer (* x y)))
+ 5 :integer :integer)
+ opstack))
+ (#\/ (apply-all 5)
+ (push (list (lambda (x y)
+ (if (zerop y)
+ (progn (cerror* "Division by zero")
+ (values nil :invalid))
+ (values (/ x y) :integer)))
+ 5 :integer :integer)
+ opstack))
+
+ ;; The close-paren hack. Finish off the operators pushed
+ ;; since the open-paren. If the operator stack is now empty,
+ ;; this is someone else's paren, so exit. Otherwise pop our
+ ;; magic marker, and continue looking for an operator.
+ (#\) (apply-all 0)
+ (when (null opstack)
+ (go done))
+ (pop opstack)
+ (go operator))
+
+ ;; Nothing useful. Must have hit the end, so leave.
+ (t (go done)))
+
+ ;; Assume we found the binary operator as a default, so snarf a
+ ;; token and head back.
+ (next-token lexer)
+ (go operand)
+
+ done)
+
+ ;; Apply all the pending operators. If there's an unmatched
+ ;; open paren, this will trigger the error message.
+ (apply-all -99)
+
+ ;; If everything worked out, we should have exactly one operand
+ ;; left. This is the one we want.
+ (assert (and (consp valstack)
+ (null (cdr valstack))))
+ (values (cdar valstack) (caar valstack)))
+ (continue ()
+ :report "Return an invalid value and continue"
+ (values nil :invalid)))))
+
+(defun parse-property-set (lexer)
+ "Parse a property set from LEXER.
+
+ If there wasn't one to parse, return nil; this isn't considered an error,
+ and GET-PROPERTY will perfectly happily report defaults for all requested
+ properties."
+
+ (let ((pset nil))
+ (when (require-token lexer #\[ :errorp nil)
+ (loop
+ (let ((name (require-token lexer :id)))
+ (require-token lexer #\=)
+ (multiple-value-bind (value type) (parse-expression lexer)
+ (unless (eq type :invalid)
+ (push (make-property name value
+ :type type
+ :location (file-location lexer))
+ pset))))
+ (unless (require-token lexer #\, :errorp nil)
+ (return)))
+ (require-token lexer #\])
+ (nreverse pset))))
+
+;;;--------------------------------------------------------------------------
+;;; Testing cruft.
+
+#+test
+(with-input-from-string (raw "[role = before, integer = 42 * (3 - 1]")
+ (let* ((in (make-instance 'position-aware-input-stream :stream raw))
+ (lexer (make-instance 'sod-lexer :stream in)))
+ (next-char lexer)
+ (next-token lexer)
+ (multiple-value-call #'values
+ (parse-property-set lexer)
+ (token-type lexer))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; System definition for SOD
+;;;
+;;; (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:defpackage #:sod-package
+ (:use #:common-lisp #:asdf))
+
+(cl:in-package #:sod-package)
+
+;;;--------------------------------------------------------------------------
+;;; Definition.
+
+(defsystem sod
+
+ ;; Boring copyright stuff.
+ :version "1.0.0"
+ :author "Mark Wooding"
+ :license "GNU General Public License, version 2 or later"
+
+ ;; Documentation.
+ :description "A Sensible Object Definition for C."
+
+ :long-description
+ "This system implements a fairly simple, yet powerful object system for
+ plain old C. Its main features are as follows.
+
+ * Multiple inheritance, done properly (unlike C++, say), with a
+ superclass linearlization algorithm, and exactly one copy of any
+ superclass's slots.
+
+ * Method combinations, and multiple flavours of methods, to make mixin
+ classes more useful.
+
+ * The default method combination doesn't depend on the programmer
+ statically predicting which superclass's method to delegate to.
+ Multiple inheritance makes this approach (taken by C++) fail: the
+ right next method might be an unknown sibling, and two siblings might
+ be in either order depending on descendents.
+
+ * Minimal runtime support requirements, so that it's suitable for use
+ wherever C is -- e.g., interfacing to other languages."
+
+ ;; And now for how to build it.
+ ;;
+ ;; The big tables in parser.lisp need to be earlier. CLEAR-THE-DECKS ought
+ ;; to do more stuff, including calling BOOTSTRAP-CLASSES. Generally, the
+ ;; code isn't very well organized at the moment.
+ :components
+ ((:file "package")
+ (:file "utilities" :depends-on ("package"))
+ (:file "tables" :depends-on ("package"))
+ (:file "c-types" :depends-on ("utilities"))
+ (:file "posn-stream" :depends-on ("utilities"))
+ (:file "lex" :depends-on ("posn-stream"))
+ (: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 "module" :depends-on ("parse-c-types" "tables"))
+ (:file "output" :depends-on ("module"))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!-- Created with Inkscape (http://www.inkscape.org/) -->
+<svg
+ xmlns:dc="http://purl.org/dc/elements/1.1/"
+ xmlns:cc="http://creativecommons.org/ns#"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:svg="http://www.w3.org/2000/svg"
+ xmlns="http://www.w3.org/2000/svg"
+ xmlns:xlink="http://www.w3.org/1999/xlink"
+ xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
+ xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
+ width="389.75183"
+ height="344.37515"
+ id="svg2"
+ sodipodi:version="0.32"
+ inkscape:version="0.46"
+ sodipodi:docname="standard-method-combination.svg"
+ inkscape:output_extension="org.inkscape.output.svg.inkscape"
+ version="1.0">
+ <defs
+ id="defs4">
+ <marker
+ inkscape:stockid="Arrow1Mend"
+ orient="auto"
+ refY="0.0"
+ refX="0.0"
+ id="Arrow1Mend"
+ style="overflow:visible;">
+ <path
+ id="path3268"
+ d="M 0.0,0.0 L 5.0,-5.0 L -12.5,0.0 L 5.0,5.0 L 0.0,0.0 z "
+ style="fill-rule:evenodd;stroke:#000000;stroke-width:1.0pt;marker-start:none;"
+ transform="scale(0.4) rotate(180) translate(10,0)" />
+ </marker>
+ <inkscape:perspective
+ sodipodi:type="inkscape:persp3d"
+ inkscape:vp_x="0 : 526.18109 : 1"
+ inkscape:vp_y="0 : 1000 : 0"
+ inkscape:vp_z="744.09448 : 526.18109 : 1"
+ inkscape:persp3d-origin="372.04724 : 350.78739 : 1"
+ id="perspective108" />
+ <marker
+ inkscape:stockid="Arrow2Mend"
+ orient="auto"
+ refY="0"
+ refX="0"
+ id="Arrow2Mend"
+ style="overflow:visible">
+ <path
+ id="path3204"
+ style="font-size:12px;fill-rule:evenodd;stroke-width:0.625;stroke-linejoin:round"
+ d="M 8.7185878,4.0337352 L -2.2072895,0.016013256 L 8.7185884,-4.0017078 C 6.97309,-1.6296469 6.9831476,1.6157441 8.7185878,4.0337352 z"
+ transform="scale(-0.6,-0.6)" />
+ </marker>
+ <radialGradient
+ xlink:href="#linearGradient3074"
+ r="21.214399"
+ inkscape:collect="always"
+ id="radialGradient3078"
+ fy="158.17307"
+ fx="61.08794"
+ cy="158.17307"
+ cx="61.08794"
+ gradientTransform="scale(1.2180558,0.8209804)"
+ gradientUnits="userSpaceOnUse" />
+ <linearGradient
+ id="linearGradient3074">
+ <stop
+ style="stop-color:#ffffff;stop-opacity:0.53370786;"
+ offset="0.0000000"
+ id="stop3075" />
+ <stop
+ style="stop-color:#000000;stop-opacity:0.69101125;"
+ offset="1.0000000"
+ id="stop3076" />
+ </linearGradient>
+ </defs>
+ <sodipodi:namedview
+ id="base"
+ pagecolor="#ffffff"
+ bordercolor="#666666"
+ borderopacity="1.0"
+ gridtolerance="10000"
+ guidetolerance="10"
+ objecttolerance="10"
+ inkscape:pageopacity="0.0"
+ inkscape:pageshadow="2"
+ inkscape:zoom="2.268243"
+ inkscape:cx="194.87592"
+ inkscape:cy="172.21547"
+ inkscape:document-units="px"
+ inkscape:current-layer="layer1"
+ showgrid="false"
+ inkscape:window-width="1337"
+ inkscape:window-height="998"
+ inkscape:window-x="225"
+ inkscape:window-y="17"
+ showborder="false" />
+ <metadata
+ id="metadata7">
+ <rdf:RDF>
+ <cc:Work
+ rdf:about="">
+ <dc:format>image/svg+xml</dc:format>
+ <dc:type
+ rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
+ <cc:license
+ rdf:resource="http://creativecommons.org/licenses/by-sa/3.0/" />
+ <dc:title>SOD standard method combination diagram</dc:title>
+ <dc:date>2009-09-18</dc:date>
+ <dc:creator>
+ <cc:Agent>
+ <dc:title>Mark Wooding</dc:title>
+ </cc:Agent>
+ </dc:creator>
+ <dc:description>A diagram showing how the applicable methods are invoked by standard method combination in the SOD object system.</dc:description>
+ <dc:rights>
+ <cc:Agent>
+ <dc:title>Straylight/Edgeware</dc:title>
+ </cc:Agent>
+ </dc:rights>
+ <dc:publisher>
+ <cc:Agent>
+ <dc:title>Straylight/Edgeware</dc:title>
+ </cc:Agent>
+ </dc:publisher>
+ <dc:language>en-GB</dc:language>
+ </cc:Work>
+ <cc:License
+ rdf:about="http://creativecommons.org/licenses/by-sa/3.0/">
+ <cc:permits
+ rdf:resource="http://creativecommons.org/ns#Reproduction" />
+ <cc:permits
+ rdf:resource="http://creativecommons.org/ns#Distribution" />
+ <cc:requires
+ rdf:resource="http://creativecommons.org/ns#Notice" />
+ <cc:requires
+ rdf:resource="http://creativecommons.org/ns#Attribution" />
+ <cc:permits
+ rdf:resource="http://creativecommons.org/ns#DerivativeWorks" />
+ <cc:requires
+ rdf:resource="http://creativecommons.org/ns#ShareAlike" />
+ </cc:License>
+ </rdf:RDF>
+ </metadata>
+ <g
+ inkscape:label="Layer 1"
+ inkscape:groupmode="layer"
+ id="layer1"
+ transform="translate(-76.574432,-549.18106)">
+ <g
+ id="g3106">
+ <g
+ transform="translate(-6.4194226,7.8915857)"
+ id="g2941">
+ <use
+ transform="translate(-87.171262,-145.57702)"
+ x="0"
+ y="0"
+ xlink:href="#rect2383"
+ id="use8070"
+ width="744.09448"
+ height="1052.3622" />
+ <use
+ height="1052.3622"
+ width="744.09448"
+ id="use8068"
+ xlink:href="#rect2383"
+ y="0"
+ x="0"
+ transform="translate(-91.171262,-141.57702)" />
+ <use
+ transform="translate(-95.171262,-137.57702)"
+ x="0"
+ y="0"
+ xlink:href="#rect2383"
+ id="use8057"
+ width="744.09448"
+ height="1052.3622" />
+ </g>
+ <text
+ id="text7219"
+ y="743.74951"
+ x="137.82718"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ xml:space="preserve"><tspan
+ id="tspan7221"
+ y="743.74951"
+ x="137.82718"
+ sodipodi:role="line">Before method</tspan></text>
+ <path
+ sodipodi:nodetypes="cc"
+ id="path7232"
+ d="M 96.33489,740.26133 L 127.09404,709.94688"
+ style="fill:none;fill-rule:evenodd;stroke:#00c800;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
+ <flowRoot
+ transform="translate(-301.49963,-67.218524)"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:center;line-height:125%;writing-mode:lr-tb;text-anchor:middle;fill:#00c800;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ id="flowRoot7234"
+ xml:space="preserve"><flowRegion
+ id="flowRegion7236"><rect
+ style="text-align:center;line-height:125%;writing-mode:lr-tb;text-anchor:middle;fill:#00c800;fill-opacity:1"
+ y="756.86218"
+ x="377"
+ height="38.5"
+ width="35.5"
+ id="rect7238" /></flowRegion><flowPara
+ id="flowPara7240">Most to least specific</flowPara></flowRoot> <path
+ sodipodi:nodetypes="cc"
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ d="M 233.72077,768.23762 L 215.68955,750.20639"
+ id="path7292" />
+ <text
+ xml:space="preserve"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ x="149.36943"
+ y="762.65088"
+ id="text7294"><tspan
+ sodipodi:role="line"
+ id="tspan7296"
+ x="149.36943"
+ y="762.65088"
+ style="font-style:italic">call-next-method</tspan></text>
+ <path
+ id="path7370"
+ d="M 215.3571,720.94472 L 233.38832,702.91349"
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ sodipodi:nodetypes="cc" />
+ <use
+ height="1052.3622"
+ width="744.09448"
+ transform="matrix(1,0,0,-1,193.60423,1471.9955)"
+ id="use2946"
+ xlink:href="#g2941"
+ y="0"
+ x="0" />
+ <text
+ xml:space="preserve"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ x="334.1524"
+ y="735.396"
+ id="text7428"><tspan
+ sodipodi:role="line"
+ x="334.1524"
+ y="735.396"
+ id="tspan7430">After method</tspan></text>
+ <path
+ style="fill:none;fill-rule:evenodd;stroke:#00c800;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ d="M 414.991,709.26598 L 445.75015,739.58043"
+ id="path7432"
+ sodipodi:nodetypes="cc" />
+ <flowRoot
+ xml:space="preserve"
+ id="flowRoot7434"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:center;line-height:125%;writing-mode:lr-tb;text-anchor:middle;fill:#00c800;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ transform="translate(54.25206,-67.572077)"><flowRegion
+ id="flowRegion7436"><rect
+ id="rect7438"
+ width="35.5"
+ height="38.5"
+ x="377"
+ y="756.86218"
+ style="text-align:center;line-height:125%;writing-mode:lr-tb;text-anchor:middle;fill:#00c800;fill-opacity:1" /></flowRegion><flowPara
+ id="flowPara7440">Least to most specific</flowPara></flowRoot> <path
+ id="path7442"
+ d="M 309.99443,702.58108 L 328.02565,720.61231"
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ sodipodi:nodetypes="cc" />
+ <text
+ id="text7444"
+ y="715.43781"
+ x="326.31656"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ xml:space="preserve"><tspan
+ style="font-style:italic"
+ y="715.43781"
+ x="326.31656"
+ id="tspan7446"
+ sodipodi:role="line">return</tspan></text>
+ <path
+ sodipodi:nodetypes="cc"
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ d="M 328.3581,749.87398 L 310.32688,767.90521"
+ id="path7448" />
+ <path
+ id="path7460"
+ d="M 286.62089,703.05143 L 286.62089,767.7517"
+ style="fill:none;fill-rule:evenodd;stroke:#0000c8;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:0.75000000000000000, 0.75000000000000000;stroke-dashoffset:0;stroke-opacity:1" />
+ <text
+ transform="matrix(0,1,-1,0,0,0)"
+ id="text7983"
+ y="-289.09686"
+ x="705.11279"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#0000c8;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ xml:space="preserve"><tspan
+ y="-289.09686"
+ x="705.11279"
+ id="tspan7985"
+ sodipodi:role="line">Return value</tspan></text>
+ </g>
+ <g
+ id="g3071">
+ <g
+ id="g2966">
+ <rect
+ y="861.61884"
+ x="211.62221"
+ height="16.482248"
+ width="120.76241"
+ id="rect2383"
+ style="font-size:10px;fill:#c8c8ff;fill-opacity:1;stroke:#000000;stroke-width:0.75;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
+ <rect
+ style="font-size:10px;fill:#c8c8ff;fill-opacity:1;stroke:#000000;stroke-width:0.75;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect2883"
+ width="120.76241"
+ height="16.482248"
+ x="211.62221"
+ y="828.91174" />
+ <rect
+ style="font-size:10px;fill:#c8c8ff;fill-opacity:1;stroke:#000000;stroke-width:0.75;stroke-linejoin:miter;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ id="rect2875"
+ width="120.76241"
+ height="16.482248"
+ x="211.62221"
+ y="770.448" />
+ <path
+ id="path4477"
+ d="M 243.59829,860.1812 L 243.59829,847.80683"
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
+ <path
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ d="M 295.09829,847.18855 L 295.09829,859.56292"
+ id="path5000" />
+ <text
+ xml:space="preserve"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:end;line-height:125%;writing-mode:lr-tb;text-anchor:end;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ x="239.44922"
+ y="856.36218"
+ id="text2952"
+ sodipodi:linespacing="125%"><tspan
+ sodipodi:role="line"
+ id="tspan2954"
+ x="239.44922"
+ y="856.36218"
+ style="font-style:italic;text-align:end;line-height:125%;writing-mode:lr-tb;text-anchor:end">call-next-method</tspan></text>
+ <text
+ id="text5030"
+ y="855.92719"
+ x="299.5"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ xml:space="preserve"><tspan
+ style="font-style:italic"
+ y="855.92719"
+ x="299.5"
+ id="tspan5032"
+ sodipodi:role="line">return</tspan></text>
+ <path
+ id="path5048"
+ d="M 295.09829,814.18855 L 295.09829,826.56292"
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
+ <use
+ x="0"
+ y="0"
+ xlink:href="#text5030"
+ id="use2960"
+ transform="translate(0,-33)"
+ width="744.09448"
+ height="1052.3622" />
+ <path
+ id="path5060"
+ d="M 243.59829,801.6812 L 243.59829,789.30683"
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
+ <path
+ id="path5046"
+ d="M 243.59829,827.1812 L 243.59829,814.80683"
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
+ <path
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ d="M 295.09829,788.68855 L 295.09829,801.06292"
+ id="path5062" />
+ <text
+ id="text5072"
+ y="808.65448"
+ x="263"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ xml:space="preserve"><tspan
+ y="808.65448"
+ x="263"
+ id="tspan5074"
+ sodipodi:role="line">. . .</tspan></text>
+ <use
+ x="0"
+ y="0"
+ xlink:href="#text2952"
+ id="use2956"
+ transform="translate(0,-33)"
+ width="744.09448"
+ height="1052.3622" />
+ <use
+ x="0"
+ y="0"
+ xlink:href="#text2952"
+ id="use2958"
+ transform="translate(0,-58.5)"
+ width="744.09448"
+ height="1052.3622" />
+ <use
+ x="0"
+ y="0"
+ xlink:href="#text5030"
+ id="use2962"
+ transform="translate(0,-58.5)"
+ width="744.09448"
+ height="1052.3622" />
+ <flowRoot
+ xml:space="preserve"
+ id="flowRoot5638"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:start;line-height:125%;writing-mode:lr-tb;text-anchor:start;fill:#00c800;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ transform="translate(-34.5,48.169125)"><flowRegion
+ id="flowRegion5640"><rect
+ id="rect5642"
+ width="35.5"
+ height="38.5"
+ x="377"
+ y="756.86218"
+ style="text-align:start;line-height:125%;writing-mode:lr-tb;text-anchor:start;fill:#00c800;fill-opacity:1" /></flowRegion><flowPara
+ id="flowPara5644">Most to least specific</flowPara></flowRoot> <path
+ id="path3347"
+ d="M 338,876.33367 L 338,772.83367"
+ style="fill:none;fill-rule:evenodd;stroke:#00c800;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
+ </g>
+ <path
+ id="path3341"
+ d="M 243.59829,892.6812 L 243.59829,880.30683"
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
+ <path
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
+ d="M 295.09829,880.18855 L 295.09829,892.56292"
+ id="path3335" />
+ <use
+ height="1052.3622"
+ width="744.09448"
+ transform="translate(0,33)"
+ id="use2964"
+ xlink:href="#text5030"
+ y="0"
+ x="0" />
+ <g
+ transform="translate(35.976561,0)"
+ id="g2994">
+ <text
+ sodipodi:linespacing="125%"
+ id="text3155"
+ y="873.42499"
+ x="236.11349"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:center;line-height:125%;writing-mode:lr-tb;text-anchor:middle;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ xml:space="preserve"><tspan
+ id="tspan3159"
+ y="873.42499"
+ x="236.11349"
+ sodipodi:role="line">Around method</tspan></text>
+ <use
+ x="0"
+ y="0"
+ xlink:href="#text3155"
+ id="use2986"
+ transform="translate(-2.5939942e-6,-32.70712)"
+ width="744.09448"
+ height="1052.3622" />
+ <use
+ x="0"
+ y="0"
+ xlink:href="#text3155"
+ id="use2988"
+ transform="translate(-2.5939942e-6,-91.170866)"
+ width="744.09448"
+ height="1052.3622" />
+ </g>
+ </g>
+ <g
+ id="g3041">
+ <use
+ height="1052.3622"
+ width="744.09448"
+ transform="translate(0,-269.42743)"
+ id="use3038"
+ xlink:href="#text2952"
+ y="0"
+ x="0" />
+ <flowRoot
+ transform="translate(-24.870058,-7.68156)"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ id="flowRoot7999"
+ xml:space="preserve"><flowRegion
+ id="flowRegion8001"><rect
+ y="558.09454"
+ x="287.08536"
+ height="24.395184"
+ width="79.903069"
+ id="rect8003" /></flowRegion><flowPara
+ id="flowPara8005">‘No next method’ error</flowPara></flowRoot> <use
+ height="1052.3622"
+ width="744.09448"
+ transform="translate(-7.6293945e-6,-178.00001)"
+ id="use2990"
+ xlink:href="#g2966"
+ y="0"
+ x="0" />
+ <path
+ id="path7372"
+ d="M 244.26849,590.75383 L 244.26849,578.37946"
+ style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:0.75000000000000000;stroke-linecap:butt;stroke-linejoin:miter;marker-end:url(#Arrow1Mend);stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
+ <g
+ id="g3138">
+ <path
+ d="M 252.33396,551.87647 L 253.31263,549.30103 L 253.7247,551.92798 L 255.37298,549.97064 L 255.11544,551.97949 L 258.92709,550.3312 L 256.14561,552.80363 L 259.18463,554.91549 L 255.88807,553.98833 L 258.56653,558.62413 L 255.37298,554.81247 L 255.78505,560.58146 L 254.3428,555.58511 L 251.71585,558.26357 L 253.41564,554.70946 L 250.53115,556.25472 L 252.33396,554.45191 L 248.93438,555.37907 L 250.73718,553.7823 L 248.11023,553.16419 L 251.25227,552.54608 L 250.78869,550.12517 L 252.33396,551.87647 z"
+ id="path3079"
+ sodipodi:nodetypes="ccccccccccccccccccccccc"
+ style="fill:#ffff00;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.19195631pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" />
+ <path
+ d="M 252.53999,552.6491 L 251.35529,551.41289 L 252.07641,553.00966 L 249.55248,553.2157 L 251.92189,553.67928 L 250.68567,554.55493 L 253.10659,553.98833 L 252.64301,554.76097 L 254.08526,554.03984 L 253.51866,555.63662 L 254.49733,554.86398 L 255.16695,556.61528 L 254.85789,554.24588 L 255.99109,554.76097 L 255.01242,553.57626 L 256.6607,553.67928 L 255.37298,553.11268 L 256.24863,552.13401 L 254.54884,552.39156 L 254.65186,551.41289 L 253.57017,552.90665 L 253.1581,550.94931 L 252.53999,552.6491 z"
+ id="path3080"
+ sodipodi:nodetypes="ccccccccccccccccccccccc"
+ style="fill:#ff3f00;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.19195631pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" />
+ <path
+ style="fill:#a6a667;fill-opacity:1;fill-rule:evenodd;stroke:#000000;stroke-width:0.23994538;stroke-linecap:butt;stroke-linejoin:miter;stroke-miterlimit:4;stroke-opacity:1"
+ sodipodi:nodetypes="ccccccccccccccc"
+ id="path1817"
+ d="M 247.30717,549.89628 C 246.00963,549.94176 244.84256,550.91505 244.19739,551.52591 C 243.54502,552.14928 243.51447,553.31251 243.61252,554.07733 C 243.71058,554.84216 243.96644,555.43302 243.96644,555.43302 L 245.06419,554.95313 C 245.06419,554.95313 244.87482,554.509 244.80025,553.92736 C 244.72626,553.35025 244.78543,552.72675 245.16617,552.28974 C 245.60405,551.74993 246.88452,550.98903 248.22897,551.20098 C 249.13851,551.42743 249.67447,552.72927 250.43297,553.23152 C 251.19147,553.73377 252.21663,553.97614 253.54026,553.71141 C 254.12914,553.53696 254.09465,552.46369 253.30631,552.53568 C 252.21323,552.7543 251.61772,552.57935 251.09882,552.23575 C 250.57991,551.89215 250.13911,551.30485 249.60516,550.66411 L 249.59316,550.65811 C 249.11476,550.16521 248.19393,549.88725 247.30717,549.89628 z" />
+ <path
+ style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:0.19195631pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+ sodipodi:nodetypes="cc"
+ id="path2440"
+ d="M 253.49996,552.61443 C 253.49996,552.61443 252.20973,553.87567 251.25293,553.62922" />
+ <path
+ style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:0.19195631pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+ sodipodi:nodetypes="cc"
+ id="path2441"
+ d="M 251.10796,552.23751 C 250.84702,552.54195 249.60028,552.13603 249.0494,551.73012" />
+ <path
+ style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:0.19195631pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+ sodipodi:nodetypes="cc"
+ id="path2442"
+ d="M 247.81716,549.9035 C 247.87515,550.09197 247.1503,551.23722 246.51243,551.39669" />
+ <path
+ style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:0.19195631pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+ sodipodi:nodetypes="cc"
+ id="path2443"
+ d="M 245.2367,550.70084 C 245.2367,550.70084 245.57013,551.62864 245.12073,552.33899" />
+ <path
+ style="fill:none;fill-opacity:0.75;fill-rule:evenodd;stroke:#000000;stroke-width:0.19195631pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+ sodipodi:nodetypes="cc"
+ id="path2444"
+ d="M 243.55506,553.2523 C 243.96097,553.2378 244.88878,554.13661 244.93227,554.52803" />
+ <path
+ d="M 242.68783,554.71626 C 242.57768,555.20411 242.65793,556.90337 241.20017,558.32955 C 237.07117,559.4961 234.0618,562.82062 234.0618,566.78418 C 234.0618,571.7145 238.68629,575.71115 244.37945,575.71115 C 250.0726,575.71115 254.6911,571.7145 254.6911,566.78418 C 254.6911,562.61923 251.37869,559.14526 246.92287,558.15833 C 246.14765,557.08259 245.53252,555.5894 245.72314,554.65131 C 245.3779,554.17559 243.72357,553.79879 242.68783,554.71626 z"
+ id="path1193"
+ sodipodi:nodetypes="cccccccc"
+ style="fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" />
+ <path
+ d="M 103.57781,124.91055 A 30.456171,20.527729 0 1 1 42.665472,124.91055 A 30.456171,20.527729 0 1 1 103.57781,124.91055 z"
+ id="path2452"
+ sodipodi:cx="73.121643"
+ sodipodi:cy="124.91055"
+ sodipodi:rx="30.456171"
+ sodipodi:ry="20.527729"
+ sodipodi:type="arc"
+ style="fill:url(#radialGradient3078);fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1pt;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+ transform="matrix(0.2562315,0,0,0.2197998,225.48526,537.77762)" />
+ </g>
+ <g
+ id="g3028"
+ transform="translate(35.941561,-179.31502)">
+ <text
+ xml:space="preserve"
+ style="font-size:10px;font-style:normal;font-variant:normal;font-weight:normal;font-stretch:normal;text-align:center;line-height:125%;writing-mode:lr-tb;text-anchor:middle;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;font-family:Palladio Uralic;-inkscape-font-specification:Palladio Uralic"
+ x="236.11349"
+ y="873.42499"
+ id="text3030"
+ sodipodi:linespacing="125%"><tspan
+ sodipodi:role="line"
+ x="236.11349"
+ y="873.42499"
+ id="tspan3032">Primary method</tspan></text>
+ <use
+ height="1052.3622"
+ width="744.09448"
+ transform="translate(-2.5939942e-6,-32.70712)"
+ id="use3034"
+ xlink:href="#text3030"
+ y="0"
+ x="0" />
+ <use
+ height="1052.3622"
+ width="744.09448"
+ transform="translate(-2.5939942e-6,-91.170866)"
+ id="use3036"
+ xlink:href="#text3030"
+ y="0"
+ x="0" />
+ </g>
+ </g>
+ </g>
+</svg>
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Main tables for the translator
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; Main tables.
+
+(defvar *module-map* (make-hash-table :test #'equal)
+ "A hash table mapping file truenames (pathnames) to modules.
+
+ This is used to prevent multiple inclusion of a single module, which would
+ be bad. Usually it maps pathnames to MODULE objects. As a special case,
+ the truename a module which is being parsed maps to :IN-PROGRESS, which
+ can be used to detect dependency cycles.")
+
+(defvar *type-map* (make-hash-table :test #'equal)
+ "A hash table mapping type names to the C types they describe.
+
+ Since a class is a C type, it gets its own entry in here as a C-CLASS-TYPE
+ object. This is how we find classes by name: the C-CLASS-TYPE object has
+ a reference to the underlying SOD-CLASS instance.")
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defparameter *clear-the-decks-functions*
+ '(reset-type-and-module-map
+ populate-type-map
+ bootstrap-classes))
+
+(defun reset-type-and-module-map ()
+ "Reset the main hash tables, clearing the translator's state.
+
+ One of the *CLEAR-THE-DECKS-FUNCTIONS*."
+
+ (setf *module-map* (make-hash-table :test #'equal)
+ *type-map* (make-hash-table :test #'equal)))
+
+(defun populate-type-map ()
+ "Store some important simple types in the type map."
+ (dolist (name '("va_list" "size_t" "ptrdiff_t"))
+ (setf (gethash name *type-map*)
+ (make-simple-type name))))
+
+(defun clear-the-decks ()
+ "Reinitialize the translator's state.
+
+ This is mainly useful when testing the translator from a Lisp REPL."
+ (dolist (func *clear-the-decks-functions*)
+ (funcall func)))
+
+#+test
+(clear-the-decks)
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Various handy utilities
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; List utilities.
+
+(define-condition inconsistent-merge-error (error)
+ ((candidates :initarg :candidates
+ :reader merge-error-candidates))
+ (:documentation
+ "Reports an inconsistency in the arguments passed to MERGE-LISTS.")
+ (:report (lambda (condition stream)
+ (format stream "Merge inconsistency: failed to decide among ~A."
+ (merge-error-candidates condition)))))
+
+(defun merge-lists (lists &key pick (test #'eql))
+ "Return a merge of the given LISTS.
+
+ The resulting LIST contains the items of the given lists, with duplicates
+ removed. The order of the resulting list is consistent with the orders of
+ the input LISTS in the sense that if A precedes B in some input list then
+ A will also precede B in the output list. If the lists aren't consistent
+ (e.g., some list contains A followed by B, and another contains B followed
+ by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled.
+
+ Item equality is determined by TEST.
+
+ If there is an ambiguity at any point -- i.e., a choice between two or
+ more possible next items to emit -- then PICK is called to arbitrate.
+ PICK is called with two arguments: the list of candidate next items, and
+ the current output list. It should return one of the candidate items. If
+ PICK is omitted then an arbitrary choice is made.
+
+ The primary use of this function is in computing class precedence lists.
+ By building the input lists and selecting the PICK function appropriately,
+ a variety of different CPL algorithms can be implemented."
+
+ ;; In this loop, TAIL points to the last cons cell in the list. This way
+ ;; 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.)
+ (do* ((head (cons nil nil))
+ (tail head))
+ ((null lists) (cdr head))
+
+ ;; The candidate items are the ones at the front of the input lists.
+ ;; Gather them up, removing duplicates. If a candidate is somewhere in
+ ;; one of the other lists other than at the front then we reject it. If
+ ;; we've just rejected everything, then we can make no more progress and
+ ;; the input lists were inconsistent.
+ (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test))
+ (leasts (remove-if (lambda (item)
+ (some (lambda (list)
+ (member item (cdr list) :test test))
+ lists))
+ candidates))
+ (winner (cond ((null leasts)
+ (error 'inconsistent-merge-error
+ :candidates candidates))
+ ((null (cdr leasts))
+ (car leasts))
+ (pick
+ (funcall pick leasts (cdr head)))
+ (t (car leasts))))
+ (new (cons winner nil)))
+
+ ;; Check that the PICK function isn't conning us.
+ (assert (member winner leasts :test test))
+
+ ;; Update the output list and remove the winning item from the input
+ ;; lists. We know that it must be at the front of each input list
+ ;; containing it. At this point, we discard input lists entirely when
+ ;; they run out of entries. The loop ends when there are no more input
+ ;; lists left, i.e., when we've munched all of the input items.
+ (setf (cdr tail) new
+ tail new
+ lists (delete nil (mapcar (lambda (list)
+ (if (funcall test winner (car list))
+ (cdr list)
+ list))
+ lists))))))
+
+;;;--------------------------------------------------------------------------
+;;; Strings and characters.
+
+(defun frob-case (string)
+ "Twiddles the case of STRING.
+
+ If all the letters in STRING are uppercase, switch them to lowercase; if
+ they're all lowercase then switch them to uppercase. If there's a mix
+ then leave them all alone. This is an invertible transformation."
+
+ ;; Given that this operation is performed by the reader anyway, it's
+ ;; surprising that there isn't a Common Lisp function to do this built
+ ;; in.
+ (let ((flags (reduce (lambda (state ch)
+ (logior state
+ (cond ((upper-case-p ch) 1)
+ ((lower-case-p ch) 2)
+ (t 0))))
+ string
+ :initial-value 0)))
+
+ ;; Now FLAGS has bit 0 set if there are any upper-case characters, and
+ ;; bit 1 if there are lower-case. So if it's zero there were no letters
+ ;; at all, and if it's three then there were both kinds; either way, we
+ ;; leave the string unchanged. Otherwise we know how to flip the case.
+ (case flags
+ (1 (string-downcase string))
+ (2 (string-upcase string))
+ (t string))))
+
+(declaim (inline whitespace-char-p))
+(defun whitespace-char-p (char)
+ "Returns whether CHAR is a whitespace character.
+
+ Whitespaceness is determined relative to the compile-time readtable, which
+ is probably good enough for most purposes."
+ (case char
+ (#.(loop for i below char-code-limit
+ for ch = (code-char i)
+ unless (with-input-from-string (in (string ch))
+ (peek-char t in nil))
+ collect ch) t)
+ (t nil)))
+
+;;;--------------------------------------------------------------------------
+;;; Keyword arguments and lambda lists.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun transform-otherkeys-lambda-list (bvl)
+ "Process a simple lambda-list BVL which might contain &OTHER-KEYS.
+
+ &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments
+ (which must also be present); &ALLOW-OTHER-KEYS must not be present.
+
+ The behaviour is that
+
+ * the presence of non-listed keyword arguments is permitted, as if
+ &ALLOW-OTHER-KEYS had been provided, and
+
+ * a list of the keyword arguments other than the ones explicitly listed
+ is stored in the VAR.
+
+ The return value is a replacement BVL which binds the &OTHER-KEYS variable
+ as an &AUX parameter if necessary.
+
+ At least for now, fancy things like destructuring lambda-lists aren't
+ supported. I suspect you'll get away with a specializing lambda-list."
+
+ (prog ((new-bvl nil)
+ (rest-var nil)
+ (keywords nil)
+ (other-keys-var nil)
+ (tail bvl))
+
+ find-rest
+ ;; Scan forwards until we find &REST or &KEY. If we find the former,
+ ;; then remember the variable name. If we find the latter first then
+ ;; there can't be a &REST argument, so we should invent one. If we
+ ;; find neither then there's nothing to do.
+ (when (endp tail)
+ (go ignore))
+ (let ((item (pop tail)))
+ (push item new-bvl)
+ (case item
+ (&rest (when (endp tail)
+ (error "Missing &REST argument name"))
+ (setf rest-var (pop tail))
+ (push rest-var new-bvl))
+ (&aux (go ignore))
+ (&key (unless rest-var
+ (setf rest-var (gensym "REST"))
+ (setf new-bvl (nconc (list '&key rest-var '&rest)
+ (cdr new-bvl))))
+ (go scan-keywords)))
+ (go find-rest))
+
+ scan-keywords
+ ;; Read keyword argument specs one-by-one. For each one, stash it on
+ ;; the NEW-BVL list, and also parse it to extract the keyword, which
+ ;; we stash in KEYWORDS. If we don't find &OTHER-KEYS then there's
+ ;; nothing for us to do.
+ (when (endp tail)
+ (go ignore))
+ (let ((item (pop tail)))
+ (push item new-bvl)
+ (case item
+ ((&aux &allow-other-keys) (go ignore))
+ (&other-keys (go fix-tail)))
+ (let ((keyword (if (symbolp item)
+ (intern (symbol-name item) :keyword)
+ (let ((var (car item)))
+ (if (symbolp var)
+ (intern (symbol-name var) :keyword)
+ (car var))))))
+ (push keyword keywords))
+ (go scan-keywords))
+
+ fix-tail
+ ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var.
+ (pop new-bvl)
+ (when (endp tail)
+ (error "Missing &OTHER-KEYS argument name"))
+ (setf other-keys-var (pop tail))
+ (push '&allow-other-keys new-bvl)
+
+ ;; There should be an &AUX next. If there isn't, assume there isn't
+ ;; one and provide our own. (This is safe as long as nobody else is
+ ;; expecting to plumb in lambda keywords too.)
+ (when (and (not (endp tail)) (eq (car tail) '&aux))
+ (pop tail))
+ (push '&aux new-bvl)
+
+ ;; Add our shiny new &AUX argument.
+ (let ((keys-var (gensym "KEYS"))
+ (list-var (gensym "LIST")))
+ (push `(,other-keys-var (do ((,list-var nil)
+ (,keys-var ,rest-var (cddr ,keys-var)))
+ ((endp ,keys-var) (nreverse ,list-var))
+ (unless (member (car ,keys-var)
+ ',keywords)
+ (setf ,list-var
+ (cons (cadr ,keys-var)
+ (cons (car ,keys-var)
+ ,list-var))))))
+ new-bvl))
+
+ ;; Done.
+ (return (nreconc new-bvl tail))
+
+ ignore
+ ;; Nothing to do. Return the unmolested lambda-list.
+ (return bvl))))
+
+(defmacro lambda-otherkeys (bvl &body body)
+ "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword."
+ `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body))
+
+(defmacro defun-otherkeys (name bvl &body body)
+ "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword."
+ `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body))
+
+(defmacro defmethod-otherkeys (name &rest stuff)
+ "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
+ (do ((quals nil)
+ (stuff stuff (cdr stuff)))
+ ((listp (car stuff))
+ `(defmethod ,name ,@(nreverse quals)
+ ,(transform-otherkeys-lambda-list (car stuff))
+ ,@(cdr stuff)))
+ (push (car stuff) quals)))
+
+;;;--------------------------------------------------------------------------
+;;; Iteration macros.
+
+(defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) &body body)
+ "Macro for iterating over general sequences.
+
+ Iterates over a (sub)sequence SEQ, delimited by START and END (which are
+ evaluated). For each item of SEQ, BODY is invoked with VAR bound to the
+ item, and INDEXVAR (if requested) bound to the item's index. (Note that
+ this is different from most iteration constructs in Common Lisp, which
+ work by mutating the variable.)
+
+ The loop is surrounded by an anonymous BLOCK and the loop body forms an
+ implicit TAGBODY, as is usual. There is no result-form, however."
+
+ (let ((seqvar (gensym "SEQ"))
+ (startvar (gensym "START"))
+ (endvar (gensym "END"))
+ (ivar (gensym "INDEX"))
+ (bodyfunc (gensym "BODY")))
+
+ (flet ((loopguts (indexp listp use-endp)
+ ;; Build a DO-loop to do what we want.
+ (let* ((do-vars nil)
+ (end-condition (if use-endp
+ `(endp ,seqvar)
+ `(>= ,ivar ,endvar)))
+ (item (if listp
+ `(car ,seqvar)
+ `(aref ,seqvar ,ivar)))
+ (body-call `(,bodyfunc ,item)))
+ (when listp
+ (push `(,seqvar (nthcdr ,startvar ,seqvar) (cdr ,seqvar))
+ do-vars))
+ (when indexp
+ (push `(,ivar ,startvar (1+ ,ivar)) do-vars))
+ (when indexvar
+ (setf body-call (append body-call (list ivar))))
+ `(do ,do-vars (,end-condition) ,body-call))))
+
+ `(block nil
+ (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
+ (tagbody ,@body)))
+ (let* ((,seqvar ,seq)
+ (,startvar ,start))
+ (etypecase ,seqvar
+ (vector
+ (let ((,endvar (or ,end (length ,seqvar))))
+ ,(loopguts t nil nil)))
+ (list
+ (let ((,endvar ,end))
+ (if ,endvar
+ ,(loopguts t t nil)
+ ,(loopguts indexvar t t)))))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Meta-object hacking.
+
+(defgeneric copy-instance-using-class (class object &rest initargs)
+ (:documentation
+ "Return a copy of OBJECT.
+
+ OBJECT is assumed to be an instance of CLASS. The copy returned is a
+ fresh instance whose slots have the same values as OBJECT except where
+ overridden by INITARGS.")
+
+ (:method ((class standard-class) object &rest initargs)
+ (let ((copy (apply #'allocate-instance class initargs)))
+ (dolist (slot (class-slots class))
+ (if (slot-boundp-using-class class object slot)
+ (setf (slot-value-using-class class copy slot)
+ (slot-value-using-class class object slot))
+ (slot-makunbound-using-class class copy slot)))
+ (apply #'shared-initialize copy nil initargs)
+ copy)))
+
+(defun copy-instance (object &rest initargs)
+ "Return a copy of OBJECT.
+
+ The copy returned is a fresh instance whose slots have the same values as
+ OBJECT except where overridden by INITARGS."
+ (apply #'copy-instance-using-class (class-of object) object initargs))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / commitdiff
