[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-serv16704

Modified Files:
	defstruct.lisp 
Log Message:
Added standard function copy-structure.

Date: Mon Mar 29 09:53:14 2004
Author: ffjeld

Index: movitz/losp/muerte/defstruct.lisp
diff -u movitz/losp/muerte/defstruct.lisp:1.4 movitz/losp/muerte/defstruct.lisp:1.5
--- movitz/losp/muerte/defstruct.lisp:1.4	Fri Mar 26 08:57:12 2004
+++ movitz/losp/muerte/defstruct.lisp	Mon Mar 29 09:53:13 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.4 2004/03/26 13:57:12 ffjeld Exp $
+;;;; $Id: defstruct.lisp,v 1.5 2004/03/29 14:53:13 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -19,9 +19,22 @@
 
 (in-package muerte)
 
-(defun structure-object-length (obj)
-  (check-type obj structure-object)
-  (movitz-accessor-u16 obj movitz-struct length))
+(defun structure-object-length (object)
+  (check-type object structure-object)
+  (movitz-accessor-u16 object movitz-struct length))
+
+(defun copy-structure (object)
+  (check-type object structure-object)
+  (let* ((length (structure-object-length object))
+	 (copy (malloc-words length)))
+    (setf (memref copy -6 0 :lisp)
+      (memref object -6 0 :lisp))
+    (setf (memref copy -6 1 :unsigned-byte32)
+      (memref object -6 1 :unsigned-byte32))
+    (dotimes (i length)
+      (setf (structure-ref copy i)
+	(structure-ref object i)))
+    copy))
 
 (defun struct-predicate-prototype (obj)
   "Prototype function for predicates of user-defined struct.