eval.t

#! perl
# Copyright (C) 2001-2005, The Perl Foundation.
# $Id$

use strict;
use warnings;
use lib qw( . lib ../lib ../../lib );
use Test::More;
use Parrot::Test tests => 17;

=head1 NAME

t/pmc/eval.t - Dynamic Code Evaluation

=head1 SYNOPSIS

    % prove t/pmc/eval.t

=head1 DESCRIPTION

Tests on-the-fly PASM, PIR and PAST compilation and invocation.

=cut

pasm_output_is( <<'CODE', <<'OUTPUT', "eval_sc" );
    compreg P1, "PASM"	# get compiler
    set_args "(0)", "print \"in eval\\n\"\nset_returns \"()\"\nreturncc\n"
    get_results "(0)", P0
    invokecc P1			# compile
    invokecc P0			# eval code P0
    print "back again\n"
    end
CODE
in eval
back again
OUTPUT

pasm_output_is( <<'CODE', <<'OUTPUT', "call subs in evaled code " );
    set S5, ".pcc_sub _foo:\n"
    concat S5, "print \"foo\\n\"\n"
    concat S5, "set_returns \"()\"\n"
    concat S5, "returncc\n"
    compreg P1, "PASM"
    set_args "(0)", S5
    invokecc P1
    find_global P0, "_foo"
    invokecc P0
    print "back\n"
    end
CODE
foo
back
OUTPUT

pasm_output_is( <<'CODE', <<'OUTPUT', "call 2 subs in evaled code " );
    set S5, ".pcc_sub _foo:\n"
    concat S5, "print \"foo\\n\"\n"
    concat S5, "set_returns \"()\"\n"
    concat S5, "returncc\n"
    concat S5, ".pcc_sub _bar:\n"
    concat S5, "print \"bar\\n\"\n"
    concat S5, "set_returns \"()\"\n"
    concat S5, "returncc\n"
    compreg P1, "PASM"
    set_args "(0)", S5
    get_results "(0)", P6
    invokecc P1
    find_global P2, "_foo"
    invokecc P2
    print "back\n"
    find_global P2, "_bar"
    invokecc P2
    print "fin\n"
    end
CODE
foo
back
bar
fin
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "PIR compiler sub" );

.sub test :main
    .local NCI compiler
    find_global compiler, "xcompile"
    compreg "XPASM", compiler
    .local pmc my_compiler
    my_compiler = compreg "XPASM"
    .local pmc the_sub
    .local string code
    code = "print \"ok\\n\"\n"
    code .= "set_returns \"()\"\n"
    code .= "returncc\n"
    the_sub = my_compiler("_foo", code)
    the_sub()
    the_sub = global "_foo"
    the_sub()
.end

.sub xcompile
    .param string sub_name
    .param string code
    $S0 = ".pcc_sub "
    $S0 .= sub_name
    $S0 .= ":\n"
    $S0 .= code
    .local NCI pasm_compiler
    pasm_compiler = compreg "PASM"
    # print $S0
    $P0 = pasm_compiler($S0)
    .return($P0)
.end
CODE
ok
ok
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "bug #31467" );

  .sub main :main
     $P1 = new Hash
     $P0 = find_name "_builtin"
     $P1['builtin'] = $P0

     $P2 = compreg "PIR"
     $S0 = ".sub main\nprint \"dynamic\\n\"\n.end\n"
     $P0 = $P2($S0)
     $P1['dynamic'] = $P0

     store_global "funcs", $P1

     $S0 = ".sub main\n$P1 = find_global\"funcs\"\n"
     $S0 .= "$P0 = $P1['dynamic']\n$P0()\n"
     $S0 .= "$P0 = $P1['builtin']\n$P0()\n"
     $S0 .= ".end\n"

     $P2 = compreg "PIR"
     $P0 = $P2($S0)
     $P0()
     end
  .end

  .sub _builtin
      print "builtin\n"
  .end
