Author: pmichaud
Date: Thu Apr 20 22:05:29 2006
New Revision: 12387
Added:
trunk/t/compilers/pge/01-codestring.t
trunk/t/compilers/pge/03-optable.t
Removed:
trunk/t/compilers/pge/pge_optable.t
Modified:
trunk/MANIFEST
trunk/compilers/pge/PGE/CodeString.pir
Log:
[PGE]: Small cleanups in preparation for larger changes
* Added pod documentation to CodeString.pir
* Added tests for CodeString.pir in 01-codestring.t
* Renamed pge_optable.t to 03-optable.t
* More to come
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Thu Apr 20 22:05:29 2006
@@ -2051,10 +2051,11 @@
t/compilers/imcc/syn/pod.t []
t/compilers/imcc/syn/scope.t []
t/compilers/imcc/syn/tail.t []
+t/compilers/pge/01-codestring.t []
+t/compilers/pge/03-optable.t []
t/compilers/pge/pge.t []
t/compilers/pge/pge_examples.t []
t/compilers/pge/pge_globs.t []
-t/compilers/pge/pge_optable.t []
t/compilers/pge/pge_util.t []
t/compilers/pge/pge-hs.t []
t/compilers/pge/p5regexp/p5rx.t []
Modified: trunk/compilers/pge/PGE/CodeString.pir
==============================================================================
--- trunk/compilers/pge/PGE/CodeString.pir (original)
+++ trunk/compilers/pge/PGE/CodeString.pir Thu Apr 20 22:05:29 2006
@@ -1,27 +1,83 @@
=head1 NAME
-PGE::CodeString - object to build (PIR) code segments
+CodeString - object to build (PIR) code segments
+
+=head1 SYNOPSIS
+
+ .local pmc code
+ code = new 'CodeString'
+
+ code.emit(" $P0 = %0 * %1", '$P21', '3')
+ code.emit(" %l:", 'l' => 'label')
+
+ print code
=head1 DESCRIPTION
+C<CodeString> is a class intended to simplify the process of
+emitting code strings. Ideally this will eventually
+become a form of "CodeBuffer" that is more efficient
+than string concatenation, but for now it works well
+enough for me.
+
+The primary method for C<CodeString> objects is C<emit>,
+which appends a line (or lines) of code to the string
+according to a format parameter. The line can contain
+substitution markers (ala printf) that indicate where
+other parameters to the call should be placed.
+
+Note that C<CodeString> is just a subclass of Parrot's
+native C<String> class, so it's easy to combine CodeString
+objects with other strings outside of the C<emit> method.
+
+=head2 Functions
+
+=over 4
+
+=item C<_onload()>
+
+Initializes the C<CodeString> class.
+
=cut
.include 'cclass.pasm'
-.namespace [ "PGE::CodeString" ]
+.namespace [ 'PGE::CodeString' ]
-.sub "__onload" :load
- $P0 = getclass "String"
- $P1 = subclass $P0, "PGE::CodeString"
+.sub '__onload' :load
+ $P0 = getclass 'String'
+ $P1 = subclass $P0, 'PGE::CodeString'
$P0 = new .Integer
$P0 = 10
- store_global "PGE::CodeString", "$!serno", $P0
+ store_global "$!serno", $P0
.return ()
.end
-.sub "emit" :method
+=item C<emit(string fmt [, pmc args ] [, pmc hash ])>
+
+Add a line to a C<CodeString> object according to C<fmt>.
+The C<fmt> string can contain any number of "%-replacements"
+which are replaced by the corresponding values from C<args>
+or C<hash> prior to being appended to the string. (Here
+C<args> is a slurpy array, and C<hash> is a slurpy hash.)
+
+The currently defined replacements include:
+
+ %0 %1 ... %9 the value from the args array at index 0..9
+ %, the values of the args array separated by commas
+ %% a percent sign
+
+A percent-sign followed by any other character that is a hash
+key receives the value of the hash element.
+
+A newline is automatically added to the end of the fmt.
+
+=cut
+
+
+.sub 'emit' :method
.param string fmt
.param pmc args :slurpy
.param pmc hash :slurpy :named
@@ -77,6 +133,16 @@
.end
+=item C<unique([string fmt])>
+
+Each call to C<unique> returns a unique number, or if a C<fmt>
+parameter is given it returns a unique string beginning with
+C<fmt>. (This may eventually be generalized to allow
+uniqueness anywhere in the string.) The function starts
+counting at 10 (so that the values 0..9 can be considered "safe").
+
+=cut
+
.sub 'unique' :method
.param string fmt :optional
.param int has_fmt :opt_flag
@@ -84,7 +150,7 @@
if has_fmt goto unique_1
fmt = ''
unique_1:
- $P0 = find_global "PGE::CodeString", "$!serno"
+ $P0 = find_global "$!serno"
$S0 = $P0
$S0 = concat fmt, $S0
inc $P0
@@ -92,3 +158,13 @@
.end
+=back
+
+=head1 AUTHOR
+
+Patrick Michaud ([EMAIL PROTECTED]) is the author and maintainer.
+Patches and suggestions should be sent to the Perl 6 compiler list
+([email protected]).
+
+=cut
+
Added: trunk/t/compilers/pge/01-codestring.t
==============================================================================
--- (empty file)
+++ trunk/t/compilers/pge/01-codestring.t Thu Apr 20 22:05:29 2006
@@ -0,0 +1,145 @@
+#!perl
+# Copyright: 2006 The Perl Foundation. All Rights Reserved.
+# $Id: $
+
+use strict;
+use warnings;
+use lib qw( . lib ../lib ../../lib );
+use Test::More;
+use Parrot::Test;
+
+=head1 NAME
+
+t/compilers/pge/pge_codestring.t - test the CodeString class
+
+
+=head1 SYNOPSIS
+
+ % prove t/compilers/pge/pge_codestring.t
+
+=head1 DESCRIPTION
+
+Tests the CodeString class directly.
+
+=cut
+
+pir_output_is(<<'CODE', <<'OUTPUT', 'create a CodeString object');
+.sub main :main
+ load_bytecode 'compilers/pge/PGE/CodeString.pir'
+ .local pmc code
+ code = new 'PGE::CodeString'
+ code = 'ok 1'
+ say code
+.end
+CODE
+ok 1
+OUTPUT
+
+pir_output_is(<<'CODE', <<'OUTPUT', 'calls to unique');
+.sub main :main
+ load_bytecode 'compilers/pge/PGE/CodeString.pir'
+ .local pmc code
+ code = new 'PGE::CodeString'
+ $P1 = code.'unique'('ok ')
+ say $P1
+ $P1 = code.'unique'()
+ say $P1
+ $P1 = code.'unique'('$P')
+ say $P1
+.end
+CODE
+ok 10
+11
+$P12
+OUTPUT
+
+
+pir_output_is(<<'CODE', <<'OUTPUT', 'basic emit');
+.sub main :main
+ load_bytecode 'compilers/pge/PGE/CodeString.pir'
+ .local pmc code
+ code = new 'PGE::CodeString'
+ code.emit(' label:')
+ code.emit(' say "Hello, World"')
+ code.emit(' $I0 = 1')
+ code.emit(' $N0 = 0.1')
+ print code
+.end
+CODE
+ label:
+ say "Hello, World"
+ $I0 = 1
+ $N0 = 0.1
+OUTPUT
+
+
+pir_output_is(<<'CODE', <<'OUTPUT', 'emit with pos args');
+.sub main :main
+ load_bytecode 'compilers/pge/PGE/CodeString.pir'
+ .local pmc code
+ code = new 'PGE::CodeString'
+ code.emit(' label_%0:', 1234)
+ code.emit(' say "%0, %1"', 'Hello', 'World')
+ code.emit(' %0 = %2', '$I0', 24, 48)
+ print code
+.end
+CODE
+ label_1234:
+ say "Hello, World"
+ $I0 = 48
+OUTPUT
+
+
+pir_output_is(<<'CODE', <<'OUTPUT', 'emit with %, args');
+.sub main :main
+ load_bytecode 'compilers/pge/PGE/CodeString.pir'
+ .local pmc code
+ code = new 'PGE::CodeString'
+ code.emit(' label_%0:', 1234)
+ code.emit(' say "%,"', 'Hello')
+ code.emit(' say "%,"', 'Hello', 'World', 'of', 'Parrot')
+ print code
+.end
+CODE
+ label_1234:
+ say "Hello"
+ say "Hello, World, of, Parrot"
+OUTPUT
+
+
+pir_output_is(<<'CODE', <<'OUTPUT', 'emit with named args');
+.sub main :main
+ load_bytecode 'compilers/pge/PGE/CodeString.pir'
+ .local pmc code
+ code = new 'PGE::CodeString'
+ code.emit(' label_%a:', 'a'=>1234)
+ code.emit(' say "%b, %c"', 'b'=>'Hello', 'c'=>'World')
+ code.emit(' say "%d"', 'b'=>'Hello', 'c'=>'World')
+ print code
+.end
+CODE
+ label_1234:
+ say "Hello, World"
+ say "%d"
+OUTPUT
+
+
+pir_output_is(<<'CODE', <<'OUTPUT', 'emit with pos + named args');
+.sub main :main
+ load_bytecode 'compilers/pge/PGE/CodeString.pir'
+ .local pmc code
+ code = new 'PGE::CodeString'
+ code.emit(' label_%a:', 'a'=>1234)
+ code.emit(' %0 "%b, %c"', 'say', 'print', 'b'=>'H', 'c'=>'W')
+ code.emit(' say "%,, %c"', 'alpha', 'beta', 'b'=>'H', 'c'=>'W')
+ print code
+.end
+CODE
+ label_1234:
+ say "H, W"
+ say "alpha, beta, W"
+OUTPUT
+
+# remember to change the number of tests :-)
+BEGIN { plan tests => 7; }
+
Added: trunk/t/compilers/pge/03-optable.t
==============================================================================
--- (empty file)
+++ trunk/t/compilers/pge/03-optable.t Thu Apr 20 22:05:29 2006
@@ -0,0 +1,193 @@
+#! perl
+# $Id: $
+
+use strict;
+use warnings;
+use lib qw( t . lib ../lib ../../lib ../../../lib );
+use Test::More;
+use Parrot::Test;
+
+## remember to change the number of tests :-)
+BEGIN { plan tests => 32; }
+
+optable_output_is('a', 'term:a', 'Simple term');
+optable_output_is('a+b', 'infix:+(term:a, term:b)', 'Simple infix');
+optable_output_is('a-b', 'infix:-(term:a, term:b)', 'Simple infix');
+optable_output_is('a+b+c',
+ 'infix:+(infix:+(term:a, term:b), term:c)',
+ 'left associativity');
+optable_output_is('a+b-c',
+ 'infix:-(infix:+(term:a, term:b), term:c)',
+ 'left associativity');
+optable_output_is('a-b+c',
+ 'infix:+(infix:-(term:a, term:b), term:c)',
+ 'left associativity');
+
+optable_output_is('a+b*c',
+ 'infix:+(term:a, infix:*(term:b, term:c))',
+ 'tighter precedence');
+optable_output_is('a*b+c',
+ 'infix:+(infix:*(term:a, term:b), term:c)',
+ 'tighter precedence');
+
+optable_output_is('a/b/c',
+ 'infix:/(infix:/(term:a, term:b), term:c)',
+ 'left associativity');
+optable_output_is('a*b/c',
+ 'infix:/(infix:*(term:a, term:b), term:c)',
+ 'left associativity');
+optable_output_is('a/b*c',
+ 'infix:*(infix:/(term:a, term:b), term:c)',
+ 'left associativity');
+
+optable_output_is('a=b*c',
+ 'infix:=(term:a, infix:*(term:b, term:c))',
+ 'looser precedence');
+
+optable_output_is('a=b=c',
+ 'infix:=(term:a, infix:=(term:b, term:c))',
+ 'right associativity');
+
+optable_output_is('a=b,c,d+e',
+ 'infix:=(term:a, infix:,(term:b, term:c, infix:+(term:d, term:e)))',
+ 'list associativity');
+
+optable_output_is('a b', 'term:a (pos=1)', 'two terms in sequence');
+optable_output_is('a = = b', 'term:a (pos=1)', 'two opers in sequence',
+ todo => 'fix end position');
+optable_output_is('a +', 'term:a (pos=1)', 'infix missing rhs',
+ todo => 'fix end position');
+
+optable_output_is('a++', 'postfix:++(term:a)', 'postfix');
+optable_output_is('a--', 'postfix:--(term:a)', 'postfix');
+optable_output_is('++a', 'prefix:++(term:a)', 'prefix');
+optable_output_is('--a', 'prefix:--(term:a)', 'prefix');
+
+optable_output_is('a*(b+c)',
+ 'infix:*(term:a, circumfix:( )(infix:+(term:b, term:c)))',
+ 'circumfix parens');
+optable_output_is('a*b+c)+4',
+ 'infix:+(infix:*(term:a, term:b), term:c) (pos=5)',
+ 'extra close paren');
+optable_output_is(' )a*b+c)+4', 'failed', 'only close paren');
+optable_output_is('(a*b+c', 'failed', 'missing close paren',
+ todo => 'fix close tokens');
+optable_output_is('(a*b+c]', 'failed', 'mismatch close paren',
+ todo => 'fix close tokens');
+
+
+optable_output_is('a+++--b',
+ 'infix:+(postfix:++(term:a), prefix:--(term:b))',
+ 'mixed tokens');
+
+optable_output_is('=a+4', 'failed', 'missing lhs term');
+
+optable_output_is('a(b,c)',
+ 'postcircumfix:( )(term:a, infix:,(term:b, term:c))',
+ 'postcircumfix');
+optable_output_is('a (b,c)',
+ 'term:a (pos=1)',
+ 'nows on postcircumfix');
+
+optable_output_is('a()', 'postcircumfix:( )(term:a, null)',
+ 'nullterm in postcircumfix');
+optable_output_is('a[]', 'term:a (pos=1)',
+ 'nullterm disallowed');
+
+
+################
+
+sub optable_output_is {
+ my($test, $output, $msg, %opt) = @_;
+ my($pir) = <<'CODE';
+.sub main :main
+ load_bytecode 'PGE.pbc'
+ load_bytecode 'dumper.pbc'
+ load_bytecode 'PGE/Dumper.pbc'
+
+ .local pmc optable
+ optable = new 'PGE::OPTable'
+
+ optable.newtok('infix:+', 'precedence'=>'=')
+ optable.newtok('infix:-', 'equiv'=>'infix:+')
+ optable.newtok('infix:*', 'tighter'=>'infix:+')
+ optable.newtok('infix:/', 'equiv'=>'infix:*')
+ optable.newtok('infix:**', 'tighter'=>'infix:*')
+ optable.newtok('infix:==', 'looser'=>'infix:+')
+ optable.newtok('infix:=', 'looser'=>'infix:==', 'assoc'=>'right')
+ optable.newtok('infix:,', 'tighter'=>'infix:=', 'assoc'=>'list')
+
+ optable.newtok('prefix:++', 'tighter'=>'infix:**')
+ optable.newtok('prefix:--', 'equiv'=>'prefix:++')
+ optable.newtok('postfix:++', 'equiv'=>'prefix:++')
+ optable.newtok('postfix:--', 'equiv'=>'prefix:++')
+
+ .local pmc ident
+ ident = find_global 'PGE::Rule', 'ident'
+ optable.newtok('term:', 'tighter'=>'prefix:++', 'parsed'=>ident)
+ optable.newtok('circumfix:( )', 'equiv'=>'term:')
+ optable.newtok('circumfix:[ ]', 'equiv'=>'term:')
+ optable.newtok('postcircumfix:( )', 'looser'=>'term:', 'nows'=>1,
'nullterm'=>1)
+ optable.newtok('postcircumfix:[ ]', 'equiv'=>'postcircumfix:( )',
'nows'=>1)
+
+ .local string test
+ test = "<<test>>"
+
+ .local pmc match
+ match = optable.parse(test)
+ unless match goto fail
+ $P0 = match['expr']
+ tree($P0)
+ $I0 = match.to()
+ $I1 = length test
+ if $I0 == $I1 goto succeed
+ print " (pos="
+ print $I0
+ print ")"
+ succeed:
+ print "\n"
+ goto end
+ fail:
+ print "failed\n"
+ end:
+.end
+
+.sub 'tree'
+ .param pmc match
+ .local string type
+ $S0 = match
+ if $S0 == "" goto print_null
+ type = match['type']
+ print type
+ if type == 'term:' goto print_term
+ print '('
+ .local pmc iter
+ $P0 = match.get_array()
+ if null $P0 goto iter_end
+ unless $P0 goto iter_end
+ iter = new .Iterator, $P0
+ iter = 0
+ unless iter goto iter_end
+ iter_loop:
+ $P0 = shift iter
+ tree($P0)
+ unless iter goto iter_end
+ print ', '
+ goto iter_loop
+ iter_end:
+ print ')'
+ goto end
+
+ print_null:
+ print "null"
+ goto end
+ print_term:
+ print match
+ end:
+ .return ()
+.end
+CODE
+ $pir =~ s/<<test>>/$test/g;
+ $output .= "\n";
+ pir_output_is($pir, $output, $msg, %opt);
+}
