languages/tcl/t/tcl_pir_compiler.t

   1 #!perl
   2
   3 # Copyright (C) 2005-2007, The Perl Foundation.
   4 # $Id$
   5
   6 use strict;
   7 use warnings;
   8 use lib qw(tcl/lib ./lib ../lib ../../lib ../../../lib);
   9
  10 use Parrot::Test tests => 7;
  11 use Test::More;
  12
  13 pir_output_is( <<'CODE', <<'OUTPUT', "test tcl compiler, verify double call works" );
  14   .sub main :main
  15      load_bytecode "languages/tcl/runtime/tcllib.pbc"
  16      .local pmc tcl_compiler,compiled_sub
  17      tcl_compiler = compreg "TCL"
  18      compiled_sub = tcl_compiler("puts {ok 1}")
  19      compiled_sub()
  20      compiled_sub = tcl_compiler("puts {ok 2}")
  21      compiled_sub()
  22   .end
  23 CODE
  24 ok 1
  25 ok 2
  26 OUTPUT
  27
  28 pir_output_is( <<'CODE', <<'OUTPUT', "test tcl compiler global variable interop" );
  29 .HLL 'Tcl', 'tcl_group'
  30   .sub main :main
  31      load_bytecode 'languages/tcl/runtime/tcllib.pbc'
  32      .local pmc tcl_compiler,compiled_sub
  33      $P1 = new 'String'
  34      $P1 = 'ok 1'
  35      store_global '$a', $P1
  36      tcl_compiler = compreg 'TCL'
  37      compiled_sub = tcl_compiler("puts $a")
  38      compiled_sub()
  39   .end
  40 CODE
  41 ok 1
  42 OUTPUT
  43
  44 pir_output_is( <<'CODE', <<'OUTPUT', "pass arguments to a tcl proc from PIR" );
  45 .HLL 'Tcl', 'tcl_group'
  46 .sub main :main
  47
  48   load_bytecode 'languages/tcl/runtime/tcllib.pbc'
  49
  50   $P0 = compreg 'TCL'
  51   $P1 = $P0('proc _tmp {a} {puts $a}')
  52   $P1()
  53
  54   $P2 = find_global '&_tmp'
  55
  56   $P3 = new 'String'
  57   $P3 = 'hello'
  58   $P2($P3)
  59 .end
  60 CODE
  61 hello
  62 OUTPUT
  63
  64 pir_output_is( <<'CODE', <<'OUTPUT', "invoke argless tcl proc from PIR" );
  65 .sub _main :main
  66   load_bytecode "languages/tcl/runtime/tcllib.pbc"
  67   $S1 = 'proc hey {} { puts 11 }; hey; '
  68   $P1 = compreg 'TCL'
  69   $P0 = $P1($S1)
  70   $P0()
  71 .end
  72 CODE
  73 11
  74 OUTPUT
  75
  76 pir_output_is( <<'CODE', <<'OUTPUT', "Verify HLL autoboxing: Int" );
  77 .HLL 'Tcl', 'tcl_group'
  78 .sub _main :main
  79   $P1 = test()
  80   $S1 = typeof $P1
  81   say $S1
  82 .end
  83 .sub test
  84   .return (1)
  85 .end
  86 CODE
  87 TclInt
  88 OUTPUT
  89
  90 pir_output_is( <<'CODE', <<'OUTPUT', "Verify HLL autoboxing: String" );
  91 .HLL 'Tcl', 'tcl_group'
  92 .sub _main :main
  93   $P1 = test()
  94   $S1 = typeof $P1
  95   say $S1
  96 .end
  97 .sub test
  98   .return ("coke")
  99 .end
 100 CODE
 101 TclString
 102 OUTPUT
 103
 104 pir_output_is( <<'CODE', <<'OUTPUT', "Verify HLL autoboxing: Float" );
 105 .HLL 'Tcl', 'tcl_group'
 106 .sub _main :main
 107   $P1 = test()
 108   $S1 = typeof $P1
 109   say $S1
 110 .end
 111 .sub test
 112   .return (8.14)
 113 .end
 114 CODE
 115 TclFloat
 116 OUTPUT
 117
 118 # Local Variables:
 119 #   mode: cperl
 120 #   cperl-indent-level: 4
 121 #   fill-column: 100
 122 # End:
 123 # vim: expandtab shiftwidth=4: