;;;----- 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
(:predicate propertyp)
(:conc-name p-)
(:constructor %make-property
- (name value
- &key type location seenp
- &aux (key (property-key name)))))
+ (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 cons)) (values (car raw) (cdr raw))))
(export 'make-property)
(defun make-property (name raw-value &key type location seenp)
:location (file-location location)
:seenp seenp)))
-(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)))))))))
-
(export 'coerce-property-value)
(defgeneric coerce-property-value (value type wanted)
(:documentation
;; 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)
((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