typed: only unbox final classes. Fixes bug reported by littledan

basis/stack-checker/dependencies/dependencies.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors classes.algebra fry generic kernel math
-namespaces sequences words sets combinators.short-circuit ;
+namespaces sequences words sets combinators.short-circuit
+classes.tuple ;
 FROM: classes.tuple.private => tuple-layout ;
 IN: stack-checker.dependencies
 
@@ -122,6 +123,15 @@ TUPLE: depends-on-flushable word ;
 M: depends-on-flushable satisfied?
     word>> flushable? ;
 
+TUPLE: depends-on-final class ;
+
+: depends-on-final ( word -- )
+    [ depends-on-conditionally ]
+    [ \ depends-on-final add-conditional-dependency ] bi ;
+
+M: depends-on-final satisfied?
+    class>> final-class? ;
+
 : init-dependencies ( -- )
     H{ } clone dependencies set
     H{ } clone generic-dependencies set

basis/typed/typed-tests.factor

@@ -14,8 +14,8 @@ TYPED: fix+ ( a: fixnum b: fixnum -- c: fixnum )
 most-positive-fixnum neg 1 - 1quotation
 [ most-positive-fixnum 1 fix+ ] unit-test
 
-TUPLE: tweedle-dee ;
+TUPLE: tweedle-dee ; final
-TUPLE: tweedle-dum ;
+TUPLE: tweedle-dum ; final
 
 TYPED: dee ( x: tweedle-dee -- y )
     drop \ tweedle-dee ;
@@ -39,11 +39,11 @@ TYPED:: f+locals ( a: float b: float -- c: float )
 
 TUPLE: unboxable
     { x fixnum read-only }
-    { y fixnum read-only } ;
+    { y fixnum read-only } ; final
 
 TUPLE: unboxable2
     { u unboxable read-only }
-    { xy fixnum read-only } ;
+    { xy fixnum read-only } ; final
 
 TYPED: unboxy ( in: unboxable -- out: unboxable2 )
     dup [ x>> ] [ y>> ] bi - unboxable2 boa ;
@@ -63,7 +63,7 @@ IN: typed.tests
 TUPLE: unboxable
     { x fixnum read-only }
     { y fixnum read-only }
-    { z float read-only } ;
+    { z float read-only } ; final
 """ eval( -- )
 
 """
@@ -79,13 +79,15 @@ TYPED: no-inputs ( -- out: integer )
 [ 1 ] [ no-inputs ] unit-test
 
 TUPLE: unboxable3
-    { x read-only } ;
+    { x read-only } ; final
 
 TYPED: no-inputs-unboxable-output ( -- out: unboxable3 )
     T{ unboxable3 } ;
 
 [ T{ unboxable3 } ] [ no-inputs-unboxable-output ] unit-test
 
+[ f ] [ no-inputs-unboxable-output no-inputs-unboxable-output eq? ] unit-test
+
 SYMBOL: buh
 
 TYPED: no-outputs ( x: integer -- )
@@ -98,10 +100,25 @@ TYPED: no-outputs-unboxable-input ( x: unboxable3 -- )
 
 [ T{ unboxable3 } ] [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test
 
-! Reported by littledan
+[ f ] [
-TUPLE: superclass x ;
+    T{ unboxable3 } no-outputs-unboxable-input buh get
-TUPLE: subclass < superclass y ;
+    T{ unboxable3 } no-outputs-unboxable-input buh get
+    eq?
+] unit-test
 
-TYPED: unbox-fail ( superclass: a -- ? ) subclass? ;
+! Reported by littledan
+TUPLE: superclass { x read-only } ;
+TUPLE: subclass < superclass { y read-only } ; final
+
+TYPED: unbox-fail ( a: superclass -- ? ) subclass? ;
 
 [ t ] [ subclass new unbox-fail ] unit-test
+
+! If a final class becomes non-final, typed words need to be recompiled
+TYPED: recompile-fail ( a: subclass -- ? ) buh get eq? ;
+
+[ f ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
+
+[ ] [ "IN: typed.tests TUPLE: subclass < superclass { y read-only } ;" eval( -- ) ] unit-test
+
+[ t ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test

basis/typed/typed.factor

@@ -20,6 +20,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
     {
         [ all-slots empty? not ]
         [ immutable-tuple-class? ]
+        [ final-class? ]
     } 1&& ;
 
 ! typed inputs
@@ -30,9 +31,14 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
 : input-mismatch-quot ( word types -- quot )
     [ input-mismatch-error ] 2curry ;
 
+: depends-on-unboxing ( class -- )
+    [ dup tuple-layout depends-on-tuple-layout ]
+    [ depends-on-final ]
+    bi ;
+
 : (unboxer) ( type -- quot )
     dup unboxable-tuple-class? [
-        dup dup tuple-layout depends-on-tuple-layout
+        dup depends-on-unboxing
         all-slots [
             [ name>> reader-word 1quotation ]
             [ class>> (unboxer) ] bi compose
@@ -52,7 +58,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
 : (unboxed-types) ( type -- types )
     dup unboxable-tuple-class?
     [
-        dup dup tuple-layout depends-on-tuple-layout
+        dup depends-on-unboxing
         all-slots [ class>> (unboxed-types) ] map concat
     ]
     [ 1array ] if ;
@@ -81,7 +87,7 @@ DEFER: make-boxer
 : boxer ( type -- quot )
     dup unboxable-tuple-class?
     [
-        dup dup tuple-layout depends-on-tuple-layout
+        dup depends-on-unboxing
         [ all-slots [ class>> ] map make-boxer ]
         [ [ boa ] curry ]
         bi compose

core/classes/tuple/tuple.factor

@@ -93,6 +93,14 @@ ERROR: bad-superclass class ;
         ] [ 2drop f ] if
     ] [ 2drop f ] if ; inline
 
+GENERIC: final-class? ( class -- ? )
+
+M: tuple-class final-class? "final" word-prop ;
+
+M: builtin-class final-class? tuple eq? not ;
+
+M: class final-class? drop t ;
+
 <PRIVATE
 
 : tuple-predicate-quot/1 ( class -- quot )
@@ -238,16 +246,8 @@ M: tuple-class update-class
     [ [ "slots" word-prop ] dip = ]
     bi-curry* bi and ;
 
-GENERIC: valid-superclass? ( class -- ? )
-
-M: tuple-class valid-superclass? "final" word-prop not ;
-
-M: builtin-class valid-superclass? tuple eq? ;
-
-M: class valid-superclass? drop f ;
-
 : check-superclass ( superclass -- )
-    dup valid-superclass? [ bad-superclass ] unless drop ;
+    dup final-class? [ bad-superclass ] when drop ;
 
 GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
 
@@ -261,12 +261,19 @@ GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
         read-only suffix
     ] map ;
 
+: reset-final ( class -- )
+    dup final-class? [
+        [ f "final" set-word-prop ]
+        [ changed-conditionally ]
+        bi
+    ] [ drop ] if ;
+
 PRIVATE>
 
 : define-tuple-class ( class superclass slots -- )
     over check-superclass
     over prepare-slots
-    pick f "final" set-word-prop
+    pick reset-final
     (define-tuple-class) ;
 
 GENERIC: make-final ( class -- )