library/test/namespaces.factor

   1 IN: scratchpad
   2 USE: arithmetic
   3 USE: combinators
   4 USE: compiler
   5 USE: inspector
   6 USE: kernel
   7 USE: lists
   8 USE: logic
   9 USE: namespaces
  10 USE: random
  11 USE: stack
  12 USE: stdio
  13 USE: strings
  14 USE: test
  15 USE: words
  16 USE: vocabularies
  17
  18 "Namespace tests." print
  19
  20 [ t ] [ global [ "global" get ] bind global ] [ = ] test-word
  21 [ [ 1 0 0 0 ] ] [ [ >n ] ] [ balance>list ] test-word
  22 [ [ 1 1 0 0 ] ] [ [ get ] ] [ balance>list ] test-word
  23 [ [ 2 0 0 0 ] ] [ [ set ] ] [ balance>list ] test-word
  24 [ [ 0 1 0 0 ] ] [ [ namestack* ] ] [ balance>list ] test-word
  25 [ [ 0 1 0 0 ] ] [ [ namestack ] ] [ balance>list ] test-word
  26 [ [ 1 0 0 0 ] ] [ [ set-namestack* ] ] [ balance>list ] test-word
  27 [ [ 1 0 0 0 ] ] [ [ set-namestack ] ] [ balance>list ] test-word
  28 [ [ 0 1 0 0 ] ] [ [ n> ] ] [ balance>list ] test-word
  29
  30 <namespace> "test-namespace" set
  31
  32 : test-namespace ( -- )
  33     <namespace> dup [ namespace = ] bind ;
  34
  35 : test-this-1 ( -- )
  36     <namespace> dup [ this = ] bind ;
  37
  38 : test-this-2 ( -- )
  39     interpreter dup [ this = ] bind ;
  40
  41 [ t ] [   ] [ test-namespace ] test-word
  42 [ t ] [   ] [ test-this-1    ] test-word
  43 [ t ] [   ] [ test-this-2    ] test-word
  44
  45 ! These stress-test a lot of code.
  46 global describe
  47 "vocabularies" get describe
  48
  49 : namespace-compile ( x -- x )
  50     <namespace> [ "x" set ] extend [ "x" get ] bind ; word must-compile
  51
  52 [ 12 ] [ 12 ] [ namespace-compile ] test-word
  53
  54 ! A compiler bug in tailcalls that manifests with the namestack
  55
  56 : namespace-tail-call-bug ( x -- x )
  57     dup 0 = [
  58         drop
  59     ] [
  60         pred <namespace> [ dup "x" set namespace-tail-call-bug ] bind
  61     ] ifte ; word must-compile
  62
  63 [ f ] [ ] [ 10 namespace-tail-call-bug "x" get 0 = ] test-word
  64
  65 ! Object paths should not resolve further up in the namestack.
  66
  67 <namespace> "test-namespace" set
  68 [ f ]
  69 [ [ "test-namespace" "test-namespace" ] ]
  70 [ object-path ]
  71 test-word
  72
  73 [ f ]
  74 [ [ "alalal" "boobobo" "bah" ] ]
  75 [ object-path ]
  76 test-word
  77
  78 [ t ]
  79 [ this [ ] ]
  80 [ object-path  = ]
  81 test-word
  82
  83 [ t ]
  84 [ "test-word" intern [ "global" "vocabularies" "test" "test-word" ] ]
  85 [ object-path  = ]
  86 test-word
  87
  88 10 "some-global" set
  89 [ f ]
  90 [ ]
  91 [ <namespace> [ f "some-global" set "some-global" get ] bind ]
  92 test-word
  93
  94 ! I did a n> in extend and forgot the obvious case
  95 [ t ] [ "dup" intern dup ] [ [ ] extend = ] test-word
  96
  97 "Namespace tests passed." print