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)) +