--- /dev/null
+USING: compiler.crossref fry kernel sequences tools.test vocabs words ;
+IN: compiler.crossref.tests
+
+! Dependencies of all words should always be satisfied unless we're
+! in the middle of recompiling something
+[ { } ] [
+ all-words dup [ subwords ] map concat append
+ H{ } clone '[ _ dependencies-satisfied? not ] filter
+] unit-test
--- /dev/null
+IN: compiler.tests.redefine22
+USING: kernel sequences compiler.units vocabs tools.test definitions ;
+
+TUPLE: ttt ;
+INSTANCE: ttt sequence
+M: ttt new-sequence 2drop ttt new ;
+
+: www-1 ( a -- b ) T{ ttt } new-sequence ;
+
+! This used to break with a compiler error in the above word
+[ ] [ [ \ ttt forget ] with-compilation-unit ] unit-test
--- /dev/null
+IN: compiler.tests.redefine23
+USING: classes.struct specialized-arrays alien.c-types sequences
+compiler.units vocabs tools.test ;
+
+STRUCT: my-struct { x int } ;
+SPECIALIZED-ARRAY: my-struct
+: my-word ( a -- b ) iota [ my-struct <struct-boa> ] my-struct-array{ } map-as ;
+
+[ ] [
+ [
+ "specialized-arrays.instances.compiler.tests.redefine23" forget-vocab
+ ] with-compilation-unit
+] unit-test
[ in-d>> #drop ]
bi prefix ;
-: record-predicate-folding ( #call -- )
- [ node-input-infos first class>> ]
+: >predicate-folding< ( #call -- value-info class result )
+ [ node-input-infos first ]
[ word>> "predicating" word-prop ]
- [ node-output-infos first literal>> ] tri
- [ depends-on-class<= ] [ depends-on-classes-disjoint ] if ;
+ [ node-output-infos first literal>> ] tri ;
+
+: record-predicate-folding ( #call -- )
+ >predicate-folding< pick literal?>>
+ [ [ literal>> ] 2dip depends-on-instance-predicate ]
+ [ [ class>> ] 2dip depends-on-class-predicate ]
+ if ;
: record-folding ( #call -- )
dup word>> predicate?
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
-classes.tuple.private kernel accessors math math.intervals namespaces
-sequences sequences.private words combinators memoize
-combinators.short-circuit byte-arrays strings arrays layouts
-cpu.architecture compiler.tree.propagation.copy ;
+classes.tuple.private classes.singleton kernel accessors math
+math.intervals namespaces sequences sequences.private words
+combinators memoize combinators.short-circuit byte-arrays
+strings arrays layouts cpu.architecture
+compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
UNION: fixed-length array byte-array string ;
+: literal-class ( obj -- class )
+ #! Handle forgotten tuples and singleton classes properly
+ dup singleton-class? [
+ class dup class? [
+ drop tuple
+ ] unless
+ ] unless ;
+
: init-literal-info ( info -- info )
empty-interval >>interval
- dup literal>> class >>class
+ dup literal>> literal-class >>class
dup literal>> {
{ [ dup real? ] [ [a,a] >>interval ] }
{ [ dup tuple? ] [ tuple-slot-infos >>slots ] }
] final-info drop
] unit-test
-[ V{ word } ] [
+[ V{ t } ] [
[ { hashtable } declare hashtable instance? ] final-classes
] unit-test
[ { assoc } declare hashtable instance? ] final-classes
] unit-test
-[ V{ word } ] [
+[ V{ t } ] [
[ { string } declare string? ] final-classes
] unit-test
[ { fixnum } declare log2 ] final-classes
] unit-test
-[ V{ word } ] [
+[ V{ t } ] [
[ { fixnum } declare log2 0 >= ] final-classes
] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences sequences.private assocs
words namespaces classes.algebra combinators
recover ;
: predicate-output-infos/class ( info class -- info )
- [ class>> ] dip {
- { [ 2dup class<= ] [ t <literal-info> ] }
- { [ 2dup classes-intersect? not ] [ f <literal-info> ] }
- [ object-info ]
- } cond 2nip ;
+ [ class>> ] dip compare-classes
+ dup +incomparable+ eq? [ drop object-info ] [ <literal-info> ] if ;
: predicate-output-infos ( info class -- info )
over literal?>>
! 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
-classes.tuple ;
+USING: assocs accessors classes classes.algebra fry generic
+kernel math namespaces sequences words sets
+combinators.short-circuit classes.tuple ;
FROM: classes.tuple.private => tuple-layout ;
IN: stack-checker.dependencies
boa conditional-dependencies get
dup [ conjoin ] [ 2drop ] if ; inline
-TUPLE: depends-on-class<= class1 class2 ;
+TUPLE: depends-on-class-predicate class1 class2 result ;
-: depends-on-class<= ( class1 class2 -- )
- \ depends-on-class<= add-conditional-dependency ;
+: depends-on-class-predicate ( class1 class2 result -- )
+ \ depends-on-class-predicate add-conditional-dependency ;
-M: depends-on-class<= satisfied?
+M: depends-on-class-predicate satisfied?
{
- [ class1>> classoid? ]
- [ class2>> classoid? ]
- [ [ class1>> ] [ class2>> ] bi class<= ]
+ [ [ class1>> classoid? ] [ class2>> classoid? ] bi and ]
+ [ [ [ class1>> ] [ class2>> ] bi compare-classes ] [ result>> ] bi eq? ]
} 1&& ;
-TUPLE: depends-on-classes-disjoint class1 class2 ;
+TUPLE: depends-on-instance-predicate object class result ;
-: depends-on-classes-disjoint ( class1 class2 -- )
- \ depends-on-classes-disjoint add-conditional-dependency ;
+: depends-on-instance-predicate ( object class result -- )
+ \ depends-on-instance-predicate add-conditional-dependency ;
-M: depends-on-classes-disjoint satisfied?
+M: depends-on-instance-predicate satisfied?
{
- [ class1>> classoid? ]
- [ class2>> classoid? ]
- [ [ class1>> ] [ class2>> ] bi classes-intersect? not ]
+ [ class>> classoid? ]
+ [ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
} 1&& ;
TUPLE: depends-on-next-method class generic next-method ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
+
+SYMBOL: +incomparable+
+
+: compare-classes ( class1 class2 -- ? )
+ {
+ { [ 2dup class<= ] [ t ] }
+ { [ 2dup classes-intersect? not ] [ f ] }
+ [ +incomparable+ ]
+ } cond 2nip ;