* Wrote (but haven't compiled!) C runtime code.
* Fettled runtime header.
* Reformatted class definitions. They don't deserve that much space.
Revamped module protocol to come.
;; Basic definitions.
(defclass qualifiable-c-type (c-type)
- ((qualifiers :initarg :qualifiers
- :type list
- :initform nil
- :accessor c-type-qualifiers))
+ ((qualifiers :initarg :qualifiers :initform nil
+ :type list :accessor c-type-qualifiers))
(:documentation
"Base class for C types which can be qualified."))
;; Basic definitions.
(defclass simple-c-type (qualifiable-c-type)
- ((name :initarg :name
- :type string
- :reader c-type-name))
+ ((name :initarg :name :type string :reader c-type-name))
(:documentation
"C types with simple forms."))
;; Definitions.
(defclass tagged-c-type (qualifiable-c-type)
- ((tag :initarg :tag
- :type string
- :reader c-type-tag))
+ ((tag :initarg :tag :type string :reader c-type-tag))
(:documentation
"C types with tags."))
;; Definitions.
(defclass c-pointer-type (qualifiable-c-type)
- ((subtype :initarg :subtype
- :type c-type
- :reader c-type-subtype))
+ ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
(:documentation
"C pointer 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))
+ ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
+ (dimensions :initarg :dimensions :type list :reader c-array-dimensions))
(:documentation
"C array 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))
+ ((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."))
;;; Classes.
(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
+ ((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)
- (chain-link :initarg :link
- :type (or sod-class null)
+ (chain-link :initarg :link :type (or sod-class null)
:reader sod-class-chain-link)
- (metaclass :initarg :metaclass
- :type sod-class
+ (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
+ (slots :initarg :slots :initform nil
+ :type list :accessor sod-class-slots)
+ (instance-initializers :initarg :instance-initializers :initform nil
: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-initializers :initarg :class-initializers :initform nil
+ :type list :accessor sod-class-class-initializers)
+ (messages :initarg :messages :initform nil
+ :type list :accessor sod-class-messages)
+ (methods :initarg :methods :initform nil
+ :type list :accessor sod-class-methods)
(class-precedence-list :type list :accessor sod-class-precedence-list)
(effective-methods :type list :accessor sod-class-effective-methods)
(vtables :type list :accessor sod-class-vtables)
- (state :initform nil
- :type (member nil :finalized broken)
+ (state :initform nil :type (member nil :finalized broken)
:accessor sod-class-state))
(:documentation
"Classes describe the layout and behaviour of objects.
;;; Slots and initializers.
(defclass sod-slot ()
- ((name :initarg :name
- :type string
- :reader sod-slot-name)
- (location :initarg :location
- :initform (file-location nil)
- :type file-location
- :reader file-location)
- (class :initarg :class
- :type sod-class
- :reader sod-slot-class)
- (type :initarg :type
- :type c-type
- :reader sod-slot-type))
+ ((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.
(sod-slot-name slot)))))
(defclass sod-initializer ()
- ((slot :initarg :slot
- :type sod-slot
- :reader sod-initializer-slot)
- (location :initarg :location
- :initform (file-location nil)
- :type file-location
- :reader file-location)
- (class :initarg :class
- :type sod-class
- :reader sod-initializer-clas)
- (value-kind :initarg :value-kind
- :type keyword
+ ((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
+ (value-form :initarg :value-form :type c-fragment
:reader sod-initializer-value-form))
(:documentation
"Provides an initial value for a slot.
;;; Messages and methods.
(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))
+ ((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-message-name message)))))
(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))
+ ((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.
;;; Classes as C types.
(defclass c-class-type (simple-c-type)
- ((class :initarg :class
- :type (or null sod-class)
- :accessor c-type-class))
+ ((class :initarg :class :type (or null sod-class) :accessor c-type-class))
(:documentation
"A SOD class, as a C type.
(defclass effective-slot ()
((class :initarg :class :type sod-slot :reader effective-slot-class)
(slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
- (initializer :initarg :initializer
- :type (or sod-initializer null)
+ (initializer :initarg :initializer :type (or sod-initializer null)
:reader effective-slot-initializer))
(:documentation
"Describes a slot and how it's meant to be initialized.
(defclass vtable-pointer ()
((class :initarg :class :type sod-class :reader vtable-pointer-class)
- (chain-head :initarg :chain-head
- :type sod-class
+ (chain-head :initarg :chain-head :type sod-class
:reader vtable-pointer-chain-head))
(:documentation
"A pointer to the vtable for CLASS corresponding to a particular CHAIN."))
;;; Effective methods.
(defclass effective-method ()
- ((message :initarg :message
- :type sod-message
+ ((message :initarg :message :type sod-message
:reader effective-method-message)
- (class :initarg :class
- :type sod-class
- :reader effective-method-class))
+ (class :initarg :class :type sod-class :reader effective-method-class))
(:documentation
"The effective method invoked by sending MESSAGE to an instance of CLASS.
;;; method-entry
(defclass method-entry ()
- ((method :initarg :method
- :type effective-method
+ ((method :initarg :method :type effective-method
:reader method-entry-effective-method)
(chain-head :initarg :chain-head
:type sod-class
(defclass vtmsgs ()
((class :initarg :class :type sod-class :reader vtmsgs-class)
(subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
- (chain-head :initarg :chain-head
- :type sod-class
+ (chain-head :initarg :chain-head :type sod-class
:reader vtmsgs-chain-head)
(entries :initarg :entries :type list :reader vtmsgs-entries))
(:documentation
;;; class-pointer
(defclass class-pointer ()
- ((class :initarg :class
- :type sod-class
- :reader class-pointer-class)
- (chain-head :initarg :chain-head
- :type sod-class
+ ((class :initarg :class :type sod-class :reader class-pointer-class)
+ (chain-head :initarg :chain-head :type sod-class
:reader class-pointer-chain-head)
- (metaclass :initarg :metaclass
- :type sod-class
+ (metaclass :initarg :metaclass :type sod-class
:reader class-pointer-metaclass)
- (meta-chain-head :initarg :meta-chain-head
- :type sod-class
+ (meta-chain-head :initarg :meta-chain-head :type sod-class
:reader class-pointer-meta-chain-head))
(:documentation
"Represents a pointer to a class object for the instance's class.
(defclass base-offset ()
((class :initarg :class :type sod-class :reader base-offset-class)
- (chain-head :initarg :chain-head
- :type sod-class
+ (chain-head :initarg :chain-head :type sod-class
:reader base-offset-chain-head))
(:documentation
"The offset of this chain to the ilayout base.
(defclass chain-offset ()
((class :initarg :class :type sod-class :reader chain-offset-class)
- (chain-head :initarg :chain-head
- :type sod-class
+ (chain-head :initarg :chain-head :type sod-class
:reader chain-offset-chain-head)
- (target-head :initarg :target-head
- :type sod-class
+ (target-head :initarg :target-head :type sod-class
:reader chain-offset-target-head))
(:documentation
"The offset from the CHAIN-HEAD ichain to the TARGET-HEAD ichain."))
(defclass vtable ()
((class :initarg :class :type sod-class :reader vtable-class)
- (chain-head :initarg :chain-head
- :type sod-class
+ (chain-head :initarg :chain-head :type sod-class
:reader vtable-chain-head)
(body :initarg :body :type list :reader vtable-body))
(:documentation
(defclass temporary-function (temporary-name) ())
(defclass temporary-variable (temporary-name)
- ((in-use-p :initarg :in-use-p
- :initform nil
- :type boolean
- :accessor var-in-use-p)))
+ ((in-use-p :initarg :in-use-p :initform nil
+ :type boolean :accessor var-in-use-p)))
(defmethod var-in-use-p ((var t))
"Non-temporary variables are always in use."
(defclass basic-codegen ()
((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
(insts :initarg :insts :initform nil :type list :accessor codegen-insts)
- (temp-index :initarg :temp-index
- :initform 0
- :type fixnum
- :accessor codegen-temp-index))
+ (temp-index :initarg :temp-index :initform 0
+ :type fixnum :accessor codegen-temp-index))
(:documentation
"Base class for code generator state.
pointer."))
(defclass simple-effective-method (basic-effective-method)
- ((primary-methods :initarg :primary-methods
- :initform nil
- :type list
- :reader effective-method-primary-methods))
+ ((primary-methods :initarg :primary-methods :initform nil
+ :type list :reader effective-method-primary-methods))
(:documentation
"Effective method counterpart to SIMPLE-MESSAGE."))
;; 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))
+ ((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.
"struct" "union" "enum"))
(defclass sod-lexer (lexer)
- ((keywords :initarg :keywords
- :initform *sod-keywords*
- :type hash-table
- :reader lexer-keywords))
+ ((keywords :initarg :keywords :initform *sod-keywords*
+ :type hash-table :reader lexer-keywords))
(:documentation
"Lexical analyser for the SOD lanuage.
;;; C fragments.
(defclass c-fragment ()
- ((location :initarg :location
- :type file-location
+ ((location :initarg :location :type file-location
:accessor c-fragment-location)
- (text :initarg :text
- :type string
- :accessor c-fragment-text))
+ (text :initarg :text :type string :accessor c-fragment-text))
(:documentation
"Represents a fragment of C code to be written to an output file.
;;; Direct method classes.
(defclass basic-direct-method (sod-method)
- ((role :initarg :role
- :type symbol
- :reader sod-method-role)
- (function-type :type c-function-type
- :reader sod-method-function-type))
+ ((role :initarg :role :type symbol :reader sod-method-role)
+ (function-type :type c-function-type :reader sod-method-function-type))
(:documentation
"Base class for built-in direct method classes.
as part of the method delegation protocol."))
(defclass basic-effective-method (effective-method)
- ((around-methods :initarg :around-methods
- :initform nil
- :type list
- :reader effective-method-around-methods)
- (before-methods :initarg :before-methods
- :initform nil
- :type list
- :reader effective-method-before-methods)
- (after-methods :initarg :after-methods
- :initform nil
- :type list
- :reader effective-method-after-methods)
+ ((around-methods :initarg :around-methods :initform nil
+ :type list :reader effective-method-around-methods)
+ (before-methods :initarg :before-methods :initform nil
+ :type list :reader effective-method-before-methods)
+ (after-methods :initarg :after-methods :initform nil
+ :type list :reader effective-method-after-methods)
(basic-argument-names :type list
:reader effective-method-basic-argument-names)
(functions :type list :reader effective-method-functions))
;;; Sequencing machinery.
(defclass sequencer-item ()
- ((name :initarg :name
- :reader sequencer-item-name)
- (functions :initarg :functions
- :initform nil
- :type list
- :accessor sequencer-item-functions))
+ ((name :initarg :name :reader sequencer-item-name)
+ (functions :initarg :functions :initform nil
+ :type list :accessor sequencer-item-functions))
(:documentation
"Represents a distinct item to be sequenced by a SEQUENCER.
(prin1 (sequencer-item-name item) stream)))
(defclass sequencer ()
- ((constraints :initarg :constraints
- :initform nil
- :type list
- :accessor sequencer-constraints)
+ ((constraints :initarg :constraints :initform nil
+ :type list :accessor sequencer-constraints)
(table :initform (make-hash-table :test #'equal)
:reader sequencer-table))
(:documentation
;;; Locations.
(defclass file-location ()
- ((pathname :initarg :pathname
- :type (or pathname null)
+ ((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)
+ (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.
;; Base classes for proxy streams.
(defclass proxy-stream (fundamental-stream)
- ((ustream :initarg :stream
- :type stream
+ ((ustream :initarg :stream :type stream
:reader position-aware-stream-underlying-stream))
(:documentation
"Base class for proxy streams.
;; 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))
+ ((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.
(cl:in-package #:sod)
;;;--------------------------------------------------------------------------
-;;; Basic definitions.
+;;; Property representation.
(defun property-key (name)
"Convert NAME into a keyword.
(string (intern (substitute #\- #\_ (frob-case name)) :keyword))))
(defun property-type (value)
- "Guess the right property type to use for VALUE."
+ "Guess a sensible property type to use for VALUE."
(typecase value
(symbol :symbol)
(integer :integer)
(:conc-name p-)
(:constructor make-property
(name value
- &key (type (property-type value)) location seenp
- &aux (key (property-key name)))))
+ &key (type (property-type value))
+ ((:location %loc))
+ seenp
+ &aux (key (property-key name))
+ (location (file-location %loc)))))
"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))
+ been used, so that we can complain about unrecognized properties.
+
+ An explicit type tag is necessary because we need to be able to talk
+ distinctly about identifiers, strings and symbols, and we've only got two
+ obvious Lisp types to play with. Sad, but true."
+
+ (name nil :type (or string symbol))
(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.
(defgeneric coerce-property-value (value type wanted)
(:documentation
- "Convert VALUE, a property of type TYPE, to be of type WANTED.")
+ "Convert VALUE, a property of type TYPE, to be of type WANTED.
+
+ It's sensible to add additional methods to this function, but there are
+ all the ones we need.")
;; If TYPE matches WANTED, we'll assume that VALUE already has the right
;; form. Otherwise, if nothing else matched, then I guess we'll have to
(:method ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
(substitute #\_ #\- (frob-case (symbol-name value)))))
+;;;--------------------------------------------------------------------------
+;;; Property set representation.
+;;;
+;;; There shouldn't be any code elsewhere which depends on the
+;;; representation. It's changed before; it may change again.
+
+(defstruct (pset (:constructor %make-pset)
+ (:conc-name %pset-))
+ "A property set.
+
+ Wrapped up in a structure so that we can define a print function."
+ (hash (make-hash-table) :type hash-table))
+
+(declaim (inline make-pset pset-get pset-store pset-map))
+
+(defun make-pset ()
+ "Constructor for property sets."
+ (%make-pset))
+
+(defun pset-get (pset key)
+ "Look KEY up in PSET and return what we find.
+
+ If there's no property by that name, return NIL."
+ (values (gethash key (%pset-hash pset))))
+
+(defun pset-store (pset prop)
+ "Store property PROP in PSET.
+
+ Overwrite or replace any previous property with the same name. Mutates
+ the property set."
+ (setf (gethash (p-key prop) (%pset-hash pset)) prop))
+
+(defun pset-map (func pset)
+ "Call FUNC for each property in PSET."
+ (maphash (lambda (key value) (declare (ignore key)) (funcall func value))
+ (%pset-hash pset)))
+
+;;;--------------------------------------------------------------------------
+;;; `Cooked' property set operations.
+
+(defun store-property
+ (pset name value &key (type (property-type value)) location)
+ "Store a property in PSET."
+ (%pset-store pset
+ (make-property name value :type type :location location)))
+
(defun get-property (pset name type &optional default)
"Fetch a property from a property set.
The value returned depends on the TYPE argument provided. If you pass NIL
then you get back the entire PROPERTY object. If you pass T, then you get
whatever was left in the property set, uninterpreted. Otherwise the value
- is coerced to the right kind of thing (where possible) and returned."
+ is coerced to the right kind of thing (where possible) and returned.
- (let ((prop (find name pset :key #'p-key)))
+ If PSET is nil, then return DEFAULT."
+
+ (let ((prop (and pset (%pset-get pset (property-key name)))))
(with-default-error-location ((and prop (p-location prop)))
(cond ((not prop)
(values default nil))
type)
(p-location prop)))))))
+(defun add-property
+ (pset name value &key (type (property-type value)) location)
+ "Add a property to PSET.
+
+ If a property with the same NAME already exists, report an error."
+
+ (with-default-error-location (location)
+ (let ((existing (get-property pset name nil)))
+ (when existing
+ (error "Property ~S already defined~@[ at ~A~]"
+ name (p-location existing)))
+ (store-property pset name value :type type :location location))))
+
+(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 ((pset (%make-pset))
+ (plist plist (cddr plist)))
+ ((endp plist) pset)
+ (add-property pset (car plist) (cadr plist))))
+
+(defmethod print-object ((pset pset) stream)
+ (print-unreadable-object (pset stream :type t)
+ (pprint-logical-block (stream nil)
+ (let ((firstp t))
+ (%pset-map (lambda (prop)
+ (cond (firstp (setf firstp nil))
+ (t (write-char #\space stream)
+ (pprint-newline :linear stream)))
+ (format stream "~:@<~S ~@_~S ~@_~S~:>"
+ (p-name prop) (p-type prop) (p-value prop)))
+ pset)))))
+
(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)))))
+ (%pset-map (lambda (prop)
+ (unless (p-seenp prop)
+ (cerror*-with-location (p-location prop)
+ "Unknown property `~A'"
+ (p-name prop))))
+ pset))
;;;--------------------------------------------------------------------------
-;;; Property set parsing.
+;;; Expression parser.
(defun parse-expression (lexer)
"Parse an expression from the LEXER.
(null (cdr valstack))))
(values (cdar valstack) (caar valstack)))
(continue ()
- :report "Return an invalid value and continue"
+ :report "Return an invalid value and continue."
(values nil :invalid)))))
+;;;--------------------------------------------------------------------------
+;;; Property set parsing.
+
+(defun parse-property (lexer pset)
+ "Parse a single property from LEXER; add it to PSET."
+ (let ((name (require-token lexer :id)))
+ (require-token lexer #\=)
+ (multiple-value-bind (value type) (parse-expression lexer)
+ (unless (eq type :invalid)
+ (add-property pset name value :type type :location lexer)))))
+
(defun parse-property-set (lexer)
"Parse a property set from LEXER.
and GET-PROPERTY will perfectly happily report defaults for all requested
properties."
- (let ((pset nil))
- (when (require-token lexer #\[ :errorp nil)
+ (when (require-token lexer #\[ :errorp nil)
+ (let ((pset (make-pset)))
(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))))
+ (parse-property lexer pset)
(unless (require-token lexer #\, :errorp nil)
(return)))
(require-token lexer #\])
- (nreverse pset))))
+ pset)))
;;;--------------------------------------------------------------------------
;;; Testing cruft.
#+test
-(with-input-from-string (raw "[role = before, integer = 42 * (3 - 1]")
+(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)
--- /dev/null
+/* -*-c-*-
+ *
+ * Runtime support for the Sensible Object Design
+ *
+ * (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.
+ */
+
+/*----- Header files ------------------------------------------------------*/
+
+#include <sod.h>
+
+/*----- Main code ---------------------------------------------------------*/
+
+/* --- @find_chain@ --- *
+ *
+ * Arguments: @const SodClass *sub, *super@ = pointers to two classes
+ *
+ * Returns: If @sub@ is a subclass of @super@, then a pointer to @sub@'s
+ * chain entry describing @super@'s chain; otherwise null.
+ */
+
+static const struct sod_chain *find_chain(const SodClass *sub,
+ const SodClass *super)
+{
+ const SodClass *head = super->cls.head;
+ const struct sod_chain *chain, *limit;
+
+ /* Slightly fancy footwork. Each class carries a table describing its
+ * constituent chains, and each chain has a vector of the classes in that
+ * chain, with the head (least specific) first. Chains are always
+ * non-empty.
+ *
+ * Another useful bit of information in the class is its level, i.e., its
+ * index in its own chain vector. This is invariant because the chains are
+ * linear.
+ *
+ * This suggests the following algorithm. Search @sub@'s chains for one
+ * headed by @super@'s chain head. If we find one, check that the chain's
+ * class vector is long enough, and look at the entry corresponding to
+ * @super@'s level. If it matches @super@ then @sub@ is indeed a subclass
+ * and we're done. Otherwise it isn't, and we lose. We also lose if no
+ * matching chain is found.
+ */
+ for (chain = sub->cls.chains, lim = chain + sub->cls.n_chains;
+ chain < limit; chain++) {
+ if (chain->classes[0] != head)
+ continue;
+ if (super->cls.level < chain->n_classes &&
+ chain->classes[super->cls.level] == super)
+ return (chain);
+ break;
+ }
+ return (0);
+}
+
+/* --- @sod_subclassp@ --- *
+ *
+ * Arguments: @const SodClass *sub, *super@ = pointers to two classes
+ *
+ * Returns: Nonzero if @sub@ is a subclass of @super@.
+ */
+
+int sod_subclassp(const SodClass *c, const SodClass *d)
+ { return (!!find_chain(c, d)); }
+
+/* --- @sod_convert@ --- *
+ *
+ * Arguments: @const SodClass *cls@ = desired class object
+ * @const void *obj@ = pointer to instance
+ *
+ * Returns: Pointer to appropriate ichain of object, or null if the
+ * instance isn't of the specified class.
+ *
+ * Use: General down/cross-casting function.
+ *
+ * Upcasts can be performed efficiently using the automatically
+ * generated macros. In particular, upcasts with a chain are
+ * trivial; cross-chain upcasts require information from vtables
+ * but are fairly fast. This function is rather slower, but is
+ * much more general.
+ *
+ * Suppose we have an instance of a class C, referred to by a
+ * pointer to an instance of one of C's superclasses S. If S'
+ * is some other superclass of C then this function will return
+ * a pointer to C suitable for use as an instance of S'. If S'
+ * is not a superclass of C, then the function returns null.
+ * (If the pointer doesn't point to an instance of some class
+ * then the behaviour is undefined.) Note that you don't need
+ * to know what C or S actually are.
+ */
+
+void *sod_convert(const SodClass *cls, void *p)
+{
+ const struct sod_instance *inst = p;
+ const struct sod_vtable *vt = inst->_vt;
+ const SodClass *realcls = vt->_class;
+ const struct sod_chain *chain = find_chain(realcls, cls);
+
+ if (!chain)
+ return (0);
+ return ((char *)p - vt->_base + chain->off_ichain);
+}
+
+/*----- That's all, folks -------------------------------------------------*/
((struct cls##__ilayout *) \
((char *)(p) - offsetof(struct cls##__ilayout, chead)))
+/*----- Utility macros ----------------------------------------------------*/
+
+/* --- @SOD_CLASSOF@ --- *
+ *
+ * Arguments: @p@ = pointer to an instance chain
+ *
+ * Returns: A pointer to the instance's class, as a const SodClass.
+ */
+
+#define SOD_CLASSOF(p) ((const SodClass *)(p)->_vt->_class)
+
/*----- Functions provided ------------------------------------------------*/
+/* --- @sod_subclassp@ --- *
+ *
+ * Arguments: @const SodClass *c, *d@ = pointers to two classes
+ *
+ * Returns: Nonzero if @c@ is a subclass of @d@.
+ */
+
+extern int sod_subclassp(const SodClass */*c*/, const SodClass */*d*/);
+
/* --- @sod_convert@ --- *
*
* Arguments: @const SodClass *cls@ = desired class object
~mdw / sod / commitdiff