simplify implementation of initial-quot:

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 8aaed4aaaef0f8252369f41e3fa55ddeada9adef..e5ea80bc391cfa8c6d9817f4489cdebf99ef926f 100755 (executable)
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -149,12 +149,22 @@ ERROR: bad-superclass class ;
 : define-boa-check ( class -- )
     dup boa-check-quot "boa-check" set-word-prop ;
 
+: tuple-initial-quots-quot ( class -- quot )
+    all-slots [ initial-quot>> ] filter
+    [
+        [
+            [ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ]
+            [ offset>> , ] bi \ set-slot ,
+        ] each
+    ] [ ] make f like ;
+
 : tuple-prototype ( class -- prototype )
     [ initial-values ] [ over [ ] any? ] [ initial-quots? or ] tri
     [ slots>tuple ] [ 2drop f ] if ;
 
 : define-tuple-prototype ( class -- )
-    dup tuple-prototype "prototype" set-word-prop ;
+    dup [ tuple-prototype ] [ tuple-initial-quots-quot ] bi 2array
+    dup [ ] any? [ drop f ] unless "prototype" set-word-prop ;
 
 : prepare-slots ( slots superclass -- slots' )
     [ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
@@ -176,25 +186,6 @@ ERROR: bad-superclass class ;
 : define-tuple-layout ( class -- )
     dup make-tuple-layout "layout" set-word-prop ;
 
-: define-tuple-constructor ( class -- )
-    {
-        { [ dup initial-quots? ] [ "initial-quots" ] }
-        { [ dup "prototype" word-prop ] [ "prototype" ] }
-        [ f ]
-    } cond "constructor" set-word-prop ;
-
-: define-tuple-initial-quots ( class -- )
-    dup all-slots [ initial-quot>> ] filter
-    [
-        [
-            [ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ]
-            [ offset>> , ] bi \ set-slot ,
-        ] each
-    ] [ ] make "initial-quots-setter" set-word-prop ;
-
-: set-initial-quots ( tuple -- tuple' )
-    dup class "initial-quots-setter" word-prop call( obj -- obj ) ;
-
 : calculate-initial-value ( slot-spec -- value )
     dup initial>> [
         nip
@@ -257,8 +248,6 @@ M: tuple-class update-class
         [ define-tuple-slots ]
         [ define-tuple-predicate ]
         [ define-tuple-prototype ]
-        [ define-tuple-constructor ]
-        [ define-tuple-initial-quots ]
     } cleave ;
 
 : define-new-tuple-class ( class superclass slots -- )
@@ -375,11 +364,11 @@ M: tuple tuple-hashcode
 M: tuple hashcode* tuple-hashcode ;
 
 M: tuple-class new
-    dup "constructor" word-prop {
-        { "initial-quots" [ "prototype" word-prop (clone) set-initial-quots ] }
-        { "prototype" [ "prototype" word-prop (clone) ] }
-        [ drop tuple-layout <tuple> ]
-    } case ;
+    dup "prototype" word-prop [
+        first2 [ (clone) ] dip [ call( obj -- obj ) ] when*
+    ] [
+        tuple-layout <tuple>
+    ] ?if ;
 
 M: tuple-class boa
     [ "boa-check" word-prop [ call ] when* ]