Author: pmichaud
Date: Wed May 3 12:35:46 2006
New Revision: 12488
Added:
trunk/languages/perl6/lib/POST.pir
trunk/languages/perl6/lib/past2post.tg
Modified:
trunk/MANIFEST
trunk/config/gen/makefiles/perl6.in
trunk/languages/perl6/lib/PAST.pir
trunk/languages/perl6/lib/builtins.pir
trunk/languages/perl6/lib/grammar_optok.pg
trunk/languages/perl6/lib/main.pir
trunk/languages/perl6/lib/pge2past.tg
trunk/languages/perl6/perl6.pir
Log:
[perl6]
* Updated code generation to use a more parse->PAST->POST->PIR like
transformation. (But it's still a different POST from punie,
although it's a lot closer.)
* This change breaks lots of previously-working tests, but those
will be fixed shortly.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Wed May 3 12:35:46 2006
@@ -1521,13 +1521,15 @@
languages/perl6/t/00-parrot/04-op-cmp.t [perl6]
languages/perl6/lib/parse.pir [perl6]
languages/perl6/lib/PAST.pir [perl6]
+languages/perl6/lib/POST.pir [perl6]
languages/perl6/lib/builtins.pir [perl6]
-languages/perl6/lib/past2pir.tg [perl6]
languages/perl6/lib/main.pir [perl6]
languages/perl6/lib/grammar_sub.pg [perl6]
languages/perl6/lib/grammar_rules.pg [perl6]
languages/perl6/lib/grammar_optok.pg [perl6]
languages/perl6/lib/pge2past.tg [perl6]
+languages/perl6/lib/past2post.tg [perl6]
+languages/perl6/lib/past2pir.tg [perl6]
languages/pheme/MANIFEST [pheme]
languages/pheme/TODO [pheme]
languages/pheme/pheme.pir [pheme]
Modified: trunk/config/gen/makefiles/perl6.in
==============================================================================
--- trunk/config/gen/makefiles/perl6.in (original)
+++ trunk/config/gen/makefiles/perl6.in Wed May 3 12:35:46 2006
@@ -17,9 +17,10 @@
lib/grammar_optok.pg \
lib/grammar_sub.pg \
lib/parse.pir \
- lib/pge2past.tg \
- lib/past2pir.tg \
lib/PAST.pir \
+ lib/POST.pir \
+ lib/pge2past.tg \
+ lib/past2post.tg \
lib/main.pir \
lib/builtins.pir
@@ -27,8 +28,8 @@
perl6.pbc: $(PARROT) $(PGE_DIR)/pgc.pir $(SOURCES)
$(PARROT) $(PGE_DIR)/pgc.pir --output=lib/grammar_gen.pir \
lib/grammar_rules.pg lib/grammar_optok.pg lib/grammar_sub.pg
- $(PARROT) $(TGE_DIR)/tgc.pir --output=lib/pge2past.pir lib/pge2past.tg
- $(PARROT) $(TGE_DIR)/tgc.pir --output=lib/past2pir.pir lib/past2pir.tg
+ $(PARROT) $(TGE_DIR)/tgc.pir --output=lib/pge2past_gen.pir
lib/pge2past.tg
+ $(PARROT) $(TGE_DIR)/tgc.pir --output=lib/past2post_gen.pir
lib/past2post.tg
$(PARROT) -o perl6.pbc perl6.pir
# This is a listing of all targets, that are meant to be called by users
@@ -58,7 +59,7 @@
testclean:
clean:
- $(RM_RF) perl6.pbc lib/grammar_gen.pir
+ $(RM_RF) perl6.pbc lib/grammar_gen.pir lib/pge2past_gen.pir
lib/past2post_gen.pir
realclean: clean
$(RM_RF) Makefile
Modified: trunk/languages/perl6/lib/PAST.pir
==============================================================================
--- trunk/languages/perl6/lib/PAST.pir (original)
+++ trunk/languages/perl6/lib/PAST.pir Wed May 3 12:35:46 2006
@@ -10,30 +10,6 @@
needed for Perl 6. The currently defined ast nodes:
Perl6::PAST::Node - base class for all ast nodes
- Perl6::PAST::Sub - a subroutine or executable block
- Perl6::PAST::Stmts - a block of statements
- Perl6::PAST::Stmt - a single statement
- Perl6::PAST::Op - an operation
- Perl6::PAST::Val - a constant value
- Perl6::PAST::Var - a variable
- Perl6::PAST::Lex - a lexical declaration ("my")
- Perl6::PAST::Vector - a vector of values
- Perl6::PAST::Assign - an assignment operation
-
-The C<Perl6::PAST::Node> class itself is derived from C<Hash>, so
-that it's easy to store and retrieve attributes from each
-node object.
-
-This file also defines (by inclusion) C<Perl6::PAST::Grammar>,
-which converts a Match object into an abstract syntax tree.
-
-=head1 PAST functions
-
-=over 4
-
-=item C<__onload()>
-
-Creates the C<Perl6::PAST::*> classes.
=cut
@@ -41,178 +17,270 @@
.sub '__onload' :load
.local pmc base
- $P0 = getclass 'Hash'
- base = subclass $P0, 'Perl6::PAST::Node'
- addattribute base, '$.source' # original source
- addattribute base, '$.pos' # offset position
+ base = newclass 'Perl6::PAST::Node'
+ addattribute base, '@.children'
+ addattribute base, '$.source'
+ addattribute base, '$.pos'
- $P0 = subclass base, 'Perl6::PAST::Sub'
- $P0 = subclass base, 'Perl6::PAST::Stmts'
- $P0 = subclass base, 'Perl6::PAST::Stmt'
- $P0 = subclass base, 'Perl6::PAST::Exp'
$P0 = subclass base, 'Perl6::PAST::Op'
+ addattribute $P0, '$.op'
+ addattribute $P0, '$.name'
+
$P0 = subclass base, 'Perl6::PAST::Val'
- $P0 = subclass base, 'Perl6::PAST::Var'
- $P0 = subclass base, 'Perl6::PAST::Lex'
+ addattribute $P0, '$.valtype'
+ addattribute $P0, '$.val'
- base = getclass 'TGE'
- $P0 = subclass base, 'Perl6::PAST::Grammar'
- $P0 = subclass base, 'Perl6::PIR::Grammar'
+ $P0 = subclass base, 'Perl6::PAST::Exp'
+ $P0 = subclass base, 'Perl6::PAST::Stmt'
+ $P0 = subclass base, 'Perl6::PAST::Stmts'
+ $P0 = subclass base, 'Perl6::PAST::Sub'
+ $P0 = subclass base, 'Perl6::PAST::Var'
$P0 = new .Integer
- store_global "Perl6::PAST", "$!serno", $P0
+ $P0 = 10
+ store_global '$!serno', $P0
+ .return ()
.end
-.namespace [ 'Perl6::PAST::Node' ]
-
-=back
-=head2 Perl6::PAST::Node methods
-
-=over 4
-
-=item C<__init()>
-
-Initializes a new C<Perl6::PAST::Node> object.
+.namespace [ 'Perl6::PAST::Node' ]
-=cut
+.sub 'attr' :method
+ .param string attrname
+ .param pmc value
+ .param int setvalue
+ if setvalue goto set
+ value = getattribute self, attrname
+ unless null value goto end
+ value = new .Undef
+ set:
+ setattribute self, attrname, value
+ end:
+ .return (value)
+.end
-.sub __init :method
- $P0 = new .String
- $P1 = new .Integer
- setattribute self, "Perl6::PAST::Node\x0$.source", $P0
- setattribute self, "Perl6::PAST::Node\x0$.pos", $P1
+.sub 'init' :method
+ .param pmc children :slurpy
+ .param pmc adverbs :slurpy :named
+
+ unless null children goto set_children
+ children = new .ResizablePMCArray
+ set_children:
+ setattribute self, '@.children', children
+
+ if null adverbs goto end
+ .local pmc iter
+ iter = new .Iterator, adverbs
+ iter = 0
+ iter_loop:
+ unless iter goto iter_end
+ $S0 = shift iter
+ if $S0 == 'XXX' goto iter_loop
+ $P0 = iter[$S0]
+ $P1 = find_method self, $S0
+ self.$P1($P0)
+ goto iter_loop
+ iter_end:
+ end:
.return ()
.end
-=item C<set_node(PMC match)>
-
-Initializes the current ast node with the source code
-information from a match object (presumably a component
-of the parse tree).
+.sub 'new' :method
+ .param string class
+ .param pmc children :slurpy
+ .param pmc adverbs :slurpy :named
+
+ $I0 = find_type class
+ $P0 = new $I0
+ $P0.'init'(children :flat, 'node'=>self, 'XXX'=>1, adverbs :flat :named)
+ .return ($P0)
+.end
-=cut
-.sub 'set_node' :method
- .param pmc match # match object of source
- $P0 = getattribute self, "Perl6::PAST::Node\x0$.source"
- $S0 = match
- $P0 = $S0
- $P1 = getattribute self, "Perl6::PAST::Node\x0$.pos"
- $I1 = match.from()
- $P1 = $I1
+.sub 'add_child' :method
+ .param pmc child
+ .local pmc array
+ array = getattribute self, '@.children'
+ push array, child
.return ()
.end
-=item C<source()>
-
-Return the source code associated with the current node.
+.sub 'add_child_new' :method
+ .param string class
+ .param pmc children :slurpy
+ .param pmc adverbs :slurpy :named
+ $P0 = self.'new'(class, children :flat, 'XXX'=>0, adverbs :flat :named)
+ self.'add_child'($P0)
+ .return ($P0)
+.end
-=cut
.sub 'source' :method
- $P0 = getattribute self, "Perl6::PAST::Node\x0$.source"
- .return ($P0)
+ .param string source :optional
+ .param int has_source :opt_flag
+ .return self.'attr'('$.source', source, has_source)
.end
-=item C<pos()>
+.sub 'pos' :method
+ .param int pos :optional
+ .param int has_pos :opt_flag
+ .return self.'attr'('$.pos', pos, has_pos)
+.end
-Return the source code offset associated with this
-node.
-=cut
+.sub 'node' :method
+ .param pmc node
+ $I0 = isa node, 'Perl6::PAST::Node'
+ if $I0 goto clone_past
+ clone_pge:
+ $S0 = node
+ self.'source'($S0)
+ $I0 = node.'from'()
+ self.'pos'($I0)
+ .return ()
+ clone_past:
+ $S0 = node.'source'()
+ self.'source'($S0)
+ $I0 = node.'pos'()
+ self.'pos'($I0)
+ .return ()
+.end
-.sub 'pos' :method
- $P0 = getattribute self, "Perl6::PAST::Node\x0$.pos"
- .return ($P0)
+
+.sub 'child_iter' :method
+ $P0 = getattribute self, '@.children'
+ $P1 = new .Iterator, $P0
+ $P1 = 0
+ .return ($P1)
.end
-=item C<generate_unique(STR prefix)>
+=item C<unique([string fmt])>
-Generate a unique string that begins with C<prefix>.
+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 "generate_unique" :method
- .param string prefix
- $P0 = find_global "Perl6::PAST", "$!serno"
+.sub 'unique' :method
+ .param string fmt :optional
+ .param int has_fmt :opt_flag
+
+ if has_fmt goto unique_1
+ fmt = ''
+ unique_1:
+ $P0 = find_global 'Perl6::PAST', '$!serno'
$S0 = $P0
- $S0 = concat prefix, $S0
+ $S0 = concat fmt, $S0
inc $P0
.return ($S0)
.end
-=item C<__dump(PMC dumper, STR label)>
+.sub '__elements' :method
+ $P0 = getattribute self, '@.children'
+ $I0 = elements $P0
+ .return ($I0)
+.end
-Display the contents of the current node in a form compatible
-with C<Data::Dumper>.
-=cut
+.sub '__get_pmc_keyed_int' :method
+ .param int key
+ $P0 = getattribute self, '@.children'
+ $P0 = $P0[key]
+ .return ($P0)
+.end
+
+
+.sub '__set_pmc_keyed_int' :method
+ .param int key
+ .param pmc val
+ $P0 = getattribute self, '@.children'
+ $P0[key] = val
+ .return ()
+.end
+
+
+.sub '__dumplist' :method
+ .return ('$.pos @.children')
+.end
+
.sub '__dump' :method
.param pmc dumper
.param string label
.local string indent, subindent
- .local pmc iter, val
- .local string key
- .local pmc hash
- .local int hascapts
(subindent, indent) = dumper.'newIndent'()
- print '=> '
- $S0 = self.source()
- dumper.'genericString'('', $S0)
- $I0 = self.pos()
- print ' @ '
- print $I0
- hascapts = 0
- iter = new .Iterator, self
+ print '=> { '
+ .local pmc attrlist, iter
+ $S0 = self.'__dumplist'()
+ attrlist = split ' ', $S0
+ iter = new .Iterator, attrlist
iter = 0
- dump_hash_1:
- unless iter goto dump_end
- if hascapts goto dump_hash_2
- print ' {'
- hascapts = 1
- dump_hash_2:
+ iter_loop:
+ unless iter goto iter_end
+ .local string attrname
+ .local pmc val
+ attrname = shift iter
+ val = getattribute self, attrname
print "\n"
print subindent
- key = shift iter
- val = iter[key]
- print '<'
- print key
- print '> => '
+ print attrname
+ print ' => '
dumper.'dump'(label, val)
- goto dump_hash_1
- dump_end:
- unless hascapts goto end
+ goto iter_loop
+ iter_end:
print "\n"
print indent
print '}'
- end:
dumper.'deleteIndent'()
+ .return ()
.end
-.namespace [ 'Perl6::PAST::Grammar' ]
-.include 'lib/pge2past.pir'
-.namespace [ 'Perl6::PIR::Grammar' ]
-.include 'lib/past2pir.pir'
+.namespace [ 'Perl6::PAST::Op' ]
-=back
+.sub 'op' :method
+ .param string op :optional
+ .param int has_op :opt_flag
+ .return self.'attr'('$.op', op, has_op)
+.end
-=head1 LICENSE
-Copyright (c) 2005-2006 The Perl Foundation
+.sub 'name' :method
+ .param string name :optional
+ .param int has_name :opt_flag
+ .return self.'attr'('$.name', name, has_name)
+.end
-This is free software; you may redistribute it and/or modify
-it under the same terms as Parrot.
-=cut
+.sub '__dumplist' :method
+ .return ('$.op $.name @.children')
+.end
+
+
+.namespace [ 'Perl6::PAST::Val' ]
+
+.sub 'valtype' :method
+ .param string valtype :optional
+ .param int has_valtype :opt_flag
+ .return self.'attr'('$.valtype', valtype, has_valtype)
+.end
+
+.sub 'val' :method
+ .param string val :optional
+ .param int has_val :opt_flag
+ .return self.'attr'('$.val', val, has_val)
+.end
-## vim: expandtab sw=4
+.sub '__dumplist' :method
+ .return ('$.valtype $.val')
+.end
Added: trunk/languages/perl6/lib/POST.pir
==============================================================================
--- (empty file)
+++ trunk/languages/perl6/lib/POST.pir Wed May 3 12:35:46 2006
@@ -0,0 +1,203 @@
+=head1 NAME
+
+POST - A(nother) low-level opcode syntax tree.
+
+=head1 DESCRIPTION
+
+Compilers progress through various levels of
+tree representations of compilation of a source
+code program. POST (Parrot Opcode Syntax Tree) is
+a low-level tree which closely corresponds to the
+semantics of PIR/PASM.
+
+The base class of POST is Perl6::PAST::Node -- see C<lib/PAST.pir>
+
+=cut
+
+.namespace [ 'Perl6::POST' ]
+
+.sub '__onload' :load
+ .local pmc base
+ $P0 = getclass 'Perl6::PAST::Node'
+ base = subclass $P0, 'Perl6::POST::Node'
+ addattribute base, '$.name'
+ addattribute base, '$.value'
+
+ $P0 = subclass base, 'Perl6::POST::Val'
+ addattribute $P0, '$.valtype'
+
+ $P0 = subclass base, 'Perl6::POST::Op'
+ $P0 = subclass base, 'Perl6::POST::Ops'
+ $P0 = subclass base, 'Perl6::POST::Label'
+ $P0 = subclass base, 'Perl6::POST::Sub'
+
+.end
+
+.namespace [ 'Perl6::POST::Node' ]
+
+.sub '__init' :method
+ $P0 = new .String
+ setattribute self, '$.name', $P0
+ $P0 = new String
+ setattribute self, '$.value', $P0
+ .return ()
+.end
+
+.sub 'name' :method
+ .param pmc name :optional
+ .param int has_name :opt_flag
+ .return self.'attr'('$.name', name, has_name)
+.end
+
+=item C<value()>
+
+Set or return the invocant's value. If no value has been
+previously set for this node, then the default for POST::Node
+is to use the value of its last child. If it has no children,
+then we generate a unique PMC register (uninitialized) and
+use that.
+
+=cut
+
+.sub value :method
+ .param pmc value :optional
+ .param int has_value :opt_flag
+
+ value = self.'attr'('$.value', value, has_value)
+ if value > '' goto end
+ $S0 = self.'unique'('$P')
+ assign value, $S0
+ end:
+ .return (value)
+.end
+
+
+.sub '__dumplist' :method
+ .return ('$.name $.value @.children')
+.end
+
+
+.namespace [ 'Perl6::POST::Ops' ]
+
+.sub 'pir' :method
+ .local pmc code, iter
+
+ code = new 'PGE::CodeString'
+ iter = self.'child_iter'()
+ iter_loop:
+ unless iter goto iter_end
+ $P0 = shift iter
+ $P1 = $P0.'pir'()
+ code .= $P1
+ goto iter_loop
+ iter_end:
+ .return (code)
+.end
+
+
+.namespace [ 'Perl6::POST::Op' ]
+
+.sub 'pir' :method
+ .local pmc code
+
+ .local pmc childvalues, iter
+ childvalues = new .ResizablePMCArray
+ iter = self.'child_iter'()
+ iter_loop:
+ unless iter goto iter_end
+ $P0 = shift iter
+ $I0 = isa $P0, 'Perl6::POST::Node'
+ if $I0 == 0 goto iter_loop_1
+ $P0 = $P0.'value'()
+ iter_loop_1:
+ push childvalues, $P0
+ goto iter_loop
+ iter_end:
+
+ code = new 'PGE::CodeString'
+ .local string name
+ name = self.'name'()
+ $S0 = substr name, 0, 1
+ if $S0 == "'" goto sub_call
+ code.'emit'(' %n %,', childvalues :flat, 'n'=>name)
+ .return (code)
+
+ sub_call:
+ $P0 = shift childvalues
+ code.emit(' %r = %n(%,)', childvalues :flat, 'r'=>$P0, 'n'=>name)
+ .return (code)
+.end
+
+
+.namespace [ 'Perl6::POST::Label' ]
+
+=item C<value()>
+
+Returns the value for this label. If one hasn't already been
+set, a new unique label is generated from the invocant's name
+and that is returned.
+
+=cut
+
+.sub 'value' :method
+ .param pmc value :optional
+ .param int has_value :opt_flag
+ value = self.'attr'('$.value', value, has_value)
+ if value > '' goto value_end
+ .local pmc name
+ name = self.'name'()
+ $S0 = self.'unique'(name)
+ assign value, $S0
+ value_end:
+ .return (value)
+.end
+
+
+.sub 'pir' :method
+ .local string code
+ .local string value
+ value = self.'value'()
+ code = ' '
+ code .= value
+ code .= ":\n"
+ .return (code)
+.end
+
+
+.namespace [ 'Perl6::POST::Sub' ]
+
+.sub 'pir' :method
+ .local pmc code, iter
+ code = new 'PGE::CodeString'
+ code.'emit'(".sub 'anon' :anon")
+ iter = self.'child_iter'()
+ iter_loop:
+ unless iter goto iter_end
+ $P0 = shift iter
+ $P1 = $P0.'pir'()
+ code .= $P1
+ goto iter_loop
+ iter_end:
+ code.'emit'('.end')
+ .return (code)
+.end
+
+
+.namespace [ 'Perl6::POST::Val' ]
+
+.sub 'value' :method
+ .param string value :optional
+ .param int has_value :opt_flag
+ .local pmc v, valtype
+ .return self.'attr'('$.value', value, has_value)
+.end
+
+.sub 'valtype' :method
+ .param string valtype :optional
+ .param int has_valtype :opt_flag
+ .return self.'attr'('$.valtype', valtype, has_valtype)
+.end
+
+.sub '__dumplist' :method
+ .return ('$.name $.value $.valtype')
+.end
Modified: trunk/languages/perl6/lib/builtins.pir
==============================================================================
--- trunk/languages/perl6/lib/builtins.pir (original)
+++ trunk/languages/perl6/lib/builtins.pir Wed May 3 12:35:46 2006
@@ -38,6 +38,62 @@
.end
+.sub 'infix:<'
+ .param pmc a
+ .param pmc b
+ $I0 = cmp_num a, b
+ $I0 = islt $I0, 0
+ .return ($I0)
+.end
+
+
+.sub 'infix:>'
+ .param pmc a
+ .param pmc b
+ $I0 = cmp_num a, b
+ $I0 = isgt $I0, 0
+ .return ($I0)
+.end
+
+
+.sub 'infix:<='
+ .param pmc a
+ .param pmc b
+ $I0 = cmp_num a, b
+ $I0 = isle $I0, 0
+ .return ($I0)
+.end
+
+
+.sub 'infix:>='
+ .param pmc a
+ .param pmc b
+ $I0 = cmp_num a, b
+ $I0 = isge $I0, 0
+ .return ($I0)
+.end
+
+
+.sub 'infix:=='
+ .param pmc a
+ .param pmc b
+ $I0 = cmp_num a, b
+ $I0 = iseq $I0, 0
+ .return ($I0)
+.end
+
+
+.sub 'infix:!='
+ .param pmc a
+ .param pmc b
+ $I0 = cmp_num a, b
+ $I0 = isne $I0, 0
+ .return ($I0)
+.end
+
+
+
+
.sub 'infix:**'
.param num base
.param num exp
Modified: trunk/languages/perl6/lib/grammar_optok.pg
==============================================================================
--- trunk/languages/perl6/lib/grammar_optok.pg (original)
+++ trunk/languages/perl6/lib/grammar_optok.pg Wed May 3 12:35:46 2006
@@ -19,6 +19,7 @@
is parsed(&listop) { ... }
proto 'circumfix:( )' is equiv('term:')
+ is post('set')
is pir(" # circumfix op") { ... }
## dot comment in postfix position
@@ -104,18 +105,22 @@
## multiplicative
proto 'infix:*' is precedence('17=')
+ is post('mul')
is pir(" %t = %0 * %1")
{ ... }
proto 'infix:/' is equiv('infix:*')
+ is post('div')
is pir(" %t = %0 / %1")
{ ... }
proto 'infix:%' is equiv('infix:*')
+ is post('mod')
is pir(" %t = mod %0, %1")
{ ... }
proto 'infix:x' is equiv('infix:*')
+ is post('repeat')
is pir(" %t = repeat %0, %1")
{ ... }
@@ -143,14 +148,17 @@
## additive
proto 'infix:+' is precedence('16=')
+ is post('add')
is pir(" %r = %0 + %1")
{ ... }
proto 'infix:-' is equiv('infix:+')
+ is post('sub')
is pir(" %r = %0 - %1")
{ ... }
proto 'infix:~' is equiv('infix:+')
+ is post('concat')
is pir(" %r = concat %0, %1")
{ ... }
@@ -364,8 +372,8 @@
proto 'infix:||' is precedence('09=')
is pasttype('cond') { ... }
-proto 'infix:^^' is equiv('infix:||')
- is pasttype('cond') { ... }
+proto 'infix:^^' is precedence('09=') is assoc('list')
+ is pasttype('xor') { ... }
proto 'infix://' is equiv('infix:||')
is pasttype('cond') { ... }
@@ -489,7 +497,7 @@
is pasttype('cond') { ... }
proto 'infix:xor' is equiv('infix:or')
- is pasttype('cond') { ... }
+ is pasttype('xor') { ... }
proto 'infix:err' is equiv('infix:or')
is pasttype('cond') { ... }
Modified: trunk/languages/perl6/lib/main.pir
==============================================================================
--- trunk/languages/perl6/lib/main.pir (original)
+++ trunk/languages/perl6/lib/main.pir Wed May 3 12:35:46 2006
@@ -35,6 +35,8 @@
$P0()
$P0 = find_global 'Perl6::PAST', '__onload'
$P0()
+ $P0 = find_global 'Perl6::POST', '__onload'
+ $P0()
load_bytecode 'dumper.pbc'
load_bytecode 'PGE/Dumper.pbc'
Added: trunk/languages/perl6/lib/past2post.tg
==============================================================================
--- (empty file)
+++ trunk/languages/perl6/lib/past2post.tg Wed May 3 12:35:46 2006
@@ -0,0 +1,246 @@
+Perl6::PAST::Sub: post(.) = {
+ $P0 = node[0]
+ $P0 = tree.'get'('post', $P0)
+ .local pmc post
+ post = new 'Perl6::POST::Sub'
+ post.'init'($P0, 'name'=>'anon')
+ .return (post)
+}
+
+
+Perl6::PAST::Stmts: post(.) = {
+ .local pmc iter, ops
+ ops = new 'Perl6::POST::Ops'
+ ops.'init'('node'=>node)
+ iter = node.'child_iter'()
+ iter_loop:
+ unless iter goto iter_end
+ $P0 = shift iter
+ $P1 = tree.'get'('post', $P0)
+ ops.'add_child'($P1)
+ goto iter_loop
+ iter_end:
+ .local string value
+ value = $P1.'value'()
+ ops.'value'(value)
+ .return (ops)
+}
+
+
+Perl6::PAST::Stmt: post(.) = {
+ $P0 = node[0]
+ $P1 = tree.'get'('post', $P0)
+ .return ($P1)
+}
+
+
+Perl6::PAST::Exp: post(.) = {
+ $P0 = node[0]
+ $P1 = tree.'get'('post', $P0)
+ .return ($P1)
+}
+
+
+Perl6::PAST::Op: post(.) = {
+ .local string opname, pasttype
+ .local pmc optable, optok
+ opname = node.'op'()
+ optable = find_global 'Perl6::Grammar', '$optable'
+ optok = optable[opname]
+ pasttype = optok['pasttype']
+ if pasttype > '' goto dispatch_post
+ pasttype = 'simple'
+ dispatch_post:
+ .return tree.'get'(pasttype, node)
+}
+
+
+Perl6::PAST::Op: simple(.) = {
+ .local pmc ops
+ ops = new 'Perl6::POST::Ops'
+ ops.'init'('node'=>node)
+
+ .local string opname, postop
+
+ opname = node.'op'()
+ postop = node.'name'()
+
+ .local pmc iter, arglist
+ $P0 = node
+ if opname != 'prelist:' goto op_children
+ $P1 = node[0]
+ $I0 = isa $P1, 'Perl6::PAST::Op'
+ if $I0 == 0 goto op_children
+ $S0 = $P1.'op'()
+ if $S0 != 'infix:,' goto op_children
+ $P0 = $P1
+ op_children:
+ iter = $P0.'child_iter'()
+ arglist = new .ResizablePMCArray
+ iter_loop:
+ unless iter goto iter_end
+ .local pmc cpast, cpost
+ cpast = shift iter
+ cpost = tree.'get'('post', cpast)
+ ops.'add_child'(cpost)
+ push arglist, cpost
+ goto iter_loop
+ iter_end:
+ $S0 = substr postop, 0, 1
+ if $S0 == "'" goto postop_end
+ ## direct POST op, create a temporary to store the result
+ ops.'add_child_new'('Perl6::POST::Op', ops, '.Undef', 'name'=>'new')
+ postop_end:
+ ops.'add_child_new'('Perl6::POST::Op', ops, arglist :flat, 'name'=>postop)
+ .return (ops)
+}
+
+
+Perl6::PAST::Op: cond(.) = {
+ .local pmc ops
+ ops = new 'Perl6::POST::Ops'
+ ops.'init'('node'=>node)
+
+ .local pmc exprpast, thenpast, elsepast
+ .local pmc exprpost, thenpost, elsepost
+ exprpast = node[0]
+ thenpast = node[1]
+ elsepast = node[2]
+
+ .local pmc thenlabel, endlabel
+ thenlabel = ops.'new'('Perl6::POST::Label', 'name'=>'if_then')
+ endlabel = ops.'new'('Perl6::POST::Label', 'name'=>'if_end')
+
+ exprpost = tree.'get'('post', exprpast)
+ ops.'add_child'(exprpost)
+ ops.'add_child_new'('Perl6::POST::Op', exprpost, thenlabel, 'name'=>'if')
+ elsepost = exprpost
+ $I0 = defined elsepast
+ if $I0 == 0 goto cond_no_else
+ elsepost = tree.'get'('post', elsepast)
+ ops.'add_child'(elsepost)
+ cond_no_else:
+ ops.'add_child_new'('Perl6::POST::Op', ops, elsepost, 'name'=>'set')
+ ops.'add_child_new'('Perl6::POST::Op', endlabel, 'name'=>'goto')
+ ops.'add_child'(thenlabel)
+ thenpost = exprpost
+ $I0 = defined thenpast
+ if $I0 == 0 goto cond_no_then
+ thenpost = tree.'get'('post', thenpast)
+ ops.'add_child'(thenpost)
+ cond_no_then:
+ ops.'add_child_new'('Perl6::POST::Op', ops, thenpost, 'name'=>'set')
+ ops.'add_child'(endlabel)
+ .return (ops)
+}
+
+
+Perl6::PAST::Op: xor(.) = {
+ .local pmc ops
+ ops = new 'Perl6::POST::Ops'
+ ops.'init'('node'=>node)
+
+ .local pmc endlabel, falselabel
+ falselabel = ops.'new'('Perl6::POST::Label', 'name'=>'xor_false')
+ endlabel = ops.'new'('Perl6::POST::Label', 'name'=>'xor_end')
+
+ .local pmc iter, apast, apost, i, t, u
+ i = ops.unique('$I')
+ t = ops.unique('$I')
+ u = ops.unique('$I')
+ iter = node.'child_iter'()
+ apast = shift iter
+ apost = tree.'get'('post', apast)
+ ops.'add_child'(apost)
+ ops.'add_child_new'('Perl6::POST::Op', ops, apost, 'name'=>'set')
+ ops.'add_child_new'('Perl6::POST::Op', t, apost, 'name'=>'istrue')
+ inner_child:
+ .local pmc bpast, bpost
+ bpast = shift iter
+ bpost = tree.'get'('post', bpast)
+ ops.'add_child'(bpost)
+ ops.'add_child_new'('Perl6::POST::Op', u, bpost, 'name'=>'istrue')
+ ops.'add_child_new'('Perl6::POST::Op', i, t, u, 'name'=>'and')
+ ops.'add_child_new'('Perl6::POST::Op', i, falselabel, 'name'=>'if')
+ unless iter goto last_child
+ .local pmc s
+ s = ops.'new'('Perl6::POST::Label', 'name'=>'xor_skip')
+ ops.'add_child_new'('Perl6::POST::Op', t, s, 'name'=>'if')
+ ops.'add_child_new'('Perl6::POST::Op', ops, bpost, 'name'=>'set')
+ ops.'add_child_new'('Perl6::POST::Op', t, u, 'name'=>'set')
+ ops.'add_child'(s)
+ goto inner_child
+ last_child:
+ ops.'add_child_new'('Perl6::POST::Op', t, endlabel, 'name'=>'if')
+ ops.'add_child_new'('Perl6::POST::Op', ops, bpost, 'name'=>'set')
+ ops.'add_child_new'('Perl6::POST::Op', endlabel, 'name'=>'goto')
+ ops.'add_child'(falselabel)
+ ops.'add_child_new'('Perl6::POST::Op', ops, '.Undef', 'name'=>'new')
+ ops.'add_child'(endlabel)
+ .return (ops)
+}
+
+
+Perl6::PAST::Op: chain(.) = {
+ .local pmc ops
+ ops = new 'Perl6::POST::Ops'
+ ops.'init'('node'=>node)
+
+ .local string opname, pasttype
+ .local pmc optable, optok
+ optable = find_global 'Perl6::Grammar', '$optable'
+
+ .local pmc clist
+ clist = new .ResizablePMCArray
+ chain_loop:
+ $I0 = isa node, 'Perl6::PAST::Op'
+ if $I0 == 0 goto chain_end
+ opname = node.'op'()
+ optok = optable[opname]
+ pasttype = optok['pasttype']
+ if pasttype != 'chain' goto chain_end
+ push clist, node
+ node = node[0]
+ goto chain_loop
+ chain_end:
+
+ .local pmc endlabel, apast, apost
+ node = pop clist
+ endlabel = ops.'new'('Perl6::POST::Label', 'name'=>'chain_end')
+ apast = node[0]
+ apost = tree.'get'('post', apast)
+ ops.'add_child'(apost)
+
+ clist_loop:
+ .local pmc bpast, bpost
+ .local string postop
+ bpast = node[1]
+ bpost = tree.'get'('post', bpast)
+ postop = node.'name'()
+ ops.'add_child'(bpost)
+ ops.'add_child_new'('Perl6::POST::Op', ops, apost, bpost, 'name'=>postop)
+ unless clist goto clist_end
+ ops.'add_child_new'('Perl6::POST::Op', ops, endlabel, 'name'=>'unless')
+ apost = bpost
+ node = pop clist
+ goto clist_loop
+ clist_end:
+ ops.'add_child'(endlabel)
+ .return (ops)
+}
+
+
+
+Perl6::PAST::Val: post(.) = {
+ .local string val, valtype
+ val = node.'val'()
+ valtype = node.'valtype'()
+ .local pmc ops
+ ops = new 'Perl6::POST::Ops'
+ ops.'init'('node'=>node)
+ ops.'add_child_new'('Perl6::POST::Op', ops, '.Undef', 'name'=>'new')
+ $P0 = ops.'new'('Perl6::POST::Val', 'valtype'=>valtype, 'value'=>val)
+ ops.'add_child_new'('Perl6::POST::Op', ops, $P0, 'name'=>'assign')
+ .return (ops)
+}
+
Modified: trunk/languages/perl6/lib/pge2past.tg
==============================================================================
--- trunk/languages/perl6/lib/pge2past.tg (original)
+++ trunk/languages/perl6/lib/pge2past.tg Wed May 3 12:35:46 2006
@@ -2,24 +2,21 @@
ROOT: past(.) = {
.local pmc past
- past = new 'Perl6::PAST::Sub'
- past.set_node(node)
$P0 = node['statement_list']
$P1 = tree.'get'('past', $P0, 'Perl6::Grammar::statement_list')
- past['statement_list'] = $P1
+ past = new 'Perl6::PAST::Sub'
+ past.'init'($P1, 'node'=>node)
.return (past)
}
Perl6::Grammar::statement_list: past(.) = {
.local pmc past
- .local pmc children
.local pmc iter
past = new 'Perl6::PAST::Stmts'
- past.'set_node'(node)
+ past.'init'('node'=>node)
- children = new .ResizablePMCArray
$P0 = node['statement']
iter = new .Iterator, $P0
iter = 0
@@ -28,27 +25,20 @@
$P1 = shift iter
$P2 = tree.'get'('past', $P1, 'Perl6::Grammar::statement')
if null $P2 goto iter_loop
- push children, $P2
+ past.'add_child'($P2)
goto iter_loop
iter_end:
- past['children'] = children
.return (past)
}
Perl6::Grammar::statement: past(.) = {
- .local pmc past
- past = new 'Perl6::PAST::Stmt'
- past.'set_node'(node)
-
- $P0 = node['expression']
- if $P0 goto expression
$P0 = node['statement_control']
if $P0 goto statement_control
- .return (past)
expression:
.local pmc stmt
+ $P0 = node['expression']
stmt = tree.'get'('past', $P0, 'Perl6::Grammar::expression')
$P0 = node['statement_modifier']
unless $P0 goto expression_1
@@ -62,61 +52,107 @@
if $S0 != 'unless' goto stmt_modifier_1
exchange thenpast, elsepast
stmt_modifier_1:
- stmt = new "Perl6::PAST::Op"
$P0 = modifier['expression']
exprpast = tree.'get'('past', $P0, 'Perl6::Grammar::expression')
- stmt['opname'] = 'statement_control:if'
- stmt['pasttype'] = 'cond'
- $P0 = new .ResizablePMCArray
- $P0[0] = exprpast
- $P0[1] = thenpast
- $P0[2] = elsepast
- stmt['children'] = $P0
+ stmt = new 'Perl6::PAST::Op'
+ stmt.'init'(exprpast, thenpast, elsepast, 'op'=>'statement_control:if',
'node'=>modifier)
+
expression_1:
- past['statement'] = stmt
+ .local pmc past
+ past = new 'Perl6::PAST::Stmt'
+ past.'init'(stmt, 'node'=>node)
.return (past)
statement_control:
$P1 = tree.'get'('past', $P0, 'Perl6::Grammar::statement_control')
- past['statement'] = $P1
+ past = new 'Perl6::PAST::Stmt'
+ past.'init'($P1, 'node'=>node)
.return (past)
}
-Perl6::Grammar::expression: past(.) = {
+Perl6::Grammar::statement_control: past(.) = {
+ .local pmc key, exprlist, blocklist
+ key = node['KEY']
+ exprlist = node['expression']
+ blocklist = node['block']
+
+ ## do we have an else clause?
+ .local pmc exprpast, thenpast, elsepast
+ .local int exprc, blockc
+ null elsepast
+ else_block:
+ exprc = elements exprlist
+ blockc = elements blocklist
+ if blockc <= exprc goto expr_block_pair
+ dec blockc
+ $P0 = blocklist[blockc]
+ elsepast = tree.'get'('past', $P0, 'Perl6::Grammar::block')
+
+ expr_block_pair:
+ ## each remaining block is paired with an "if" (or "elsif")
+ ## expression, except the first which could be "unless".
+ dec exprc
+ dec blockc
+ $P0 = exprlist[exprc]
+ exprpast = tree.'get'('past', $P0, 'Perl6::Grammar::expression')
+ $P0 = blocklist[blockc]
+ thenpast = tree.'get'('past', $P0, 'Perl6::Grammar::block')
+ if exprc > 0 goto if_op
+ if key != 'unless' goto if_op
+ exchange thenpast, elsepast
+
+ if_op:
.local pmc past
+ past = new "Perl6::PAST::Op"
+ past.init(exprpast, thenpast, elsepast, 'node'=>node,
'op'=>'statement_control:if')
+ elsepast = past
+ if exprc > 0 goto expr_block_pair
+ .return (past)
+}
+
- past = new 'Perl6::PAST::Exp'
- past.set_node(node)
+Perl6::Grammar::expression: past(.) = {
+ .local pmc past
$P0 = node['expr']
$P1 = tree.'get'('past', $P0, 'Perl6::Grammar::expr')
- past['expression'] = $P1
+ past = new 'Perl6::PAST::Exp'
+ past.'init'($P1, 'node'=>node)
.return (past)
}
Perl6::Grammar::expr: past(.) = {
.local string type
- .local pmc optable
- .local pmc op
type = node['type']
if type != "" goto pastrule
null $P0
.return ($P0)
pastrule:
- optable = find_global "Perl6::Grammar", "$optable"
- op = optable[type]
- $S0 = op['pastrule']
- unless $S0 goto op_standard
+ .local pmc optable, optok
+ optable = find_global 'Perl6::Grammar', '$optable'
+ optok = optable[type]
+ $S0 = optok['pastrule']
+ unless $S0 goto set_subname
.return tree.'get'($S0, node, 'Perl6::Grammar::expr')
- op_standard:
+ set_subname:
+ .local string subname
+ subname = optok['post']
+ if subname > '' goto set_subname_end
+ subname = node['ident']
+ if subname > '' goto set_subname_quote
+ subname = type
+ set_subname_quote:
+ subname = concat "'", subname
+ subname = concat subname, "'"
+ set_subname_end:
+
.local pmc past, children, iter
past = new 'Perl6::PAST::Op'
- past.set_node(node)
- children = new .ResizablePMCArray
+ past.'init'('node'=>node, 'op'=>type, 'name'=>subname)
$P0 = node.'get_array'()
if null $P0 goto iter_end
iter = new .Iterator, $P0
@@ -128,32 +164,18 @@
if $S0 == "" goto iter_loop
$P1 = tree.'get'('past', $P0, 'Perl6::Grammar::expr')
if null $P1 goto iter_loop
- push children, $P1
+ past.'add_child'($P1)
goto iter_loop
iter_end:
- past['opname'] = type
- past['children'] = children
- $S0 = op['pasttype']
- past['pasttype'] = $S0
- if type == 'infix:or' goto op_or
- if type != 'infix:||' goto subname
- op_or:
- children = 3
- $P0 = children[1]
- children[2] = $P0
+ if type == 'infix:or' goto infix_or
+ if type != 'infix:||' goto end
+ infix_or:
+ ## We cheat a bit here, moving the "then" portion of an 'or'
+ ## node to the 'else' portion.
+ $P0 = past[1]
+ past[2] = $P0
null $P0
- children[1] = $P0
-
- subname:
- $I0 = exists node['ident']
- if $I0 goto node_ident
- past['subname'] = type
- goto end
-
- node_ident:
- $S0 = node['ident']
- past['subname'] = $S0
-
+ past[1] = $P0
end:
.return (past)
}
@@ -200,94 +222,38 @@
Perl6::Grammar::integer: past(.) = {
.local pmc past
- past = new 'Perl6::PAST::Val'
- past.set_node(node)
- past['returns'] = 'int'
$I0 = node
- past['value'] = $I0
+ past = new 'Perl6::PAST::Val'
+ past.'init'('node'=>node, 'valtype'=>'int', 'val'=>$I0)
.return (past)
}
Perl6::Grammar::number: past(.) = {
.local pmc past
+ $N0 = node
past = new 'Perl6::PAST::Val'
- past.set_node(node)
- past['returns'] = 'num'
- $N0 = node.value()
- past['value'] = $N0
+ past.'init'('node'=>node, 'valtype'=>'num', 'val'=>$N0)
.return (past)
}
Perl6::Grammar::string_literal: past(.) = {
.local pmc past
- past = new 'Perl6::PAST::Val'
- past.set_node(node)
- past['returns'] = 'str'
$S0 = node
- past['value'] = $S0
+ past = new 'Perl6::PAST::Val'
+ past.'init'('node'=>node, 'valtype'=>'str', 'val'=>$S0)
.return (past)
}
Perl6::Grammar::version: past(.) = {
- .local pmc past
- past = new 'Perl6::PAST::Val'
- past.set_node(node)
- past['returns'] = 'str'
$S0 = node
$S0 = concat "'", $S0
- concat $S0, "'"
- past['value'] = $S0
- .return (past)
-}
-
-
-Perl6::Grammar::statement_control: past(.) = {
- .local pmc key, exprlist, blocklist
- .local int exprc, blockc
- .local pmc exprpast, thenpast, elsepast
- key = node[0]
- exprlist = node['expression']
- blocklist = node['block']
-
- # do we have an else clause?
- null elsepast
- else_block:
- exprc = elements exprlist
- blockc = elements blocklist
- if blockc <= exprc goto expr_block_pair
- dec blockc
- $P0 = blocklist[blockc]
- elsepast = tree.'get'('past', $P0, 'Perl6::Grammar::block')
-
- ## each remaining block is paired with an "if" (or "elsif")
- ## expression, except the first which could be an "unless".
- expr_block_pair:
- dec exprc
- dec blockc
- $P0 = exprlist[exprc]
- exprpast = tree.'get'('past', $P0, 'Perl6::Grammar::expression')
- $P0 = blocklist[blockc]
- thenpast = tree.'get'('past', $P0, 'Perl6::Grammar::block')
- if exprc > 0 goto if_op
- if key != 'unless' goto if_op
- exchange thenpast, elsepast
-
- if_op:
+ $S0 = concat $S0, "'"
.local pmc past
- past = new "Perl6::PAST::Op"
- past['opname'] = 'statement_control:if'
- past['pasttype'] = 'cond'
- $P0 = new .ResizablePMCArray
- $P0[0] = exprpast
- $P0[1] = thenpast
- $P0[2] = elsepast
- past['children'] = $P0
- elsepast = past
- if exprc > 0 goto expr_block_pair
-
+ past = new 'Perl6::PAST::Val'
+ past.'init'('node'=>node, 'valtype'=>'str', 'val'=>$S0)
.return (past)
}
@@ -304,14 +270,4 @@
}
-Perl6::Grammar::scoped_variables: past(.) = {
- .local pmc past
- past = new "Perl6::PAST::Lex"
- past.set_node(node)
- $P0 = node['variable']
- $S0 = $P0
- past['variable'] = $S0
- .return (past)
-}
-
## vim: expandtab sw=4
Modified: trunk/languages/perl6/perl6.pir
==============================================================================
--- trunk/languages/perl6/perl6.pir (original)
+++ trunk/languages/perl6/perl6.pir Wed May 3 12:35:46 2006
@@ -36,6 +36,11 @@
load_bytecode 'PGE/Util.pbc'
load_bytecode 'TGE.pbc'
+
+ $P0 = getclass 'TGE'
+ $P1 = subclass $P0, 'Perl6::PAST::Grammar'
+ $P1 = subclass $P0, 'Perl6::POST::Grammar'
+
$P0 = compreg 'PGE::P6Regex'
$P1 = $P0('^<Perl6::Grammar::program>')
store_global 'Perl6', '&parse', $P1
@@ -81,12 +86,16 @@
ast = astbuilder.get('past')
if target == 'PAST' goto return_ast
+ build_post:
+ .local pmc postgrammar, postbuilder, post
+ postgrammar = new 'Perl6::POST::Grammar'
+ postbuilder = postgrammar.'apply'(ast)
+ post = postbuilder.get('post')
+ if target == 'POST' goto return_post
+
build_pir:
- .local pmc pirgrammar, pirbuilder
.local string pir
- pirgrammar = new 'Perl6::PIR::Grammar'
- pirbuilder = pirgrammar.'apply'(ast)
- pir = pirbuilder.get('pir')
+ pir = post.'pir'()
if target == 'PIR' goto return_pir
compile_pir:
@@ -98,22 +107,33 @@
.return (match)
return_ast:
.return (ast)
+ return_post:
+ .return (post)
return_pir:
.return (pir)
.end
-.namespace [ 'Perl6::Grammar' ]
-.include 'lib/grammar_gen.pir'
-
.include 'lib/parse.pir'
.include 'lib/PAST.pir'
+.include 'lib/POST.pir'
+
.include 'lib/main.pir'
.include 'lib/builtins.pir'
+.namespace [ 'Perl6::Grammar' ]
+.include 'lib/grammar_gen.pir'
+
+.namespace [ 'Perl6::PAST::Grammar' ]
+.include 'lib/pge2past_gen.pir'
+
+.namespace [ 'Perl6::POST::Grammar' ]
+.include 'lib/past2post_gen.pir'
+
+
=back
=cut
