core/continuations/continuations-tests.factor

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