core/continuations/continuations-tests.factor

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