diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index d995354a52..df68fa8961 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/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 diff --git a/basis/typed/typed-tests.factor b/basis/typed/typed-tests.factor index f1e151b985..7f984ccaf2 100644 --- a/basis/typed/typed-tests.factor +++ b/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-dum ; +TUPLE: tweedle-dee ; final +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 -TUPLE: superclass x ; -TUPLE: subclass < superclass y ; +[ f ] [ + T{ unboxable3 } no-outputs-unboxable-input buh get + 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 diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor index e71196e3ee..8a85ca1afb 100644 --- a/basis/typed/typed.factor +++ b/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 diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index c7a3afdd6d..b590826511 100644 --- a/core/classes/tuple/tuple.factor +++ b/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 ; + : 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 -- )