From f239856649b38b4fe1f4c7f4932464777e9ba77c Mon Sep 17 00:00:00 2001
From: Joe Groff <joe@victoria.(none)>
Date: Wed, 12 Aug 2009 09:15:46 -0400
Subject: [PATCH] make "struct-class new" work to create a struct with initial
 values set

---
 extra/classes/struct/struct.factor | 19 ++++++++++++++-----
 1 file changed, 14 insertions(+), 5 deletions(-)

diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor
index 130c939214..94d3b625e8 100644
--- a/extra/classes/struct/struct.factor
+++ b/extra/classes/struct/struct.factor
@@ -1,3 +1,4 @@
+! (c)Joe Groff bsd license
 USING: accessors alien alien.c-types byte-arrays classes
 classes.c-types classes.parser classes.tuple
 classes.tuple.parser classes.tuple.private fry kernel
@@ -30,7 +31,7 @@ M: struct >c-ptr
 
 M: struct-class new
     dup "prototype" word-prop
-    [ >c-ptr clone swap memory>struct ] [ <struct> ] if ; inline
+    [ >c-ptr clone swap memory>struct ] [ <struct> ] if* ; inline
 
 ! Struct slot accessors
 
@@ -39,11 +40,13 @@ M: struct-class reader-quot
     [ class>> c-type-getter-boxer ]
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
-M: struct-class writer-quot
-    nip
+: (writer-quot) ( slot -- quot )
     [ class>> c-setter ]
     [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
+M: struct-class writer-quot
+    nip (writer-quot) ;
+
 ! Struct as c-type
 
 : align-offset ( offset class -- offset' )
@@ -82,8 +85,14 @@ M: struct-class heap-size
 ! class definition
 
 : struct-prototype ( class -- prototype )
-    [ heap-size <byte-array> ] [ new [ 2 set-slot ] keep ] bi ; ! [ "struct-slots" word-prop ] tri
-    ! [ [ initial>> ] [ name>> setter-word ] bi over [ execute( struct value -- struct ) ] [ 2drop ] if ] each ;
+    [ heap-size <byte-array> ]
+    [ tuple-layout <tuple> [ 2 set-slot ] keep ]
+    [ "struct-slots" word-prop ] tri
+    [
+        [ initial>> ]
+        [ (writer-quot) ] bi
+        over [ swapd [ call( value struct -- ) ] curry keep ] [ 2drop ] if
+    ] each ;
 
 : (define-struct-class) ( class slots size align -- )
     [