X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/aa14a4cddcb96b681d5c19a2ec8bad382f43b264..6afec9101d5ea87e3df4bda2239ffd05f8154fa6:/src/pset-proto.lisp diff --git a/src/pset-proto.lisp b/src/pset-proto.lisp index d4dc614..f03ec51 100644 --- a/src/pset-proto.lisp +++ b/src/pset-proto.lisp @@ -7,7 +7,7 @@ ;;;----- 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 @@ -38,27 +38,14 @@ (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)) :integer) - (: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 @@ -68,58 +55,30 @@ 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) @@ -134,10 +93,12 @@ ;; 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)) ;;;-------------------------------------------------------------------------- @@ -162,7 +123,7 @@ (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) @@ -186,9 +147,9 @@ (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)))) ;;;-------------------------------------------------------------------------- @@ -196,7 +157,7 @@ (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))) @@ -210,12 +171,16 @@ 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 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. + 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. + + The file location at which the property was defined is returned as a + second value. - If PSET is nil, then return DEFAULT." + 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))) @@ -232,8 +197,7 @@ (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." @@ -255,8 +219,8 @@ 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." + alternative is manufacturing a `property-value' object by hand and + stuffing it into the set." (property-set plist)) @@ -276,7 +240,7 @@ ((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 @@ -291,8 +255,9 @@ ;;;-------------------------------------------------------------------------- ;;; 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) @@ -302,19 +267,25 @@ 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 --------------------------------------------------