From eec283354e56de31cb383b3e98a9cc02cecdea7b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 24 Sep 2009 11:32:25 -0500
Subject: [PATCH] clean up classes.struct code. don't set a bunch of redundant
 word-props on struct class words

---
 basis/classes/struct/struct.factor | 64 ++++++++++++------------------
 1 file changed, 26 insertions(+), 38 deletions(-)

diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index 63f2ad282e..1aed4a1e7a 100755
--- a/basis/classes/struct/struct.factor
+++ b/basis/classes/struct/struct.factor
@@ -27,9 +27,8 @@ PREDICATE: struct-class < tuple-class
 
 M: struct-class valid-superclass? drop f ;
 
-GENERIC: struct-slots ( struct-class -- slots )
-
-M: struct-class struct-slots "struct-slots" word-prop ;
+: struct-slots ( struct-class -- slots )
+    "c-type" word-prop fields>> ;
 
 ! struct allocation
 
@@ -175,16 +174,15 @@ M: struct-c-type c-struct? drop t ;
     [ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
     define-inline-method ;
 
-: c-type-for-class ( class -- c-type )
-    struct-c-type new swap {
-        [ drop byte-array >>class ]
-        [ >>boxed-class ]
-        [ struct-slots >>fields ]
-        [ "struct-size" word-prop >>size ]
-        [ "struct-align" word-prop >>align ]
-        [ (unboxer-quot) >>unboxer-quot ]
-        [ (boxer-quot) >>boxer-quot ]
-    } cleave ;
+:: c-type-for-class ( class slots size align -- c-type )
+    struct-c-type new
+        byte-array >>class
+        class >>boxed-class
+        slots >>fields
+        size >>size
+        align >>align
+        class (unboxer-quot) >>unboxer-quot
+        class (boxer-quot)   >>boxer-quot ;
     
 : align-offset ( offset class -- offset' )
     c-type-align align ;
@@ -202,7 +200,7 @@ M: struct-c-type c-struct? drop t ;
     [ type>> c-type-align ] [ max ] map-reduce ;
 PRIVATE>
 
-M: struct byte-length class "struct-size" word-prop ; foldable
+M: struct byte-length class "c-type" word-prop size>> ; foldable
 
 ! class definition
 
@@ -221,7 +219,7 @@ M: struct binary-zero?
 
 : make-struct-prototype ( class -- prototype )
     dup struct-needs-prototype? [
-        [ "struct-size" word-prop <byte-array> ]
+        [ "c-type" word-prop size>> <byte-array> ]
         [ memory>struct ]
         [ struct-slots ] tri
         [
@@ -236,35 +234,25 @@ M: struct binary-zero?
     [ (define-clone-method) ]
     bi ;
 
-: (struct-word-props) ( class slots size align -- )
-    [
-        [ "struct-slots" set-word-prop ]
-        [ define-accessors ] 2bi
-    ]
-    [ "struct-size" set-word-prop ]
-    [ "struct-align" set-word-prop ] tri-curry*
-    [ tri ] 3curry
-    [ dup make-struct-prototype "prototype" set-word-prop ]
-    [ (struct-methods) ] tri ;
-
 : check-struct-slots ( slots -- )
     [ type>> c-type drop ] each ;
 
 : redefine-struct-tuple-class ( class -- )
     [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
 
-: (define-struct-class) ( class slots offsets-quot -- )
-    [ 
-        empty?
-        [ struct-must-have-slots ]
-        [ redefine-struct-tuple-class ] if
-    ]
-    swap '[
-        make-slots dup
-        [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
-        (struct-word-props)
-    ]
-    [ drop [ c-type-for-class ] keep typedef ] 2tri ; inline
+:: (define-struct-class) ( class slots offsets-quot -- )
+    slots empty? [ struct-must-have-slots ] when
+    class redefine-struct-tuple-class
+    slots make-slots dup check-struct-slots :> slot-specs
+    slot-specs offsets-quot call :> size
+    slot-specs struct-align :> alignment
+
+    class  slot-specs  size alignment align  alignment  c-type-for-class :> c-type
+
+    c-type class typedef
+    class slot-specs define-accessors
+    class dup make-struct-prototype "prototype" set-word-prop
+    class (struct-methods) ; inline
 PRIVATE>
 
 : define-struct-class ( class slots -- )