2016-03-30 21:43:14 -04:00
|
|
|
USING: accessors alien alien.accessors alien.c-types
|
|
|
|
alien.syntax byte-arrays continuations fry kernel layouts math
|
|
|
|
namespaces prettyprint sequences tools.memory tools.test ;
|
2016-03-29 23:43:46 -04:00
|
|
|
QUALIFIED: sets
|
2009-03-26 00:00:19 -04:00
|
|
|
IN: alien.tests
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ t } [ -1 <alien> alien-address 0 > ] unit-test
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ t } [ 0 <alien> 0 <alien> = ] unit-test
|
|
|
|
{ f } [ 0 <alien> 1024 <alien> = ] unit-test
|
|
|
|
{ f } [ "hello" 1024 <alien> = ] unit-test
|
|
|
|
{ f } [ 0 <alien> ] unit-test
|
|
|
|
{ f } [ 0 f <displaced-alien> ] unit-test
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Testing the various bignum accessor
|
|
|
|
10 <byte-array> "dump" set
|
|
|
|
|
2008-02-06 14:47:19 -05:00
|
|
|
[ "dump" get alien-address ] must-fail
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ 123 } [
|
2007-09-20 18:09:08 -04:00
|
|
|
123 "dump" get 0 set-alien-signed-1
|
|
|
|
"dump" get 0 alien-signed-1
|
|
|
|
] unit-test
|
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ 12345 } [
|
2007-09-20 18:09:08 -04:00
|
|
|
12345 "dump" get 0 set-alien-signed-2
|
|
|
|
"dump" get 0 alien-signed-2
|
|
|
|
] unit-test
|
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ 12345678 } [
|
2007-09-20 18:09:08 -04:00
|
|
|
12345678 "dump" get 0 set-alien-signed-4
|
|
|
|
"dump" get 0 alien-signed-4
|
|
|
|
] unit-test
|
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ 12345678901234567 } [
|
2007-09-20 18:09:08 -04:00
|
|
|
12345678901234567 "dump" get 0 set-alien-signed-8
|
|
|
|
"dump" get 0 alien-signed-8
|
|
|
|
] unit-test
|
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ -1 } [
|
2007-09-20 18:09:08 -04:00
|
|
|
-1 "dump" get 0 set-alien-signed-8
|
|
|
|
"dump" get 0 alien-signed-8
|
|
|
|
] unit-test
|
|
|
|
|
|
|
|
cell 8 = [
|
2011-11-23 21:49:33 -05:00
|
|
|
[ 0x123412341234 ] [
|
2007-09-20 18:09:08 -04:00
|
|
|
8 <byte-array>
|
2011-11-23 21:49:33 -05:00
|
|
|
0x123412341234 over 0 set-alien-signed-8
|
2007-09-20 18:09:08 -04:00
|
|
|
0 alien-signed-8
|
|
|
|
] unit-test
|
2014-09-16 11:14:39 -04:00
|
|
|
|
2011-11-23 21:49:33 -05:00
|
|
|
[ 0x123412341234 ] [
|
2007-09-20 18:09:08 -04:00
|
|
|
8 <byte-array>
|
2011-11-23 21:49:33 -05:00
|
|
|
0x123412341234 over 0 set-alien-signed-cell
|
2007-09-20 18:09:08 -04:00
|
|
|
0 alien-signed-cell
|
|
|
|
] unit-test
|
|
|
|
] when
|
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ "ALIEN: 1234" } [ 0x1234 <alien> unparse ] unit-test
|
2007-09-28 04:02:06 -04:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ } [ 0 B{ 1 2 3 } <displaced-alien> drop ] unit-test
|
2007-09-29 23:57:29 -04:00
|
|
|
|
2008-02-06 14:47:19 -05:00
|
|
|
[ 0 B{ 1 2 3 } <displaced-alien> alien-address ] must-fail
|
2007-09-28 04:02:06 -04:00
|
|
|
|
2008-02-06 14:47:19 -05:00
|
|
|
[ 1 1 <displaced-alien> ] must-fail
|
2007-11-07 19:26:39 -05:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ f } [ 1 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
|
2007-11-07 19:26:39 -05:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ f } [ 2 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
|
2008-07-04 23:36:55 -04:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ t } [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> underlying>> byte-array? ] unit-test
|
2008-07-04 23:36:55 -04:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ "( displaced alien )" } [ 1 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
|
2008-03-18 18:46:25 -04:00
|
|
|
|
2009-02-20 21:51:13 -05:00
|
|
|
SYMBOL: initialize-test
|
|
|
|
|
|
|
|
f initialize-test set-global
|
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ 31337 } [ initialize-test [ 31337 ] initialize-alien ] unit-test
|
2009-02-20 21:51:13 -05:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ 31337 } [ initialize-test [ 69 ] initialize-alien ] unit-test
|
2009-02-20 21:51:13 -05:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ } [ initialize-test get BAD-ALIEN >>alien drop ] unit-test
|
2009-02-20 21:51:13 -05:00
|
|
|
|
2015-07-02 20:28:17 -04:00
|
|
|
{ 7575 } [ initialize-test [ 7575 ] initialize-alien ] unit-test
|
2009-04-04 21:21:41 -04:00
|
|
|
|
2016-03-29 23:43:46 -04:00
|
|
|
{ { BAD-ALIEN } } [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } sets:members ] unit-test
|
2014-09-16 11:14:39 -04:00
|
|
|
|
|
|
|
! Generate callbacks until the whole callback-heap is full, then free
|
|
|
|
! them. Do it ten times in a row for good measure.
|
|
|
|
: produce-until-error ( quot -- error seq )
|
|
|
|
'[ [ @ t ] [ f ] recover ] [ ] produce ; inline
|
|
|
|
|
|
|
|
SYMBOL: foo
|
|
|
|
|
|
|
|
: fill-and-free-callback-heap ( -- )
|
|
|
|
[ \ foo 33 <callback> ] produce-until-error nip [ free-callback ] each ;
|
|
|
|
|
2014-09-17 06:26:00 -04:00
|
|
|
{ } [
|
2014-09-16 11:14:39 -04:00
|
|
|
10 [ fill-and-free-callback-heap ] times
|
|
|
|
] unit-test
|
2014-09-17 06:26:00 -04:00
|
|
|
|
|
|
|
: <cb-creator> ( -- alien )
|
|
|
|
\ int { pointer: void pointer: void } \ cdecl
|
|
|
|
[ 2drop 37 ] alien-callback ;
|
|
|
|
|
|
|
|
: call-cb ( -- ret )
|
2014-10-22 06:24:44 -04:00
|
|
|
f f <cb-creator> [
|
|
|
|
\ int { pointer: void pointer: void } \ cdecl
|
|
|
|
alien-indirect
|
|
|
|
] with-callback ;
|
|
|
|
|
|
|
|
! This function shouldn't leak
|
|
|
|
{ t } [
|
|
|
|
callback-room occupied>>
|
|
|
|
call-cb drop
|
|
|
|
callback-room occupied>> =
|
|
|
|
] unit-test
|
2014-09-17 06:26:00 -04:00
|
|
|
|
|
|
|
! Will fail if the callbacks cache gets out of sync
|
|
|
|
{ 37 37 } [
|
2014-10-22 06:24:44 -04:00
|
|
|
call-cb
|
2014-09-17 06:26:00 -04:00
|
|
|
fill-and-free-callback-heap
|
2014-10-22 06:24:44 -04:00
|
|
|
call-cb
|
2014-09-17 06:26:00 -04:00
|
|
|
] unit-test
|
2016-08-03 04:53:48 -04:00
|
|
|
|
|
|
|
[ void { } cdecl [ ] alien-assembly ] [ callsite-not-compiled? ] must-fail-with
|
|
|
|
[ void f "flor" { } alien-invoke ] [ callsite-not-compiled? ] must-fail-with
|