[movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv11359

Modified Files:
	los-closette.lisp 
Log Message:
Improved make-structure to observe initargs and initforms properly.

Date: Thu Sep 23 11:11:26 2004
Author: ffjeld

Index: movitz/losp/muerte/los-closette.lisp
diff -u movitz/losp/muerte/los-closette.lisp:1.19 movitz/losp/muerte/los-closette.lisp:1.20
--- movitz/losp/muerte/los-closette.lisp:1.19	Thu Sep 23 09:21:38 2004
+++ movitz/losp/muerte/los-closette.lisp	Thu Sep 23 11:11:26 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Tue Jul 23 14:29:10 2002
 ;;;;                
-;;;; $Id: los-closette.lisp,v 1.19 2004/09/23 07:21:38 ffjeld Exp $
+;;;; $Id: los-closette.lisp,v 1.20 2004/09/23 09:11:26 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -1101,10 +1101,21 @@
 
 (defclass structure-slot-definition (slot-definition)
   ((name
-    :initarg :name)
+    :initarg :name
+    :reader structure-slot-name)
    (location
     :initarg :location
-    :reader structure-slot-location)))
+    :reader structure-slot-location)
+   (initarg
+    :initarg :initarg
+    :reader structure-slot-initarg)
+   (initform
+    :initarg :initform
+    :reader structure-slot-initform)
+   (type
+    :initarg type)
+   (readonly
+    :initarg :readonly)))
 
 (defclass structure-object (t) () (:metaclass structure-class))
 
@@ -1137,14 +1148,15 @@
 			     (:jmp 'init-loop)
 			     init-done)))
 		     (do-it))))
-      (do ((p init-args (cddr p)))
-	  ((endp p))
-	(let ((slot-position (position (car p) slots :key #'fifth)))
-	  (assert slot-position ()
-	    "Illegal init-arg ~S for ~S." (car p) class)
-	  (setf (structure-ref struct slot-position) (cadr p))))
+      (dolist (slot slots)
+	(let ((init-value (getf init-args (structure-slot-initarg slot) 'no-initarg)))
+	  (if (not (eq init-value 'no-initarg))
+	      (setf (structure-ref struct (structure-slot-location slot)) init-value)
+	    (let ((initform (structure-slot-initform slot)))
+	      (when initform
+		(setf (structure-ref struct (structure-slot-location slot))
+		  (eval initform)))))))
       struct)))
-
 ;;;;