basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

   1 USING: tools.test compiler.tree
   2 compiler.tree.builder compiler.tree.recursive
   3 compiler.tree.normalization compiler.tree.propagation
   4 compiler.tree.cleanup compiler.tree.escape-analysis
   5 compiler.tree.tuple-unboxing compiler.tree.checker
   6 compiler.tree.def-use kernel accessors sequences math
   7 math.private sorting math.order binary-search sequences.private
   8 slots.private ;
   9 IN: compiler.tree.tuple-unboxing.tests
  10
  11 : test-unboxing ( quot -- )
  12     build-tree
  13     analyze-recursive
  14     normalize
  15     propagate
  16     cleanup
  17     escape-analysis
  18     unbox-tuples
  19     check-nodes ;
  20
  21 TUPLE: cons { car read-only } { cdr read-only } ;
  22
  23 TUPLE: empty-tuple ;
  24
  25 {
  26     [ 1 2 cons boa [ car>> ] [ cdr>> ] bi ]
  27     [ empty-tuple boa drop ]
  28     [ cons boa [ car>> ] [ cdr>> ] bi ]
  29     [ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
  30     [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
  31     [ 2 cons boa { [ ] [ ] } dispatch ]
  32     [ dup [ drop f ] [ "A" throw ] if ]
  33     [ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
  34     [ [ ] [ ] curry curry call ]
  35     [ 1 cons boa over [ "A" throw ] when car>> ]
  36     [ [ <=> ] sort ]
  37     [ [ <=> ] with search ]
  38 } [ [ ] swap [ test-unboxing ] curry unit-test ] each
  39
  40 ! A more complicated example
  41 : impeach-node ( quot: ( node -- ) -- )
  42     [ call ] keep impeach-node ; inline recursive
  43
  44 : bleach-node ( quot: ( node -- ) -- )
  45     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
  46
  47 [ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test
  48
  49 TUPLE: box { i read-only } ;
  50
  51 : box-test ( m -- n )
  52     dup box-test i>> swap box-test drop box boa ; inline recursive
  53
  54 [ ] [ [ T{ box f 34 } box-test i>> ] test-unboxing ] unit-test