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

[Frode Vatvedt Fjeld]

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

Modified Files:
	defstruct.lisp 
Log Message:
More defstruct fixes. Structs now have a class slot, not a name
slot. And, let's allow a :superclass option for defstruct.

Date: Tue Jul 27 02:19:09 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.11 movitz/losp/muerte/defstruct.lisp:1.12
--- movitz/losp/muerte/defstruct.lisp:1.11	Fri Jul 23 18:30:44 2004
+++ movitz/losp/muerte/defstruct.lisp	Tue Jul 27 02:19:09 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Mon Jan 22 13:10:59 2001
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: defstruct.lisp,v 1.11 2004/07/24 01:30:44 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.12 2004/07/27 09:19:09 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -23,6 +23,9 @@
   (check-type object structure-object)
   (memref object -4 0 :unsigned-byte14))
 
+(defun structure-object-class (x)
+  (memref x -6 1 :lisp))
+
 (defun copy-structure (object)
   ;; (check-type object structure-object)
   (let* ((length (structure-object-length object))
@@ -167,6 +170,7 @@
 	       ((cons symbol (cons * null))
 		(let ((parameter (second option)))
 		  (ecase (car option)
+		    (:superclass (push parameter (getf collector :superclass)))
 		    (:conc-name (push (string (or parameter ""))
 				      (getf collector :conc-name)))
 		    (:constructor (push parameter (getf collector :constructor)))
@@ -194,6 +198,7 @@
 			  (assert (<= 1 (length (getf options ,option)) ,max-values) ()
 			    "Option ~S given too many times." ,option))))
 	  (default (:type 1) 'class-struct)
+	  (default (:superclass 1) 'structure-object)
 	  (default (:named 1) nil)
 	  (default (:conc-name 1)
 	      (concatenate 'string (string struct-name) (string #\-)))
@@ -202,9 +207,15 @@
 	  (default (:predicate 1)
 	      (intern (concatenate 'string (string struct-name) (string '-p)))))
 	(let* ((struct-type (first (getf options :type)))
+	       (superclass (first (getf options :superclass)))
 	       (struct-named (first (getf options :named)))
 	       (conc-name (first (getf options :conc-name)))
 	       (predicate-name (first (getf options :predicate)))
+	       (standard-name-and-options (if (not (consp name-and-options))
+					      name-and-options
+					    (remove :superclass name-and-options
+						    :key (lambda (x)
+							   (when (consp x) (car x))))))
 	       (canonical-slot-descriptions
 		(mapcar #'(lambda (d)
 			    "(<slot-name> <init-form> <type> <read-only-p> <initarg>)"
@@ -224,9 +235,9 @@
 		  (setf (gethash '(:translate-when :eval ,struct-name :cl :muerte.cl)
 				 (movitz::image-struct-slot-descriptions movitz:*image*))
 		    '(:translate-when :eval ,slot-descriptions :cl :muerte.cl))
-		  (defstruct (:translate-when :eval ,name-and-options :cl :muerte.cl)
+		  (defstruct (:translate-when :eval ,standard-name-and-options :cl :muerte.cl)
 		    . (:translate-when :eval ,slot-names :cl :muerte.cl)))
-		(defclass ,struct-name (structure-object) ()
+		(defclass ,struct-name (,superclass) ()
 			  (:metaclass structure-class)
 			  (:slots ,(loop for (name) in canonical-slot-descriptions
 				       as location upfrom 0
@@ -334,6 +345,5 @@
 		',struct-name))
 	    ))))))
 
-;;;(defun structure-object-name (x)
-;;;  (movitz-accessor x movitz-struct name))
+