--- /dev/null
+IN: compiler.tests.redefine0
+USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math ;
+
+! Test ripple-up behavior
+: test-1 ( -- a ) 3 ;
+: test-2 ( -- ) test-1 ;
+
+[ test-2 ] [ not-compiled? ] must-fail-with
+
+[ ] [ "IN: compiler.tests.redefine0 : test-1 ( -- ) ;" eval( -- ) ] unit-test
+
+{ 0 0 } [ test-1 ] must-infer-as
+
+[ ] [ test-2 ] unit-test
+
+[ ] [
+ [
+ \ test-1 forget
+ \ test-2 forget
+ ] with-compilation-unit
+] unit-test
+
+: test-3 ( a -- ) drop ;
+: test-4 ( -- ) [ 1 2 3 ] test-3 ;
+
+[ ] [ test-4 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 USE: kernel : test-3 ( a -- ) call ; inline" eval( -- ) ] unit-test
+
+[ test-4 ] [ not-compiled? ] must-fail-with
+
+[ ] [
+ [
+ \ test-3 forget
+ \ test-4 forget
+ ] with-compilation-unit
+] unit-test
+
+: test-5 ( a -- quot ) ;
+: test-6 ( a -- b ) test-5 ;
+
+[ 31337 ] [ 31337 test-6 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; MACRO: test-5 ( a -- quot ) drop [ ] ;" eval( -- ) ] unit-test
+
+[ 31337 test-6 ] [ not-compiled? ] must-fail-with
+
+[ ] [
+ [
+ \ test-5 forget
+ \ test-6 forget
+ ] with-compilation-unit
+] unit-test
+
+GENERIC: test-7 ( a -- b )
+
+M: integer test-7 + ;
+
+: test-8 ( a -- b ) 255 bitand test-7 ;
+
+[ 1 test-7 ] [ not-compiled? ] must-fail-with
+[ 1 test-8 ] [ not-compiled? ] must-fail-with
+
+[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; GENERIC: test-7 ( x y -- z )" eval( -- ) ] unit-test
+
+[ 4 ] [ 1 3 test-7 ] unit-test
+[ 4 ] [ 1 259 test-8 ] unit-test
+
+[ ] [
+ [
+ \ test-7 forget
+ \ test-8 forget
+ ] with-compilation-unit
+] unit-test
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test
-[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
\ No newline at end of file
+[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
+
+[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
[ f initial-recursive-state infer-quot ] bi*
] with-tree-builder
unclip-last in-d>>
- ] [ "OOPS" USE: io print flush 3drop f f ] recover ;
+ ] [ 3drop f f ] recover ;
: build-sub-tree ( #call quot -- nodes/f )
[ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
normalize
propagate
cleanup
- ?check
dup run-escape-analysis? [
escape-analysis
unbox-tuples
[ history [ swap suffix ] change ]
bi ;
-:: inline-word-def ( #call word quot -- ? )
+:: inline-word ( #call word -- ? )
word history get memq? [ f ] [
- #call quot splicing-nodes [
+ #call word specialized-def splicing-nodes [
[
word remember-inlining
[ ] [ count-nodes ] [ (propagate) ] tri
] [ f ] if*
] if ;
-: inline-word ( #call word -- ? )
- dup specialized-def inline-word-def ;
-
: inline-method-body ( #call word -- ? )
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
call( #call -- word/quot/f )
object swap eliminate-dispatch ;
-: inline-instance-check ( #call word -- ? )
- over in-d>> second value-info literal>> dup class?
- [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
-
: (do-inlining) ( #call word -- ? )
#! If the generic was defined in an outer compilation unit,
#! then it doesn't have a definition yet; the definition
#! discouraged, but it should still work.)
{
{ [ dup never-inline-word? ] [ 2drop f ] }
- { [ dup \ instance? eq? ] [ inline-instance-check ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
] [ 2drop object-info ] if
] "outputs" set-word-prop
+\ instance? [
+ in-d>> second value-info literal>> dup class?
+ [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
+] "custom-inlining" set-word-prop
+
\ equal? [
! If first input has a known type and second input is an
! object, we convert this to [ swap equal? ].
dispatch <tuple-boa> exit load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect
alien-callback
-} [ t "special" set-word-prop ] each
+} [
+ [ t "special" set-word-prop ]
+ [ t "no-compile" set-word-prop ] bi
+] each
M\ quotation call t "no-compile" set-word-prop
M\ curry call t "no-compile" set-word-prop
arrays vectors strings compiler.units accessors classes.algebra
calendar prettyprint io.streams.string splitting summary
columns math.order classes.private slots slots.private eval see
-words.symbol ;
+words.symbol compiler.errors ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
! Make sure we handle changing shapes!
TUPLE: point x y ;
-C: <point> point
-
-[ ] [ 100 200 <point> "p" set ] unit-test
+[ ] [ 100 200 point boa "p" set ] unit-test
! Use eval to sequence parsing explicitly
[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test
C: <erg's-reshape-problem> erg's-reshape-problem
-! We want to make sure constructors are recompiled when
-! tuples are reshaped
-: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
-: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
-
-[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval( -- ) ] unit-test
-
-[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
-
-[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
-
! Inheritance
TUPLE: computer cpu ram ;
C: <computer> computer
! Dynamically changing inheritance hierarchy
TUPLE: electronic-device ;
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
[ f ] [ electronic-device laptop class<= ] unit-test
[ t ] [ server electronic-device class<= ] unit-test
[ f ] [ "server" get laptop? ] unit-test
[ t ] [ "server" get server? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
[ f ] [ "laptop" get electronic-device? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
[ ] [ "laptop" get 220 >>voltage drop ] unit-test
[ ] [ "server" get 110 >>voltage drop ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: <computer> computer" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
[ 220 ] [ "laptop" get voltage>> ] unit-test
[ 110 ] [ "server" get voltage>> ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
[ 110 ] [ "server" get voltage>> ] unit-test
! Reshaping superclass and subclass simultaneously
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
! Reshape crash
TUPLE: test1 a ; TUPLE: test2 < test1 b ;
-C: <test2> test2
-
-"a" "b" <test2> "test" set
+"a" "b" test2 boa "test" set
: test-a/b ( -- )
[ "a" ] [ "test" get a>> ] unit-test
TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
-C: <constructor-update-2> constructor-update-2
+: <constructor-update-2> ( a b c -- tuple ) constructor-update-2 boa ;
{ 3 1 } [ <constructor-update-2> ] must-infer-as
[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test
-{ 5 1 } [ <constructor-update-2> ] must-infer-as
+{ 3 1 } [ <constructor-update-2> ] must-infer-as
+
+[ 1 2 3 4 5 <constructor-update-2> ] [ not-compiled? ] must-fail-with
-[ { 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
+[ ] [ [ \ <constructor-update-2> forget ] with-compilation-unit ] unit-test
! Redefinition problem
TUPLE: redefinition-problem ;
: blah ( -- vec ) vector new ;
-\ blah must-infer
+[ vector new ] must-infer
[ V{ } ] [ blah ] unit-test
-USING: definitions compiler.units tools.test arrays sequences words kernel
+USING: compiler definitions compiler.units tools.test arrays sequences words kernel
accessors namespaces fry eval ;
IN: compiler.units.tests
! Non-optimizing compiler bugs
[ 1 1 ] [
- "A" "B" <word> [ [ 1 ] dip ] 2array 1array modify-code-heap
+ "A" "B" <word> [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep
1 swap execute
] unit-test
[ "A" "B" ] [
+ disable-compiler
+
gensym "a" set
gensym "b" set
[
"a" get [ "B" ] define
] with-compilation-unit
"b" get execute
+
+ enable-compiler
] unit-test
! Notify observers even if compilation unit did nothing