;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
(symbol name)
(string (intern (frob-identifier name) :keyword))))
-(export 'property-type)
-(defgeneric property-type (value)
- (:documentation "Guess a sensible property type to use for VALUE.")
- (:method ((value symbol)) :symbol)
- (:method ((value integer)) :int)
- (:method ((value string)) :string)
- (:method ((value character)) :char)
- (:method (value) :other))
-
-(export '(property propertyp make-property
- p-name p-value p-type p-key p-seenp))
+(export '(property propertyp p-name p-value p-type p-key p-seenp))
(defstruct (property
(:predicate propertyp)
(:conc-name p-)
- (:constructor make-property
- (name value
- &key (type (property-type value))
- ((:location %loc))
- seenp
- &aux (key (property-key name))
- (location (file-location %loc)))))
+ (:constructor %make-property
+ (name value
+ &key type location seenp
+ &aux (key (property-key name)) (%type type))))
"A simple structure for holding a property in a property set.
The main useful feature is the ability to tick off properties which have
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)
+ (name nil :type (or string symbol) :read-only t)
+ (value nil :type t :read-only t)
+ (%type nil :type symbol :read-only t)
+ (location (file-location nil) :type file-location :read-only t)
+ (key nil :type symbol :read-only t)
(seenp nil :type boolean))
+(define-access-wrapper p-type p-%type :read-only t)
+
+(export 'decode-property)
+(defgeneric decode-property (raw)
+ (:documentation "Decode a RAW value into a TYPE, VALUE pair.")
+ (:method ((raw symbol)) (values :symbol raw))
+ (:method ((raw integer)) (values :int raw))
+ (:method ((raw string)) (values :string raw))
+ (:method ((raw character)) (values :char raw))
+ (:method ((raw property)) (values (p-type raw) (p-value raw)))
+ (:method ((raw cons)) (values (car raw) (cdr raw)))
+ (:method ((raw function)) (values :func raw))
+ (:method ((raw c-type)) (values :type raw)))
+
+(export 'make-property)
+(defun make-property (name raw-value &key type location seenp)
+ (multiple-value-bind (type value)
+ (if type
+ (values type raw-value)
+ (decode-property raw-value))
+ (%make-property name value
+ :type type
+ :location (file-location location)
+ :seenp seenp)))
(defun string-to-symbol
(string &key (package *package*) (swap-case t) (swap-hyphen t))
;; If the caller asks for type T then give him the raw thing.
(:method (value type (wanted (eql t)))
+ (declare (ignore type))
value))
;;;--------------------------------------------------------------------------
(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."
+ If there's no property by that name, return nil."
(values (gethash key (%pset-hash pset))))
(defun pset-store (pset prop)
(with-gensyms (next win key value)
`(with-hash-table-iterator (,next (%pset-hash ,pset))
(macrolet ((,name ()
- (multiple-value-bind (,win ,key ,value) (,next)
- (declare (ignore ,key))
- (and ,win ,value))))
+ `(multiple-value-bind (,',win ,',key ,',value) (,',next)
+ (declare (ignore ,',key))
+ (and ,',win ,',value))))
,@body))))
;;;--------------------------------------------------------------------------
(export 'store-property)
(defun store-property
- (pset name value &key (type (property-type value)) location)
+ (pset name value &key type location)
"Store a property in PSET."
(pset-store pset
(make-property name value :type type :location location)))
Otherwise the value is coerced to the right kind of thing (where possible)
and returned.
- If PSET is nil, then return DEFAULT."
+ The file location at which the property was defined is returned as a
+ second value.
+
+ If PSET is nil, then return DEFAULT and nil."
(let ((prop (and pset (pset-get pset (property-key name)))))
(with-default-error-location ((and prop (p-location prop)))
(p-location prop)))))))
(export 'add-property)
-(defun add-property
- (pset name value &key (type (property-type value)) location)
+(defun add-property (pset name value &key type location)
"Add a property to PSET.
If a property with the same NAME already exists, report an error."
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."
+ stuffing it into the set."
(property-set plist))
((endp list) pset)
(add-property pset (funcall name list) (funcall value list))))))
-(export 'check--unused-properties)
+(export 'check-unused-properties)
(defun check-unused-properties (pset)
"Issue errors about unused properties in PSET."
(when pset
;;; Utility macros.
(defmacro default-slot-from-property
- ((instance slot slot-names)
+ ((instance slot &optional (slot-names t))
(pset property type
&optional (pvar (gensym "PROP-"))
&rest convert-forms)
We initialize SLOT in INSTANCE. In full: if PSET contains a property
called NAME, then convert it to TYPE, bind the value to PVAR and evaluate
CONVERT-FORMS -- these default to just using the property value. If
- there's no property, and the slot is named in SLOT-NAMES and currently
+ there's no property, and DEFAULT-FORMS contains at least one non-
+ declaration form, and the slot is named in SLOT-NAMES and currently
unbound, then evaluate DEFAULT-FORMS and use their value to compute the
slot value."
(once-only (instance slot slot-names pset property type)
- (with-gensyms (floc)
- `(multiple-value-bind (,pvar ,floc)
- (get-property ,pset ,property ,type)
- (if ,floc
- (setf (slot-value ,instance ,slot)
- (with-default-error-location (,floc)
- ,@(or convert-forms `(,pvar))))
- (default-slot (,instance ,slot ,slot-names)
- ,@default-forms))))))
+ (multiple-value-bind (docs decls body)
+ (parse-body default-forms :docp nil)
+ (declare (ignore docs))
+ (with-gensyms (floc)
+ `(multiple-value-bind (,pvar ,floc)
+ (get-property ,pset ,property ,type)
+ ,@decls
+ (if ,floc
+ (setf (slot-value ,instance ,slot)
+ (with-default-error-location (,floc)
+ ,@(or convert-forms `(,pvar))))
+ ,@(and body
+ `((default-slot (,instance ,slot ,slot-names)
+ ,@body)))))))))
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff