From abdf50aad1a95f1df8d11c54ff1623077eb84193 Mon Sep 17 00:00:00 2001 Message-Id: From: Mark Wooding Date: Wed, 14 Oct 2009 01:09:19 +0100 Subject: [PATCH] Early work-in-progress. Organization: Straylight/Edgeware From: Mark Wooding Much needs to be done. --- .gitignore | 2 + .skelrc | 9 + NOTES | 38 ++ c-types.lisp | 603 +++++++++++++++++++++++++++ class-builder.lisp | 485 ++++++++++++++++++++++ class-defs.lisp | 712 ++++++++++++++++++++++++++++++++ cpl.lisp | 336 +++++++++++++++ cutting-room-floor.lisp | 93 +++++ errors.lisp | 246 +++++++++++ layout.lisp | 84 ++++ layout.org | 141 +++++++ lex.lisp | 640 ++++++++++++++++++++++++++++ module.lisp | 325 +++++++++++++++ output.lisp | 153 +++++++ package.lisp | 44 ++ parse-c-types.lisp | 507 +++++++++++++++++++++++ posn-stream.lisp | 446 ++++++++++++++++++++ pset.lisp | 427 +++++++++++++++++++ sod.asd | 83 ++++ standard-method-combination.svg | 604 +++++++++++++++++++++++++++ tables.lisp | 78 ++++ utilities.lisp | 362 ++++++++++++++++ 22 files changed, 6418 insertions(+) create mode 100644 .gitignore create mode 100644 .skelrc create mode 100644 NOTES create mode 100644 c-types.lisp create mode 100644 class-builder.lisp create mode 100644 class-defs.lisp create mode 100644 cpl.lisp create mode 100644 cutting-room-floor.lisp create mode 100644 errors.lisp create mode 100644 layout.lisp create mode 100644 layout.org create mode 100644 lex.lisp create mode 100644 module.lisp create mode 100644 output.lisp create mode 100644 package.lisp create mode 100644 parse-c-types.lisp create mode 100644 posn-stream.lisp create mode 100644 pset.lisp create mode 100644 sod.asd create mode 100644 standard-method-combination.svg create mode 100644 tables.lisp create mode 100644 utilities.lisp diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3d894d7 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*~ +*.fasl diff --git a/.skelrc b/.skelrc new file mode 100644 index 0000000..d27ff69 --- /dev/null +++ b/.skelrc @@ -0,0 +1,9 @@ +;;; -*-emacs-lisp-*- + +(setq skel-alist + (append + '((author . "Straylight/Edgeware") + (full-title . "the Simple Object Definition system") + (program . "SOD") + (licence-text . skelrc-gpl)) + skel-alist)) diff --git a/NOTES b/NOTES new file mode 100644 index 0000000..c22622c --- /dev/null +++ b/NOTES @@ -0,0 +1,38 @@ +* 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: diff --git a/c-types.lisp b/c-types.lisp new file mode 100644 index 0000000..acf2db8 --- /dev/null +++ b/c-types.lisp @@ -0,0 +1,603 @@ +;;; -*-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 "~:@" 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 "~:@" 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 -------------------------------------------------- diff --git a/class-builder.lisp b/class-builder.lisp new file mode 100644 index 0000000..8c945ab --- /dev/null +++ b/class-builder.lisp @@ -0,0 +1,485 @@ +;;; -*-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 -------------------------------------------------- diff --git a/class-defs.lisp b/class-defs.lisp new file mode 100644 index 0000000..570322b --- /dev/null +++ b/class-defs.lisp @@ -0,0 +1,712 @@ +;;; -*-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 "~:@" (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 -------------------------------------------------- diff --git a/cpl.lisp b/cpl.lisp new file mode 100644 index 0000000..5a8c7c1 --- /dev/null +++ b/cpl.lisp @@ -0,0 +1,336 @@ +;;; -*-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 -------------------------------------------------- diff --git a/cutting-room-floor.lisp b/cutting-room-floor.lisp new file mode 100644 index 0000000..1781f98 --- /dev/null +++ b/cutting-room-floor.lisp @@ -0,0 +1,93 @@ +;;;-------------------------------------------------------------------------- +;;; 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)) + diff --git a/errors.lisp b/errors.lisp new file mode 100644 index 0000000..4b92fee --- /dev/null +++ b/errors.lisp @@ -0,0 +1,246 @@ +;;; -*-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 -------------------------------------------------- diff --git a/layout.lisp b/layout.lisp new file mode 100644 index 0000000..d077fe2 --- /dev/null +++ b/layout.lisp @@ -0,0 +1,84 @@ +;;; -*-lisp-*- +;;; +;;; Layout for instances and vtables +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Simple Object Definition system. +;;; +;;; SOD is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; SOD is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with SOD; if not, write to the Free Software Foundation, +;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(cl:in-package #:sod) + +;;;-------------------------------------------------------------------------- +;;; Layout objects. + +(defclass effective-slot () + ((slot :initarg :slot :type sod-slot :reader slot-direct-slot) + (initializer :initarg :initializer + :type (or sod-initializer null) + :reader slot-initializer))) + +(defclass islots () + ((class :initarg :class :type sod-class :reader islots-class) + (slots :initarg :slots :type list :reader islots-slots))) + +(defclass ichain () + ((class :initarg :class :type sod-class :reader ichain-class) + (chain :initarg :chain :type sod-class :reader ichain-chain) + (body :initarg :body :type list :reader ichain-body))) + +(defclass ilayout () + ((class :initarg :class :type sod-class :reader ilayout-class) + (ichains :initarg :ichains :type list :reader ilayout-ichains))) + +(defclass effective-method () + ((message :initarg :message :type sod-message :reader method-message) + (class :initarg :class :type sod-class :reader method-class))) + +(defclass method-entry () + ((method :initarg :method + :type effective-method + :reader method-entry-effective-method) + (ichain :initarg :chain :type ichain :reader method-entry-ichain))) + +(defclass vtmsgs () + ((class :initargs :class :type sod-class :reader vtmsgs-class) + (body :initargs :body :type list :reader vtmsgs-body))) + +(defclass class-pointer () + ((metaclass :initarg :metaclass + :type sod-class + :reader class-pointer-metaclass) + (ichain :initarg :chain :type ichain :reader class-pointer-ichain))) + +(defclass base-offset () + ((class :initargs :class :type sod-class :reader base-offset-class) + (ichain :initargs :chain :type ichain :reader base-offset-ichain))) + +(defclass chain-offset () + ((class :initargs :class :type sod-class :reader chain-offset-class) + (ichain :initargs :ichain :type ichain :reader chain-offset-ichain) + (target :initargs :chain :type ichain :reader chain-offset-target))) + +(defclass vtable () + ((class :initargs :class :type sod-class :reader vtable-class) + (ichain :initargs :ichain :type ichain :reader vtable-ichain) + (body :initargs :body :type list :reader vtable-body))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/layout.org b/layout.org new file mode 100644 index 0000000..2bc237a --- /dev/null +++ b/layout.org @@ -0,0 +1,141 @@ +* 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. diff --git a/lex.lisp b/lex.lisp new file mode 100644 index 0000000..46b951d --- /dev/null +++ b/lex.lisp @@ -0,0 +1,640 @@ +;;; -*-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) "") + ((eql :string) "") + ((eql :char) "") + ((eql :id) (format nil "" 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 -------------------------------------------------- diff --git a/module.lisp b/module.lisp new file mode 100644 index 0000000..2575b39 --- /dev/null +++ b/module.lisp @@ -0,0 +1,325 @@ +;;; -*-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 -------------------------------------------------- diff --git a/output.lisp b/output.lisp new file mode 100644 index 0000000..44ec6e2 --- /dev/null +++ b/output.lisp @@ -0,0 +1,153 @@ +;;; -*-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 -------------------------------------------------- diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..92e6a0c --- /dev/null +++ b/package.lisp @@ -0,0 +1,44 @@ +;;; -*-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 -------------------------------------------------- diff --git a/parse-c-types.lisp b/parse-c-types.lisp new file mode 100644 index 0000000..702ae77 --- /dev/null +++ b/parse-c-types.lisp @@ -0,0 +1,507 @@ +;;; -*-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 "" + :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 -------------------------------------------------- diff --git a/posn-stream.lisp b/posn-stream.lisp new file mode 100644 index 0000000..b687ad0 --- /dev/null +++ b/posn-stream.lisp @@ -0,0 +1,446 @@ +;;; -*-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 "~:[~;~:*~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 -------------------------------------------------- diff --git a/pset.lisp b/pset.lisp new file mode 100644 index 0000000..f1c1172 --- /dev/null +++ b/pset.lisp @@ -0,0 +1,427 @@ +;;; -*-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 -------------------------------------------------- diff --git a/sod.asd b/sod.asd new file mode 100644 index 0000000..932b611 --- /dev/null +++ b/sod.asd @@ -0,0 +1,83 @@ +;;; -*-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 -------------------------------------------------- diff --git a/standard-method-combination.svg b/standard-method-combination.svg new file mode 100644 index 0000000..c54f546 --- /dev/null +++ b/standard-method-combination.svg @@ -0,0 +1,604 @@ + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + SOD standard method combination diagram + 2009-09-18 + + + Mark Wooding + + + A diagram showing how the applicable methods are invoked by standard method combination in the SOD object system. + + + Straylight/Edgeware + + + + + Straylight/Edgeware + + + en-GB + + + + + + + + + + + + + + + + + + + Before method + + Most to least specific + call-next-method + + + After method + + Least to most specific + return + + + Return value + + + + + + + + + call-next-method + return + + + + + + . . . + + + + Most to least specific + + + + + + Around method + + + + + + + ‘No next method’ error + + + + + + + + + + + + + + + Primary method + + + + + + diff --git a/tables.lisp b/tables.lisp new file mode 100644 index 0000000..9bd4d5a --- /dev/null +++ b/tables.lisp @@ -0,0 +1,78 @@ +;;; -*-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 -------------------------------------------------- diff --git a/utilities.lisp b/utilities.lisp new file mode 100644 index 0000000..d61bb00 --- /dev/null +++ b/utilities.lisp @@ -0,0 +1,362 @@ +;;; -*-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]