core/alien/alien-tests.factor

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