core/continuations/continuations-tests.factor

   1 USING: kernel math namespaces io tools.test sequences vectors
   2 continuations debugger parser memory arrays words
   3 kernel.private accessors eval ;
   4 IN: continuations.tests
   5
   6 : (callcc1-test)
   7     swap 1- tuck swap ?push
   8     over 0 = [ "test-cc" get continue-with ] when
   9     (callcc1-test) ;
  10
  11 : callcc1-test ( x -- list )
  12     [
  13         "test-cc" set V{ } clone (callcc1-test)
  14     ] callcc1 nip ;
  15
  16 : callcc-namespace-test ( -- ? )
  17     [
  18         "test-cc" set
  19         5 "x" set
  20         [
  21             6 "x" set "test-cc" get continue
  22         ] with-scope
  23     ] callcc0 "x" get 5 = ;
  24
  25 [ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test
  26 [ t ] [ callcc-namespace-test ] unit-test
  27
  28 [ 5 throw ] [ 5 = ] must-fail-with
  29
  30 [ t ] [
  31     [ "Hello" throw ] ignore-errors
  32     error get-global
  33     "Hello" =
  34 ] unit-test
  35
  36 "!!! The following error is part of the test" print
  37
  38 [ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test
  39
  40 "!!! The following error is part of the test" print
  41
  42 [ ] [ [ [ "2 car" ] eval ] try ] unit-test
  43
  44 [ f throw ] must-fail
  45
  46 ! Weird PowerPC bug.
  47 [ ] [
  48     [ "4" throw ] ignore-errors
  49     gc
  50     gc
  51 ] unit-test
  52
  53 [ f ] [ { } kernel-error? ] unit-test
  54 [ f ] [ { "A" "B" } kernel-error? ] unit-test
  55
  56 ! ! See how well callstack overflow is handled
  57 ! [ clear drop ] must-fail
  58 !
  59 ! : callstack-overflow callstack-overflow f ;
  60 ! [ callstack-overflow ] must-fail
  61
  62 : don't-compile-me { } [ ] each ;
  63
  64 : foo callstack "c" set 3 don't-compile-me ;
  65 : bar 1 foo 2 ;
  66
  67 [ 1 3 2 ] [ bar ] unit-test
  68
  69 [ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test
  70
  71 [ 1 ] [ "c" get innermost-frame-scan ] unit-test
  72
  73 SYMBOL: always-counter
  74 SYMBOL: error-counter
  75
  76 [
  77     0 always-counter set
  78     0 error-counter set
  79
  80     [ ] [ always-counter inc ] [ error-counter inc ] cleanup
  81
  82     [ 1 ] [ always-counter get ] unit-test
  83     [ 0 ] [ error-counter get ] unit-test
  84
  85     [
  86         [ "a" throw ]
  87         [ always-counter inc ]
  88         [ error-counter inc ] cleanup
  89     ] [ "a" = ] must-fail-with
  90
  91     [ 2 ] [ always-counter get ] unit-test
  92     [ 1 ] [ error-counter get ] unit-test
  93
  94     [
  95         [ ]
  96         [ always-counter inc "a" throw ]
  97         [ error-counter inc ] cleanup
  98     ] [ "a" = ] must-fail-with
  99
 100     [ 3 ] [ always-counter get ] unit-test
 101     [ 1 ] [ error-counter get ] unit-test
 102 ] with-scope
 103
 104 [ ] [ [ return ] with-return ] unit-test
 105
 106 [ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with
 107
 108 [ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
 109
 110 \ with-datastack must-infer