X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/239fa5bd3dff0b38b0cebdd3438311f21c24ba4f..b492babc8de898bd22d638d7c25f24356896a3a9:/src/pset-proto.lisp

diff --git a/src/pset-proto.lisp b/src/pset-proto.lisp
index aafa306..e16e04c 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)) :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
@@ -68,12 +55,36 @@
    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))
@@ -138,6 +149,7 @@
 
   ;; If the caller asks for type T then give him the raw thing.
   (:method (value type (wanted (eql t)))
+    (declare (ignore type))
     value))
 
 ;;;--------------------------------------------------------------------------
@@ -162,7 +174,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 +198,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 +208,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)))
@@ -216,7 +228,10 @@
    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)))
@@ -233,8 +248,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."
@@ -257,7 +271,7 @@
    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))
 
@@ -277,7 +291,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
@@ -293,7 +307,7 @@
 ;;; 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)
@@ -308,14 +322,18 @@
    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))))
+	       (default-slot (,instance ,slot ,slot-names)
+		 ,@body)))))))
 
 ;;;----- That's all, folks --------------------------------------------------