2016-03-30 21:43:14 -04:00
|
|
|
USING: arrays compiler compiler.units definitions eval fry
|
|
|
|
kernel math namespaces quotations sequences tools.test words ;
|
2009-03-28 05:19:02 -04:00
|
|
|
IN: compiler.units.tests
|
2008-08-30 03:31:27 -04:00
|
|
|
|
2009-03-13 20:39:32 -04:00
|
|
|
[ [ [ ] define-temp ] with-compilation-unit ] must-infer
|
|
|
|
[ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
|
|
|
|
|
2009-01-23 19:20:47 -05:00
|
|
|
! Non-optimizing compiler bugs
|
2015-07-02 20:28:17 -04:00
|
|
|
{ 1 1 } [
|
2010-02-01 08:49:05 -05:00
|
|
|
"A" <uninterned-word> [ [ [ 1 ] dip ] 2array 1array t t modify-code-heap ] keep
|
2009-01-22 22:22:28 -05:00
|
|
|
1 swap execute
|
2009-01-23 19:20:47 -05:00
|
|
|
] unit-test
|
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ "A" "B" } [
|
2009-05-01 06:52:05 -04:00
|
|
|
disable-optimizer
|
2009-04-21 17:09:53 -04:00
|
|
|
|
2009-01-23 19:20:47 -05:00
|
|
|
gensym "a" set
|
|
|
|
gensym "b" set
|
|
|
|
[
|
|
|
|
"a" get [ "A" ] define
|
|
|
|
"b" get "a" get '[ _ execute ] define
|
|
|
|
] with-compilation-unit
|
|
|
|
"b" get execute
|
|
|
|
[
|
|
|
|
"a" get [ "B" ] define
|
|
|
|
] with-compilation-unit
|
|
|
|
"b" get execute
|
2009-04-21 17:09:53 -04:00
|
|
|
|
2009-05-01 06:52:05 -04:00
|
|
|
enable-optimizer
|
2009-03-28 05:19:02 -04:00
|
|
|
] unit-test
|
|
|
|
|
2009-04-22 05:20:38 -04:00
|
|
|
! Check that we notify observers
|
2009-03-28 05:19:02 -04:00
|
|
|
SINGLETON: observer
|
|
|
|
|
|
|
|
observer add-definition-observer
|
|
|
|
|
|
|
|
SYMBOL: counter
|
|
|
|
|
|
|
|
0 counter set-global
|
|
|
|
|
2011-10-19 13:40:12 -04:00
|
|
|
M: observer definitions-changed
|
|
|
|
2drop [ counter inc ] with-global ;
|
2009-03-28 05:19:02 -04:00
|
|
|
|
2011-10-18 16:18:42 -04:00
|
|
|
[ gensym [ ] ( -- ) define-declared ] with-compilation-unit
|
2009-03-28 05:19:02 -04:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ 1 } [ counter get-global ] unit-test
|
2009-04-15 01:27:02 -04:00
|
|
|
|
|
|
|
observer remove-definition-observer
|
|
|
|
|
|
|
|
! Notify observers with nested compilation units
|
|
|
|
observer add-definition-observer
|
|
|
|
|
|
|
|
0 counter set-global
|
|
|
|
|
|
|
|
DEFER: nesting-test
|
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ } [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval( -- ) ] unit-test
|
2009-04-15 01:27:02 -04:00
|
|
|
|
2009-04-17 13:45:57 -04:00
|
|
|
observer remove-definition-observer
|
2010-01-06 05:49:14 -05:00
|
|
|
|
|
|
|
! Make sure that non-optimized calls to a generic word which
|
|
|
|
! hasn't been compiled yet work properly
|
|
|
|
GENERIC: uncompiled-generic-test ( a -- b )
|
|
|
|
|
|
|
|
M: integer uncompiled-generic-test 1 + ;
|
|
|
|
|
|
|
|
<< [ uncompiled-generic-test ] [ jit-compile ] [ suffix! ] bi >>
|
|
|
|
"q" set
|
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ 4 } [ 3 "q" get call ] unit-test
|
2010-01-06 05:49:14 -05:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ } [ [ \ uncompiled-generic-test forget ] with-compilation-unit ] unit-test
|