X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/ea578bb4b9eb4a03b2eb4ed151e058d699c216ea..2c6153373f927d948a74b283ebb16330af8ee49a:/src/pset-proto.lisp diff --git a/src/pset-proto.lisp b/src/pset-proto.lisp index e98c908..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 @@ -43,9 +43,9 @@ (: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 @@ -55,23 +55,19 @@ 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) @@ -84,52 +80,6 @@ :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 @@ -143,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)) ;;;-------------------------------------------------------------------------- @@ -171,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) @@ -288,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 @@ -303,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) @@ -314,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 --------------------------------------------------