CODE
dynamic
builtin
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "PIR compiler sub PASM" );
.sub main :main
  register_compiler()

  .local pmc compiler, invokable
  compiler = compreg "PUTS"

  invokable = compiler("ok 1")
  invokable()

.end

.sub register_compiler
  $P0 = find_global "puts"
  compreg "PUTS", $P0
.end

.sub puts
  .param string printme

  .local pmc pasm_compiler, retval
  pasm_compiler = compreg "PASM"

  .local string code

  code = "print \""
  code .= printme
  code .= "\\n\"\n"
  code .= "set_returns \"()\"\n"
  code .= "returncc\n"

  retval = pasm_compiler( code )

  .return (retval)
.end
CODE
ok 1
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "PIR compiler sub PIR" );
.sub main :main
  register_compiler()

  .local pmc compiler, invokable
  compiler = compreg "PUTS"

  invokable = compiler( "ok 1" )
  invokable()

.end

.sub register_compiler
 .local pmc counter
 counter = new Integer
 counter = 0
 store_global "counter", counter

  $P0 = find_global "_puts"
  compreg "PUTS", $P0
.end

.sub _puts
  .param string printme

  .local pmc pir_compiler, retval
  pir_compiler = compreg "PIR"

  .local pmc counter
  counter = find_global "counter"
  inc counter

  .local string code
  code = ".sub anonymous"
  $S0 = counter
  code .= $S0
  code .= " :anon\n"
  code .= "print \""
  code .= printme
  code .= "\\n\"\n"
  code .=".end\n"

  retval = pir_compiler( code )

  .return (retval)
.end
CODE
ok 1
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "eval.get_string" );
.sub main :main

  .local pmc f1, f2
  .local pmc io
  f1 = compi("foo_1", "hello from foo_1")
  $S0 = f1
  io = open "temp.pbc", ">"
  print io, $S0
  close io
  load_bytecode "temp.pbc"
  f2 = compi("foo_2", "hello from foo_2")
  io = open "temp2.pbc", ">"
  print io, f2
  close io
  load_bytecode "temp2.pbc"
.end

.sub compi
  .param string name
  .param string printme
  .local string code
  .local pmc pir_compiler, retval
  pir_compiler = compreg "PIR"
  code = ".sub "
  code .= name
  code .= " :load\n"
  code .= "print \""
  code .= printme
  code .= "\\n\"\n"
  code .= ".end\n"

  retval = pir_compiler(code)
  .return (retval)
.end
CODE
hello from foo_1
hello from foo_2
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "check loaded lib hash" );
.sub main
  load_bytecode "temp.pbc"
  load_bytecode "temp2.pbc"
  .local pmc pbc_hash, interp
  .include 'iglobals.pasm'
  interp = getinterp
  pbc_hash = interp[.IGLOBALS_PBC_LIBS]
  $I0 = elements pbc_hash
  print $I0
  print ' '
  $I1 = exists pbc_hash['temp']
  print $I1
  print ' '
  $I2 = exists pbc_hash['temp2']
  print $I2
  print ' '
  $S0 = pbc_hash['temp2']
  # print $S0          not portable
  $I3 = index $S0, 'temp2.pbc'
  $I4 = isgt $I3, -1
  print $I4
  print_newline
.end
CODE
hello from foo_1
hello from foo_2
2 1 1 1
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "eval.get_string - same file" );
.sub main :main

  .local pmc f1, f2
  .local pmc io
  f1 = compi("foo_1", "hello from foo_1")
  $S0 = f1
  io = open "temp.pbc", ">"
  print io, $S0
  close io
  load_bytecode "temp.pbc"
  f2 = compi("foo_2", "hello from foo_2")
  io = open "temp.pbc", ">"
  print io, f2
  close io
  load_bytecode "temp.pbc"
.end

.sub compi
  .param string name
  .param string printme
  .local string code
  .local pmc pir_compiler, retval
  pir_compiler = compreg "PIR"
  code = ".sub "
  code .= name
  code .= " :load\n"
  code .= "print \""
  code .= printme
  code .= "\\n\"\n"
  code .= ".end\n"

  retval = pir_compiler(code)
  .return (retval)
