X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/1818107e8198734df843841a51bca3713bd37596..2a8a526029dbdcfd8bd5a4c40bc5c63ed2a44cf5:/src/pset-proto.lisp

diff --git a/src/pset-proto.lisp b/src/pset-proto.lisp
index 332bcef..0238f41 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
@@ -55,13 +55,13 @@
    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)
+(define-access-wrapper p-type p-%type :read-only t)
 
 (export 'decode-property)
 (defgeneric decode-property (raw)
@@ -72,7 +72,8 @@
   (: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 function)) (values :func raw))
+  (:method ((raw c-type)) (values :type raw)))
 
 (export 'make-property)
 (defun make-property (name raw-value &key type location seenp)
@@ -305,6 +306,7 @@
 ;;;--------------------------------------------------------------------------
 ;;; Utility macros.
 
+(export 'default-slot-from-property)
 (defmacro default-slot-from-property
     ((instance slot &optional (slot-names t))
      (pset property type
@@ -316,19 +318,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 --------------------------------------------------