! 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
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
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 ;
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 ;
TUPLE: unboxable
{ x fixnum read-only }
{ y fixnum read-only }
- { z float read-only } ;
+ { z float read-only } ; final
""" eval( -- )
"""
[ 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 -- )
[ T{ unboxable3 } ] [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test
+[ f ] [
+ T{ unboxable3 } no-outputs-unboxable-input buh get
+ T{ unboxable3 } no-outputs-unboxable-input buh get
+ eq?
+] unit-test
+
! Reported by littledan
-TUPLE: superclass x ;
-TUPLE: subclass < superclass y ;
+TUPLE: superclass { x read-only } ;
+TUPLE: subclass < superclass { y read-only } ; final
-TYPED: unbox-fail ( superclass: a -- ? ) subclass? ;
+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
{
[ all-slots empty? not ]
[ immutable-tuple-class? ]
+ [ final-class? ]
} 1&& ;
! typed inputs
: 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
: (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 ;
: 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
] [ 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 )
[ [ "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 -- )
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 -- )