.end
CODE
hello from foo_1
OUTPUT

END {
    unlink "temp.pbc", "temp2.pbc", "temp.file";
}

pir_output_is( <<'CODE', <<'OUTPUT', "eval.freeze" );
.sub main :main
  .local pmc f, e
  .local pmc io
  f = compi("foo_1", "hello from foo_1")
  $S0 = freeze f
  io = open "temp.file", ">"
  print io, $S0
  close io
  print "written\n"
.end

.sub compi
  .param string name
  .param string printme
  .local string code
  .local pmc pir_compiler, retval
  pir_compiler = compreg "PIR"
  code = ".sub "
  code .= name
  code .= "\n"
  code .= "print \""
  code .= printme
  code .= "\\n\"\n"
  code .= ".end\n"

  retval = pir_compiler(code)
  .return (retval)
.end
CODE
written
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "eval.thaw" );
.sub main :main
    .local pmc io, e
    .local string file
    .local int size
    file = "temp.file"
    .include "stat.pasm"
    size = stat file, .STAT_FILESIZE
    io = open file, "<"
    $S0 = read io, size
    close io
    e = thaw $S0
    e()
    e = find_global "foo_1"
    e()
.end
CODE
hello from foo_1
hello from foo_1
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "eval.freeze+thaw" );
.sub main :main
  .local pmc f, e
  .local pmc io
  f = compi("foo_1", "hello from foo_1")
  $S0 = freeze f
  io = open "temp.file", ">"
  print io, $S0
  close io
  print "written\n"
  "read"()
.end

.sub compi
  .param string name
  .param string printme
  .local string code
  .local pmc pir_compiler, retval
  pir_compiler = compreg "PIR"
  code = ".sub "
  code .= name
  code .= "\n"
  code .= <<"MORE"
  noop
  noop
  noop
  noop
MORE
  code .= "print \""
  code .= printme
  code .= "\\n\"\n"
  code .= ".end\n"

  retval = pir_compiler(code)
  .return (retval)
.end

.sub "read"
    .local pmc io, e
    .local string file
    .local int size
    file = "temp.file"
    .include "stat.pasm"
    size = stat file, .STAT_FILESIZE
    io = open file, "<"
    $S0 = read io, size
    close io
    e = thaw $S0
    e()
    e = find_global "foo_1"
    e()
.end
CODE
written
hello from foo_1
hello from foo_1
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "get_pmc_keyed_int" );
.sub main :main
    .local string code
    .local pmc e, s, compi
    code = <<"EOC"
    .sub foo
    noop
    .end
    .sub bar
    noop
    .end
EOC
    compi = compreg "PIR"
    e  = compi(code)
    s = e[0]
    print s
    print "\n"
    s = e[1]
    print s
    print "\n"
.end
CODE
parrot;foo
parrot;bar
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "catch compile err: RT:#39892" );
.sub main :main
     push_eh handler
     $P2 = compreg "PIR"
     $S0 = <<"EPIR"
  .sub foo
     print a typo
  .end
EPIR
     $P0 = $P2($S0)
     $P0()
     end
handler:
     print "ok\n"
.end
CODE
ok
OUTPUT

open my $TEMP, '>', "temp.pir" or die "can't open 'temp.pir': $!";
END { unlink "temp.pir" }
print $TEMP <<PIR;
  .sub foo
     print a typo
  .end
PIR
close $TEMP;

pir_output_like( <<'CODE', <<'OUTPUT', "compile err in load_bytecode" );
.sub main :main
     load_bytecode "temp.pir"
     print "never\n"
     end
.end
CODE
/undefined identifier/
OUTPUT

pir_output_is( <<'CODE', <<'OUTPUT', "catch compile err in load_bytecode" );
.sub main :main
     push_eh handler
     load_bytecode "temp.pir"
     print "never\n"
     end
handler:
     print "ok\n"
.end
CODE
ok
OUTPUT

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4: