fix constructors for shadowed slots

diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor
index 271e173718cf9e96a7055291611f2fd505c1fb7d..bb63838f5dcdc2692b84d71457b2bf260d166fef 100644 (file)
--- a/basis/constructors/constructors-tests.factor
+++ b/basis/constructors/constructors-tests.factor
@@ -57,3 +57,11 @@ TUPLE: default { a integer initial: 0 } ;
 CONSTRUCTOR: default ( -- obj ) ;
 
 [ 0 ] [ <default> a>> ] unit-test
+
+
+TUPLE: inherit1 a ;
+TUPLE: inherit2 < inherit1 a ;
+
+CONSTRUCTOR: inherit2 ( a -- obj ) ;
+
+[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test

diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor
index d67d07810d618bd771e20ffb868dbfd9d06b53c4..6fd6fa19064337b7d439827921fa5d0047dd70a8 100644 (file)
--- a/basis/constructors/constructors.factor
+++ b/basis/constructors/constructors.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs classes classes.tuple effects.parser
 fry generalizations generic.standard kernel lexer locals macros
-parser sequences slots vocabs words ;
+parser sequences slots vocabs words arrays ;
 IN: constructors
 
 ! An experiment
@@ -25,14 +25,17 @@ IN: constructors
     [ drop define-initializer-generic ]
     [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
 
+: all-slots-assoc ( class -- slots )
+    superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ;
+
 MACRO:: slots>constructor ( class slots -- quot )
-    class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
+    class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
+    class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
     slots length
-    params length
+    default-params length
     '[
-        _ narray slots swap zip 
-        params swap assoc-union
-        values _ firstn class boa
+        _ narray slot-assoc swap zip 
+        default-params swap assoc-union values _ firstn class boa
     ] ;
 
 :: (define-constructor) ( constructor-word class effect def -- word quot )