;;;----- 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))
-
-(defun string-to-symbol
- (string &key (package *package*) (swap-case t) (swap-hyphen t))
- "Convert STRING to a symbol in PACKAGE.
-
- Parse off a `PACKAGE:' prefix from STRING if necessary, to identify the
- package; PACKAGE is used if there isn't a prefix. 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.
-
- The portions of the string are modified by `frob-identifier'; the
- arguments SWAP-CASE and SWAP-HYPHEN are passed to `frob-identifier' to
- control this process."
-
- (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 (if (zerop colon) "KEYWORD"
- (frob-identifier (subseq string 0 colon)
- :swap-case swap-case
- :swap-hyphen swap-hyphen)))
- (found (find-package package-name)))
- (unless found
- (error "Unknown package `~A'" package-name))
- (setf package found)))
- (let ((name (frob-identifier (subseq string start)
- :swap-case swap-case
- :swap-hyphen swap-hyphen)))
- (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)))))))))
+(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 property)) (values (p-type raw) (p-value raw)))
+ (:method ((raw cons)) (values (car raw) (cdr 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)))
(export 'coerce-property-value)
(defgeneric coerce-property-value (value type wanted)
;; say it didn't work.
(:method (value type wanted)
(if (eql type wanted) value
- (error "Incorrect type: expected ~A but found ~A" wanted type)))
+ (error "Incorrect type: expected ~(~A~) but found ~(~A~)"
+ wanted type)))
- ;; If the caller asks for type T then give him the raw thing.
+ ;; If the caller asks for type T then give them 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.
+(export 'default-slot-from-property)
(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