t/library/coroutine.t

   1 #!./parrot
   2 # Copyright (C) 2006-2008, Parrot Foundation.
   3 # $Id$
   4
   5 =head1 NAME
   6
   7 t/library/coroutine.t -- Test the Parrot::Coroutine class
   8
   9 =head1 SYNOPSIS
  10
  11   ./parrot t/library/coroutine.t
  12
  13 =head1 DESCRIPTION
  14
  15 This script tests the C<Parrot::Coroutine> class using an implementation of the
  16 "same fringe" problem.
  17
  18 Note:  In order to see how coroutine calling works in detail, insert
  19 C<trace 4> before and C<trace 0> after one of the C<same_fringe> calls
  20 in the body of the main program.
  21
  22 =head1 SEE ALSO
  23
  24 L<http://swiss.csail.mit.edu/classes/symbolic/spring06/psets/ps6/samefringe.scm>
  25 -- a collection of "same fringe" implementations in Scheme.
  26
  27 =cut
  28
  29 .const int N_TESTS = 6
  30
  31 .loadlib 'io_ops'
  32
  33 ## Build an N-ary tree (where N is passed as node_width) of the specified depth,
  34 ## with the leaves being consecutive integer PMCs from start but less than N.
  35 ## The tree will be complete iff end-start+1 == node_width^depth.
  36 .sub make_nary_tree
  37         .param int start
  38         .param int end
  39         .param int node_width
  40         .param int depth
  41
  42         .local pmc result
  43         if depth goto deeper
  44         result = new 'Undef'
  45         result = start
  46         inc start
  47         goto done
  48 deeper:
  49         result = new 'ResizablePMCArray'
  50         dec depth
  51         .local int i
  52         i = 0
  53 next:
  54         if i >= node_width goto done
  55         if start > end goto done
  56         ($P0, start) = make_nary_tree(start, end, node_width, depth)
  57         push result, $P0
  58         inc i
  59         goto next
  60 done:
  61         .return (result, start)
  62 .end
  63
  64 ## non-coroutine traversal, for debugging.
  65 .sub enumerate_tree
  66         .param pmc tree_node
  67         .param int depth :optional
  68         .param int depth_p :opt_flag
  69
  70         if depth_p goto have_depth
  71         depth = 0
  72 have_depth:
  73         inc depth
  74
  75         $I0 = isa tree_node, 'ResizablePMCArray'
  76         if $I0 goto recur
  77         print "[leaf "
  78         print tree_node
  79         print "]\n"
  80 done:
  81         .return ()
  82
  83 recur:
  84         ## Loop through array elements, recurring on each.
  85         .local int size, i
  86         i = 0
  87         size = tree_node
  88 again:
  89         if i >= size goto done
  90         print "[recur: depth "
  91         print depth
  92         print ' elt '
  93         print i
  94         print "]\n"
  95         $P1 = tree_node[i]
  96         enumerate_tree($P1, depth)
  97         inc i
  98         goto again
  99 .end
 100
 101 ## Recursive coroutine to enumerate tree elements.  Each element that is not a
 102 ## FixedPMCArray is yielded in turn.
 103 .sub coro_enumerate_tree
 104         .param pmc coro
 105         .param pmc tree_node
 106         .param int depth :optional
 107         .param int depth_p :opt_flag
 108
 109         if depth_p goto have_depth
 110         depth = 0
 111 have_depth:
 112         inc depth
 113
 114         $I0 = isa tree_node, 'FixedPMCArray'
 115         if $I0 goto recur
 116         ## print "[leaf "
 117         ## print tree_node
 118         ## print "]\n"
 119         coro.'yield'(tree_node)
 120         .return ()
 121
 122 recur:
 123         ## Loop through array elements, recurring on each.
 124         .local int size, i
 125         i = 0
 126         size = tree_node
 127 again:
 128         if i >= size goto done
 129         ## print "[coro recur: depth "
 130         ## print depth
 131         ## print ' elt '
 132         ## print i
 133         ## print "]\n"
 134         $P1 = tree_node[i]
 135         coro_enumerate_tree(coro, $P1, depth)
 136         inc i
 137         goto again
 138 done:
 139         .return ()
 140 .end
 141
 142 ## Solution to the "same fringe" problem that uses coroutines to enumerate each
 143 ## of two passed trees of numbers.  Returns 1 if the trees have the same fringe,
 144 ## else 0.
 145 .sub same_fringe
 146         .param pmc tree1
 147         .param pmc tree2
 148
 149         .local pmc coro_class
 150     coro_class = get_class ['Parrot'; 'Coroutine']
 151     unless null coro_class goto found
 152         printerr "Bug:  Can't find ['Parrot'; 'Coroutine'] class.\n"
 153         die 5, 1
 154 found:
 155         .local pmc coro1, coro2
 156         .const 'Sub' coro_sub = "coro_enumerate_tree"
 157         coro1 = coro_class.'new'('initial_sub' => coro_sub)
 158         coro2 = coro_class.'new'('initial_sub' => coro_sub)
 159         ($P0 :optional, $I0 :opt_flag) = coro1.'resume'(coro1, tree1)
 160         ($P1 :optional, $I1 :opt_flag) = coro2.'resume'(coro2, tree2)
 161
 162 loop:
 163         if $I0 goto got_first
 164         if $I1 goto not_equal
 165         goto equal
 166 got_first:
 167         unless $I1 goto not_equal
 168
 169         ## now have results from both.
 170         ## print "[got "
 171         ## print $P0
 172         ## print ' and '
 173         ## print $P1
 174         ## print "]\n"
 175         if $P0 != $P1 goto not_equal
 176         ## set up for the next iteration.
 177         ($P0 :optional, $I0 :opt_flag) = coro1.'resume'()
 178         ($P1 :optional, $I1 :opt_flag) = coro2.'resume'()
 179         goto loop
 180 not_equal:
 181         .return (0)
 182 equal:
 183         .return (1)
 184 .end
 185
 186 .sub main :main
 187         load_bytecode 'Test/Builder.pbc'
 188         .local pmc test
 189         test = new [ 'Test'; 'Builder' ]
 190         test.'plan'(N_TESTS)
 191
 192         push_eh cant_load
 193         load_bytecode 'Parrot/Coroutine.pbc'
 194         pop_eh
 195         test.'ok'(1, 'loaded bytecode')
 196
 197         ## grow some trees for traversal.
 198         .local pmc binary, binary_4, ternary, ternary_2
 199         binary = make_nary_tree(1, 8, 2, 3)
 200         ternary = make_nary_tree(1, 8, 3, 2)
 201         binary_4 = make_nary_tree(1, 16, 2, 4)
 202         ## now make a "damaged" one that will be different.
 203         ternary_2 = make_nary_tree(1, 8, 3, 2)
 204         $P0 = ternary_2[1]
 205         $P0 = $P0[0]
 206         ternary_2[1] = $P0
 207         ## enumerate_tree(ternary_2)
 208         test.'ok'(1, 'made test trees.')
 209
 210         $I0 = same_fringe(binary, binary)
 211         test.'ok'($I0, 'binary [[[1,2],[3,4]],[[5,6],[7,8]]] vs. itself')
 212         $I0 = same_fringe(binary, binary_4)
 213         $I0 = 1 - $I0
 214         test.'ok'($I0, 'binary 1..8 vs. binary 1..16')
 215         $I0 = same_fringe(binary, ternary)
 216         test.'ok'($I0, 'binary 1..8 vs. ternary [[1,2,3],[4,5,6],[7,8]]')
 217         $I0 = same_fringe(binary, ternary_2)
 218         $I0 = 1 - $I0
 219         test.'ok'($I0, 'binary 1..8 vs. ternary [[1,2,3],4,[7,8]]')
 220         test.'finish'()
 221         end
 222 cant_load:
 223         test.'ok'(0, 'Load failed')
 224         test.'finish'()
 225 .end
 226
 227 # Local Variables:
 228 #   mode: pir
 229 #   fill-column: 100
 230 # End:
 231 # vim: expandtab shiftwidth=4 ft=pir: