t/compilers/pge/pge.t

   1 #! perl
   2 # Copyright (C) 2001-2005, Parrot Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( t . lib ../lib ../../lib );
   8 use Test::More;
   9 use Parrot::Test qw/ no_plan /;
  10 use Parrot::Test::PGE;
  11
  12 =head1 NAME
  13
  14 t/library/pge.t
  15
  16 =head1 SYNOPSIS
  17
  18         % prove -Ilib t/library/pge.t
  19
  20 =head1 DESCRIPTION
  21
  22 Parrot Grammar Engine basic tests
  23
  24 =cut
  25
  26 ## definition of PGE public api
  27 ## data format like: filename => { 'namespace' => [list of subs], ... },
  28 my $ns_subs = {
  29     'PGE.pir'       => { 'PGE'      => [qw/ /], },
  30     'PGE/Exp.pir'   => { 'PGE::Exp' => [qw/ root_pir /], },
  31     'PGE/Match.pir' => {
  32         'PGE::Match' => [
  33             qw/
  34                 next from to __get_bool __get_integer __get_number
  35                 __get_string __get_pmc_keyed_int __set_pmc_keyed_int
  36                 __delete_keyed_int __defined_keyed_int list hash
  37                 /
  38         ],
  39     },
  40     'PGE/OPTable.pir' => { 'PGE::OPTable' => [qw/ newtok parse /], },
  41     'PGE/Perl6Regex.pir' => {
  42         'PGE'          => [qw/ /],
  43         'PGE::Exp'     => [qw/ /],
  44         'PGE::Perl6Regex' => [qw/ /],
  45     },
  46     'PGE/Regex.pir' => {
  47         'PGE::Match' => [
  48             qw/
  49                 ident null fail upper lower alpha digit xdigit space
  50                 print graph blank cntrl punct alnum sp lt gt dot ws before
  51                 /
  52         ],
  53     },
  54     'PGE/TokenHash.pir' => { 'PGE::TokenHash' => [qw/ /], },
  55 };
  56
  57 ## populate_namespaces -- populate many namespaces with a subname
  58 ## data format like: subname => [qw/ list of namespaces /],
  59 ## my $p6r_subs = { p6analyze => [qw/ Literal /], };
  60 ## populate_namespaces( $ns_subs, $p6r_subs, 'PGE/Perl6Regex.pir', 'PGE::Exp' );
  61 sub populate_namespaces {
  62     my ( $outdata_ref, $indata_ref, $filekey, $nsprefix ) = @_;
  63     for my $key ( sort keys %$indata_ref ) {
  64         push @{ $outdata_ref->{$filekey}{ $nsprefix . '::' . $_ } } => $key
  65             for @{ $indata_ref->{$key} };
  66     }
  67 }
  68
  69 my $PRE = <<'PRE';
  70 .sub 'main' :main
  71         load_bytecode 'PGE.pbc'
  72 PRE
  73 my $POST = <<'POST';
  74         goto OK
  75 NOK:print "not "
  76 OK: print "ok"
  77 END:print "\n"
  78 .end
  79 POST
  80
  81 # 1
  82 pir_output_is( <<'CODE'. $POST, <<OUT, 'load_bytecode PGE.pbc' );
  83 .sub 'main' :main
  84         load_bytecode 'PGE.pbc'
  85 CODE
  86 ok
  87 OUT
  88
  89 # 2
  90 pir_output_is( <<'CODE'. $POST, <<OUT, 'load_bytecode PGE.pbc 2x' );
  91 .sub 'main' :main
  92         load_bytecode 'PGE.pbc'
  93         load_bytecode 'PGE.pbc'
  94 CODE
  95 ok
  96 OUT
  97
  98 ## compiler registration
  99 for my $compiler (qw/ PGE::Perl6Regex PGE::Perl6Regex PGE::P5Regex PGE::Glob /) {
 100     pir_output_is( <<"CODE". $POST, <<OUT, 'compreg "$compiler"' );
 101 .sub 'main' :main
 102         load_bytecode 'PGE.pbc'
 103         \$P0 = compreg '$compiler'
 104 CODE
 105 ok
 106 OUT
 107 }
 108
 109 ## public api tests
 110 for my $file ( sort keys %$ns_subs ) {
 111     for my $ns ( sort keys %{ $ns_subs->{$file} } ) {
 112         for my $sub ( sort @{ $ns_subs->{$file}{$ns} } ) {
 113             ## get_global
 114             pir_output_is( <<CODE. $POST, <<OUT, 'get_global $file: ($ns:: $sub)' );
 115 .sub 'main' :main
 116         load_bytecode 'PGE.pbc'
 117         .local pmc sub
 118         sub = get_global ['$ns'], '$sub'
 119 CODE
 120 ok
 121 OUT
 122         }
 123     }
 124 }
 125
 126 # Local Variables:
 127 #   mode: cperl
 128 #   cperl-indent-level: 4
 129 #   fill-column: 100
 130 # End:
 131 # vim: expandtab shiftwidth=4: