Remove obsolete files
Slava Pestov
parent
6df325c168
commit
b14197fadc
|
|
@ -1,356 +0,0 @@
|
|||
IN: temporary
|
||||
USING: alien alien.c-types alien.syntax compiler kernel
|
||||
namespaces namespaces tools.test sequences inference words
|
||||
arrays parser quotations continuations inference.backend effects
|
||||
namespaces.private io io.streams.string memory system threads
|
||||
tools.test ;
|
||||
|
||||
FUNCTION: void ffi_test_0 ;
|
||||
[ ] [ ffi_test_0 ] unit-test
|
||||
|
||||
FUNCTION: int ffi_test_1 ;
|
||||
[ 3 ] [ ffi_test_1 ] unit-test
|
||||
|
||||
FUNCTION: int ffi_test_2 int x int y ;
|
||||
[ 5 ] [ 2 3 ffi_test_2 ] unit-test
|
||||
[ "hi" 3 ffi_test_2 ] must-fail
|
||||
|
||||
FUNCTION: int ffi_test_3 int x int y int z int t ;
|
||||
[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
|
||||
|
||||
FUNCTION: float ffi_test_4 ;
|
||||
[ 1.5 ] [ ffi_test_4 ] unit-test
|
||||
|
||||
FUNCTION: double ffi_test_5 ;
|
||||
[ 1.5 ] [ ffi_test_5 ] unit-test
|
||||
|
||||
FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
|
||||
[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
|
||||
[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
|
||||
[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
|
||||
|
||||
C-STRUCT: foo
|
||||
{ "int" "x" }
|
||||
{ "int" "y" }
|
||||
;
|
||||
|
||||
: make-foo ( x y -- foo )
|
||||
"foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
|
||||
|
||||
FUNCTION: int ffi_test_11 int a foo b int c ;
|
||||
|
||||
[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
|
||||
|
||||
FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
|
||||
|
||||
[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
|
||||
|
||||
FUNCTION: foo ffi_test_14 int x int y ;
|
||||
|
||||
[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
|
||||
|
||||
FUNCTION: char* ffi_test_15 char* x char* y ;
|
||||
|
||||
[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
|
||||
[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
|
||||
[ 1 2 ffi_test_15 ] must-fail
|
||||
|
||||
C-STRUCT: bar
|
||||
{ "long" "x" }
|
||||
{ "long" "y" }
|
||||
{ "long" "z" }
|
||||
;
|
||||
|
||||
FUNCTION: bar ffi_test_16 long x long y long z ;
|
||||
|
||||
[ 11 6 -7 ] [
|
||||
11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
|
||||
] unit-test
|
||||
|
||||
C-STRUCT: tiny
|
||||
{ "int" "x" }
|
||||
;
|
||||
|
||||
FUNCTION: tiny ffi_test_17 int x ;
|
||||
|
||||
[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
|
||||
|
||||
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
|
||||
|
||||
: indirect-test-1
|
||||
"int" { } "cdecl" alien-indirect ;
|
||||
|
||||
{ 1 1 } [ indirect-test-1 ] must-infer-as
|
||||
|
||||
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
|
||||
|
||||
[ -1 indirect-test-1 ] must-fail
|
||||
|
||||
: indirect-test-2
|
||||
"int" { "int" "int" } "cdecl" alien-indirect data-gc ;
|
||||
|
||||
{ 3 1 } [ indirect-test-2 ] must-infer-as
|
||||
|
||||
[ 5 ]
|
||||
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
|
||||
unit-test
|
||||
|
||||
: indirect-test-3
|
||||
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
|
||||
data-gc ;
|
||||
|
||||
<< "f-stdcall" f "stdcall" add-library >>
|
||||
|
||||
[ f ] [ "f-stdcall" load-library ] unit-test
|
||||
[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
|
||||
|
||||
: ffi_test_18 ( w x y z -- int )
|
||||
"int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
|
||||
alien-invoke data-gc ;
|
||||
|
||||
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
|
||||
|
||||
: ffi_test_19 ( x y z -- bar )
|
||||
"bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
|
||||
alien-invoke data-gc ;
|
||||
|
||||
[ 11 6 -7 ] [
|
||||
11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
|
||||
] unit-test
|
||||
|
||||
FUNCTION: double ffi_test_6 float x float y ;
|
||||
[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
|
||||
[ "a" "b" ffi_test_6 ] must-fail
|
||||
|
||||
FUNCTION: double ffi_test_7 double x double y ;
|
||||
[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
|
||||
|
||||
FUNCTION: double ffi_test_8 double x float y double z float t int w ;
|
||||
[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
|
||||
|
||||
FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
|
||||
[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
|
||||
|
||||
FUNCTION: void ffi_test_20 double x1, double x2, double x3,
|
||||
double y1, double y2, double y3,
|
||||
double z1, double z2, double z3 ;
|
||||
|
||||
[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
|
||||
|
||||
! Make sure XT doesn't get clobbered in stack frame
|
||||
|
||||
: ffi_test_31
|
||||
"void"
|
||||
f "ffi_test_31"
|
||||
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
|
||||
alien-invoke code-gc 3 ;
|
||||
|
||||
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
|
||||
|
||||
FUNCTION: longlong ffi_test_21 long x long y ;
|
||||
|
||||
[ 121932631112635269 ]
|
||||
[ 123456789 987654321 ffi_test_21 ] unit-test
|
||||
|
||||
FUNCTION: long ffi_test_22 long x longlong y longlong z ;
|
||||
|
||||
[ 987655432 ]
|
||||
[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
|
||||
|
||||
[ 1111 f 123456789 ffi_test_22 ] must-fail
|
||||
|
||||
C-STRUCT: rect
|
||||
{ "float" "x" }
|
||||
{ "float" "y" }
|
||||
{ "float" "w" }
|
||||
{ "float" "h" }
|
||||
;
|
||||
|
||||
: <rect>
|
||||
"rect" <c-object>
|
||||
[ set-rect-h ] keep
|
||||
[ set-rect-w ] keep
|
||||
[ set-rect-y ] keep
|
||||
[ set-rect-x ] keep ;
|
||||
|
||||
FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
|
||||
|
||||
[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
|
||||
|
||||
[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
|
||||
|
||||
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
|
||||
|
||||
[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
|
||||
|
||||
! Test odd-size structs
|
||||
C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
|
||||
|
||||
FUNCTION: test-struct-1 ffi_test_24 ;
|
||||
|
||||
[ B{ 1 } ] [ ffi_test_24 ] unit-test
|
||||
|
||||
C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
|
||||
|
||||
FUNCTION: test-struct-2 ffi_test_25 ;
|
||||
|
||||
[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
|
||||
|
||||
C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
|
||||
|
||||
FUNCTION: test-struct-3 ffi_test_26 ;
|
||||
|
||||
[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
|
||||
|
||||
C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
|
||||
|
||||
FUNCTION: test-struct-4 ffi_test_27 ;
|
||||
|
||||
[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
|
||||
|
||||
C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
|
||||
|
||||
FUNCTION: test-struct-5 ffi_test_28 ;
|
||||
|
||||
[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
|
||||
|
||||
C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
|
||||
|
||||
FUNCTION: test-struct-6 ffi_test_29 ;
|
||||
|
||||
[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
|
||||
|
||||
C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
|
||||
|
||||
FUNCTION: test-struct-7 ffi_test_30 ;
|
||||
|
||||
[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
|
||||
|
||||
C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
|
||||
|
||||
FUNCTION: double ffi_test_32 test-struct-8 x int y ;
|
||||
|
||||
[ 9.0 ] [
|
||||
"test-struct-8" <c-object>
|
||||
1.0 over set-test-struct-8-x
|
||||
2.0 over set-test-struct-8-y
|
||||
3 ffi_test_32
|
||||
] unit-test
|
||||
|
||||
C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
|
||||
|
||||
FUNCTION: double ffi_test_33 test-struct-9 x int y ;
|
||||
|
||||
[ 9.0 ] [
|
||||
"test-struct-9" <c-object>
|
||||
1.0 over set-test-struct-9-x
|
||||
2.0 over set-test-struct-9-y
|
||||
3 ffi_test_33
|
||||
] unit-test
|
||||
|
||||
C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
|
||||
|
||||
FUNCTION: double ffi_test_34 test-struct-10 x int y ;
|
||||
|
||||
[ 9.0 ] [
|
||||
"test-struct-10" <c-object>
|
||||
1.0 over set-test-struct-10-x
|
||||
2 over set-test-struct-10-y
|
||||
3 ffi_test_34
|
||||
] unit-test
|
||||
|
||||
C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
|
||||
|
||||
FUNCTION: double ffi_test_35 test-struct-11 x int y ;
|
||||
|
||||
[ 9.0 ] [
|
||||
"test-struct-11" <c-object>
|
||||
1 over set-test-struct-11-x
|
||||
2 over set-test-struct-11-y
|
||||
3 ffi_test_35
|
||||
] unit-test
|
||||
|
||||
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
|
||||
|
||||
: make-struct-12
|
||||
"test-struct-12" <c-object>
|
||||
[ set-test-struct-12-x ] keep ;
|
||||
|
||||
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
|
||||
|
||||
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
|
||||
|
||||
! Test callbacks
|
||||
|
||||
: callback-1 "void" { } "cdecl" [ ] alien-callback ;
|
||||
|
||||
[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
|
||||
|
||||
[ t ] [ callback-1 alien? ] unit-test
|
||||
|
||||
: callback_test_1 "void" { } "cdecl" alien-indirect ;
|
||||
|
||||
[ ] [ callback-1 callback_test_1 ] unit-test
|
||||
|
||||
: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
|
||||
|
||||
[ ] [ callback-2 callback_test_1 ] unit-test
|
||||
|
||||
: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
|
||||
|
||||
[ t ] [
|
||||
namestack*
|
||||
3 "x" set callback-3 callback_test_1
|
||||
namestack* eq?
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
[
|
||||
3 "x" set callback-3 callback_test_1 "x" get
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
: callback-4
|
||||
"void" { } "cdecl" [ "Hello world" write ] alien-callback
|
||||
data-gc ;
|
||||
|
||||
[ "Hello world" ] [
|
||||
[ callback-4 callback_test_1 ] string-out
|
||||
] unit-test
|
||||
|
||||
: callback-5
|
||||
"void" { } "cdecl" [ data-gc ] alien-callback ;
|
||||
|
||||
[ "testing" ] [
|
||||
"testing" callback-5 callback_test_1
|
||||
] unit-test
|
||||
|
||||
: callback-5a
|
||||
"void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
|
||||
|
||||
! Hack; if we're on ARM, we probably don't have much RAM, so
|
||||
! skip this test.
|
||||
cpu "arm" = [
|
||||
[ "testing" ] [
|
||||
"testing" callback-5a callback_test_1
|
||||
] unit-test
|
||||
] unless
|
||||
|
||||
: callback-6
|
||||
"void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
|
||||
|
||||
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
|
||||
|
||||
: callback-7
|
||||
"void" { } "cdecl" [ 1000 sleep ] alien-callback ;
|
||||
|
||||
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
|
||||
|
||||
[ f ] [ namespace global eq? ] unit-test
|
||||
|
||||
: callback-8
|
||||
"void" { } "cdecl" [
|
||||
[ continue ] callcc0
|
||||
] alien-callback ;
|
||||
|
||||
[ ] [ callback-8 callback_test_1 ] unit-test
|
||||
|
|
@ -1,303 +0,0 @@
|
|||
USING: arrays compiler generic hashtables inference kernel
|
||||
kernel.private math optimizer prettyprint sequences sbufs
|
||||
strings tools.test vectors words sequences.private quotations
|
||||
optimizer.backend classes inference.dataflow tuples.private
|
||||
continuations growable ;
|
||||
IN: temporary
|
||||
|
||||
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
|
||||
] unit-test
|
||||
|
||||
[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
|
||||
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
|
||||
] unit-test
|
||||
|
||||
! Test method inlining
|
||||
[ f ] [ fixnum { } min-class ] unit-test
|
||||
|
||||
[ string ] [
|
||||
\ string
|
||||
[ integer string array reversed sbuf
|
||||
slice vector quotation ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ fixnum ] [
|
||||
\ fixnum
|
||||
[ fixnum integer object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ integer ] [
|
||||
\ fixnum
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ object ] [
|
||||
\ word
|
||||
[ integer float object ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
[ reversed ] [
|
||||
\ reversed
|
||||
[ integer reversed slice ]
|
||||
sort-classes min-class
|
||||
] unit-test
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
M: array xyz xyz ;
|
||||
|
||||
[ t ] [ \ xyz compiled? ] unit-test
|
||||
|
||||
! Test predicate inlining
|
||||
: pred-test-1
|
||||
dup fixnum? [
|
||||
dup integer? [ "integer" ] [ "nope" ] if
|
||||
] [
|
||||
"not a fixnum"
|
||||
] if ;
|
||||
|
||||
[ 1 "integer" ] [ 1 pred-test-1 ] unit-test
|
||||
|
||||
TUPLE: pred-test ;
|
||||
|
||||
: pred-test-2
|
||||
dup tuple? [
|
||||
dup pred-test? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
"not a tuple"
|
||||
] if ;
|
||||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test
|
||||
|
||||
: pred-test-3
|
||||
dup pred-test? [
|
||||
dup tuple? [ "pred-test" ] [ "nope" ] if
|
||||
] [
|
||||
"not a tuple"
|
||||
] if ;
|
||||
|
||||
[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test
|
||||
|
||||
: inline-test
|
||||
"nom" = ;
|
||||
|
||||
[ t ] [ "nom" inline-test ] unit-test
|
||||
[ f ] [ "shayin" inline-test ] unit-test
|
||||
[ f ] [ 3 inline-test ] unit-test
|
||||
|
||||
: fixnum-declarations >fixnum 24 shift 1234 bitxor ;
|
||||
|
||||
[ ] [ 1000000 fixnum-declarations . ] unit-test
|
||||
|
||||
! regression
|
||||
|
||||
: literal-not-branch 0 not [ ] [ ] if ;
|
||||
|
||||
[ ] [ literal-not-branch ] unit-test
|
||||
|
||||
! regression
|
||||
|
||||
: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline
|
||||
: bad-kill-2 bad-kill-1 drop ;
|
||||
|
||||
[ 3 ] [ t bad-kill-2 ] unit-test
|
||||
|
||||
! regression
|
||||
: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline
|
||||
: the-test ( -- x y ) 2 dup (the-test) ;
|
||||
|
||||
[ 2 0 ] [ the-test ] unit-test
|
||||
|
||||
! regression
|
||||
: (double-recursion) ( start end -- )
|
||||
< [
|
||||
6 1 (double-recursion)
|
||||
3 2 (double-recursion)
|
||||
] when ; inline
|
||||
|
||||
: double-recursion 0 2 (double-recursion) ;
|
||||
|
||||
[ ] [ double-recursion ] unit-test
|
||||
|
||||
! regression
|
||||
: double-label-1 ( a b c -- d )
|
||||
[ f double-label-1 ] [ swap nth-unsafe ] if ; inline
|
||||
|
||||
: double-label-2 ( a -- b )
|
||||
dup array? [ ] [ ] if 0 t double-label-1 ;
|
||||
|
||||
[ 0 ] [ 10 double-label-2 ] unit-test
|
||||
|
||||
! regression
|
||||
GENERIC: void-generic ( obj -- * )
|
||||
: breakage "hi" void-generic ;
|
||||
[ t ] [ \ breakage compiled? ] unit-test
|
||||
[ breakage ] must-fail
|
||||
|
||||
! regression
|
||||
: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
|
||||
: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
|
||||
: test-2 ( -- ) 5 test-1 ;
|
||||
|
||||
[ f ] [ f test-2 ] unit-test
|
||||
|
||||
: branch-fold-regression-0 ( m -- n )
|
||||
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
|
||||
|
||||
: branch-fold-regression-1 ( -- m )
|
||||
10 branch-fold-regression-0 ;
|
||||
|
||||
[ 10 ] [ branch-fold-regression-1 ] unit-test
|
||||
|
||||
! another regression
|
||||
: constant-branch-fold-0 "hey" ; foldable
|
||||
: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline
|
||||
[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test
|
||||
|
||||
! another regression
|
||||
: foo f ;
|
||||
: bar foo 4 4 = and ;
|
||||
[ f ] [ bar ] unit-test
|
||||
|
||||
! ensure identities are working in some form
|
||||
[ t ] [
|
||||
[ { number } declare 0 + ] dataflow optimize
|
||||
[ #push? ] node-exists? not
|
||||
] unit-test
|
||||
|
||||
! compiling <tuple> with a non-literal class failed
|
||||
: <tuple>-regression <tuple> ;
|
||||
|
||||
[ t ] [ \ <tuple>-regression compiled? ] unit-test
|
||||
|
||||
GENERIC: foozul ( a -- b )
|
||||
M: reversed foozul ;
|
||||
M: integer foozul ;
|
||||
M: slice foozul ;
|
||||
|
||||
[ reversed ] [ reversed \ foozul specific-method ] unit-test
|
||||
|
||||
! regression
|
||||
: constant-fold-2 f ; foldable
|
||||
: constant-fold-3 4 ; foldable
|
||||
|
||||
[ f t ] [
|
||||
[ constant-fold-2 constant-fold-3 4 = ] compile-call
|
||||
] unit-test
|
||||
|
||||
: constant-fold-4 f ; foldable
|
||||
: constant-fold-5 f ; foldable
|
||||
|
||||
[ f ] [
|
||||
[ constant-fold-4 constant-fold-5 or ] compile-call
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ dup - ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test
|
||||
[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test
|
||||
|
||||
[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test
|
||||
[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test
|
||||
[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test
|
||||
[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test
|
||||
[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test
|
||||
[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test
|
||||
|
||||
[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test
|
||||
[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test
|
||||
|
||||
[ f ] [ 5 [ dup < ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup <= ] compile-call ] unit-test
|
||||
[ f ] [ 5 [ dup > ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup >= ] compile-call ] unit-test
|
||||
|
||||
[ t ] [ 5 [ dup eq? ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup = ] compile-call ] unit-test
|
||||
[ t ] [ 5 [ dup number= ] compile-call ] unit-test
|
||||
[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test
|
||||
|
||||
GENERIC: detect-number ( obj -- obj )
|
||||
M: number detect-number ;
|
||||
|
||||
[ 10 f [ <array> 0 + detect-number ] compile-call ] must-fail
|
||||
|
||||
! Regression
|
||||
[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test
|
||||
|
||||
! Regression
|
||||
USE: sorting
|
||||
USE: sorting.private
|
||||
|
||||
: old-binsearch ( elt quot seq -- elt quot i )
|
||||
dup length 1 <= [
|
||||
slice-from
|
||||
] [
|
||||
[ midpoint swap call ] 3keep roll dup zero?
|
||||
[ drop dup slice-from swap midpoint@ + ]
|
||||
[ partition old-binsearch ] if
|
||||
] if ; inline
|
||||
|
||||
[ 10 ] [
|
||||
10 20 >vector <flat-slice>
|
||||
[ [ - ] swap old-binsearch ] compile-call 2nip
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
TUPLE: silly-tuple a b ;
|
||||
|
||||
[ 1 2 { silly-tuple-a silly-tuple-b } ] [
|
||||
T{ silly-tuple f 1 2 }
|
||||
[
|
||||
{ silly-tuple-a silly-tuple-b } [ get-slots ] keep
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
||||
! Regression
|
||||
: empty-compound ;
|
||||
|
||||
: node-successor-f-bug ( x -- * )
|
||||
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
|
||||
|
||||
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
|
||||
|
||||
: construct-empty-bug construct-empty ;
|
||||
|
||||
[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
|
||||
|
||||
! Make sure we have sane heuristics
|
||||
: should-inline? method method-word flat-length 10 <= ;
|
||||
|
||||
[ t ] [ \ fixnum \ shift should-inline? ] unit-test
|
||||
[ f ] [ \ array \ equal? should-inline? ] unit-test
|
||||
[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
|
||||
[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
|
||||
[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
|
||||
Loading…
Reference in New Issue