core/alien/alien-tests.factor

   1 USING: accessors alien alien.accessors alien.c-types
   2 alien.syntax byte-arrays continuations kernel layouts math
   3 namespaces prettyprint sequences tools.memory tools.test ;
   4 QUALIFIED: sets
   5 IN: alien.tests
   6
   7 { t } [ -1 <alien> alien-address 0 > ] unit-test
   8
   9 { t } [ 0 <alien> 0 <alien> = ] unit-test
  10 { f } [ 0 <alien> 1024 <alien> = ] unit-test
  11 { f } [ "hello" 1024 <alien> = ] unit-test
  12 { f } [ 0 <alien> ] unit-test
  13 { f } [ 0 f <displaced-alien> ] unit-test
  14
  15 ! Testing the various bignum accessor
  16 10 <byte-array> "dump" set
  17
  18 [ "dump" get alien-address ] must-fail
  19
  20 { 123 } [
  21     123 "dump" get 0 set-alien-signed-1
  22     "dump" get 0 alien-signed-1
  23 ] unit-test
  24
  25 { 12345 } [
  26     12345 "dump" get 0 set-alien-signed-2
  27     "dump" get 0 alien-signed-2
  28 ] unit-test
  29
  30 { 12345678 } [
  31     12345678 "dump" get 0 set-alien-signed-4
  32     "dump" get 0 alien-signed-4
  33 ] unit-test
  34
  35 { 12345678901234567 } [
  36     12345678901234567 "dump" get 0 set-alien-signed-8
  37     "dump" get 0 alien-signed-8
  38 ] unit-test
  39
  40 { -1 } [
  41     -1 "dump" get 0 set-alien-signed-8
  42     "dump" get 0 alien-signed-8
  43 ] unit-test
  44
  45 cell 8 = [
  46     [ 0x123412341234 ] [
  47       8 <byte-array>
  48       0x123412341234 over 0 set-alien-signed-8
  49       0 alien-signed-8
  50     ] unit-test
  51
  52     [ 0x123412341234 ] [
  53       8 <byte-array>
  54       0x123412341234 over 0 set-alien-signed-cell
  55       0 alien-signed-cell
  56     ] unit-test
  57 ] when
  58
  59 { "ALIEN: 1234" } [ 0x1234 <alien> unparse ] unit-test
  60
  61 { } [ 0 B{ 1 2 3 } <displaced-alien> drop ] unit-test
  62
  63 [ 0 B{ 1 2 3 } <displaced-alien> alien-address ] must-fail
  64
  65 [ 1 1 <displaced-alien> ] must-fail
  66
  67 { f } [ 1 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
  68
  69 { f } [ 2 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
  70
  71 { t } [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> underlying>> byte-array? ] unit-test
  72
  73 { "( displaced alien )" } [ 1 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
  74
  75 SYMBOL: initialize-test
  76
  77 f initialize-test set-global
  78
  79 { 31337 } [ initialize-test [ 31337 ] initialize-alien ] unit-test
  80
  81 { 31337 } [ initialize-test [ 69 ] initialize-alien ] unit-test
  82
  83 { } [ initialize-test get BAD-ALIEN >>alien drop ] unit-test
  84
  85 { 7575 } [ initialize-test [ 7575 ] initialize-alien ] unit-test
  86
  87 { { BAD-ALIEN } } [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } sets:members ] unit-test
  88
  89 ! Generate callbacks until the whole callback-heap is full, then free
  90 ! them. Do it ten times in a row for good measure.
  91 : produce-until-error ( quot -- error seq )
  92     '[ [ @ t ] [ f ] recover ] [ ] produce ; inline
  93
  94 SYMBOL: foo
  95
  96 : fill-and-free-callback-heap ( -- )
  97     [ \ foo 33 <callback> ] produce-until-error nip [ free-callback ] each ;
  98
  99 { } [
 100     10 [ fill-and-free-callback-heap ] times
 101 ] unit-test
 102
 103 : <cb-creator> ( -- alien )
 104     \ int { pointer: void pointer: void } \ cdecl
 105     [ 2drop 37 ] alien-callback ;
 106
 107 : call-cb ( -- ret )
 108     f f <cb-creator> [
 109         \ int { pointer: void pointer: void } \ cdecl
 110         alien-indirect
 111     ] with-callback ;
 112
 113 ! This function shouldn't leak
 114 { t } [
 115     callback-room occupied>>
 116     call-cb drop
 117     callback-room occupied>> =
 118 ] unit-test
 119
 120 ! Will fail if the callbacks cache gets out of sync
 121 { 37 37 } [
 122     call-cb
 123     fill-and-free-callback-heap
 124     call-cb
 125 ] unit-test
 126
 127 [ void { } cdecl [ ] alien-assembly ] [ callsite-not-compiled? ] must-fail-with
 128 [ void f "flor" { } f alien-invoke ] [ callsite-not-compiled? ] must-fail-with