Author: allison
Date: Thu Nov 10 19:02:30 2005
New Revision: 9897
Added:
trunk/compilers/tge/ (props changed)
trunk/compilers/tge/README
trunk/compilers/tge/TGE/
trunk/compilers/tge/TGE.pir
trunk/compilers/tge/TGE/Instance.pir
trunk/compilers/tge/TGE/Parser.pir
trunk/compilers/tge/TGE/Rule.pir
trunk/compilers/tge/t/ (props changed)
trunk/compilers/tge/t/basic.t (contents, props changed)
trunk/compilers/tge/t/grammar.t (contents, props changed)
trunk/compilers/tge/t/harness (contents, props changed)
trunk/compilers/tge/t/parser.t (contents, props changed)
trunk/config/gen/makefiles/tge.in
Modified:
trunk/ (props changed)
trunk/MANIFEST
trunk/MANIFEST.SKIP
trunk/config/gen/makefiles.pl
Log:
Adding tree grammar engine as compilers/tge.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Thu Nov 10 19:02:30 2005
@@ -146,6 +146,13 @@ compilers/pge/PGE/OPTable.pir
compilers/pge/PGE/P6Rule.pir []
compilers/pge/PGE/Rule.pir []
compilers/pge/PGE/TokenHash.pir []
+compilers/tge/t/basic.t []
+compilers/tge/t/grammar.t []
+compilers/tge/t/parser.t []
+compilers/tge/TGE.pir []
+compilers/tge/TGE/Instance.pir []
+compilers/tge/TGE/Parser.pir []
+compilers/tge/TGE/Rule.pir []
config/auto/aio.pl []
config/auto/aio/aio.in []
config/auto/alignptrs.pl []
Modified: trunk/MANIFEST.SKIP
==============================================================================
--- trunk/MANIFEST.SKIP (original)
+++ trunk/MANIFEST.SKIP Thu Nov 10 19:02:30 2005
@@ -118,6 +118,15 @@
# generated from svn:ignore of 'compilers/pge/PGE/'
^compilers/pge/PGE/Library\.pir$
^compilers/pge/PGE/Library\.pir/
+# generated from svn:ignore of 'compilers/tge/'
+^compilers/tge/Makefile$
+^compilers/tge/Makefile/
+^compilers/tge/.*\.pbc$
+^compilers/tge/.*\.pbc/
+# generated from svn:ignore of 'compilers/tge/TGE/'
+# generated from svn:ignore of 'compilers/tge/t/'
+^compilers/tge/t/.*\.pir$
+^compilers/tge/t/.*\.pir/
# generated from svn:ignore of 'config/'
# generated from svn:ignore of 'config/auto/'
# generated from svn:ignore of 'config/auto/aio/'
Added: trunk/compilers/tge/README
==============================================================================
--- (empty file)
+++ trunk/compilers/tge/README Thu Nov 10 19:02:30 2005
@@ -0,0 +1,14 @@
+TGE - Tree Grammar Engine
+Copyright 2005, The Perl Foundation.
+
+TGE is a tool for transforming trees. It's most heavily used in the
+compiler tools suite, where it transforms the trees output by PGE into
+abstract syntax trees.
+
+INSTALLATION
+
+Compile TGE to bytecode and run its test suite:
+
+ $ make
+ $ make test
+
Added: trunk/compilers/tge/TGE.pir
==============================================================================
--- (empty file)
+++ trunk/compilers/tge/TGE.pir Thu Nov 10 19:02:30 2005
@@ -0,0 +1,234 @@
+# Copyright 2005, The Perl Foundation.
+
+=head1 NAME
+
+TGE - A tree grammar engine.
+
+=head1 SYNOPSIS
+
+ # define a grammar leaf.g
+ Leaf: min(.) = {
+ $P1 = getattribute node, "value"
+ .return ($P1)
+ }
+ ...
+ # and elsewhere...
+
+ .sub _main :main
+ load_bytecode 'TGE.pir'
+
+ # Compile a grammar from the source grammar file
+ .local pmc grammar
+ grammar = new 'TGE'
+ grammar.agcompile(source)
+
+ .local pmc tree
+ # ... the tree to be manipulated
+
+ # Apply the grammar to the tree
+ .local pmc TGI
+ TGI = grammar.apply(tree)
+
+ # Return the result of a particular rule on a particular tree
+ .local pmc result
+ result = TGI.get('min')
+ # ...
+ .end
+
+=head1 DESCRIPTION
+
+TGE is a tool for transforming trees. Think of it as a good
+old-fashioned substitution, but instead of taking and returning strings,
+it takes and returns trees.
+
+TGE is most heavily used in the compiler tools suite, where it
+transforms the trees output by PGE into abstract syntax trees.
+
+TGE has both a procedural interface and a syntax interface. The syntax
+interface is easiest for humans to use when constructing grammars by
+hand. The procedural interface is preferable for computer generated
+grammars.
+
+This is the syntax for tree grammar rules:
+
+ type: name(parent) = {
+ # action
+ }
+
+The I<type> is the type of node this particular rule applies to. The
+I<name> is the name of the attribute the rule defines a value for. The
+I<parent> says which node the attribute applies to: '.' if the attribute
+applies to the current node (generally synthesized attributes),
+'.childname' if the attribute applies to a child of the current node
+(generally inherited attributes). The I<action> is a block of PIR code
+run to get the value of the attribute. Within the block, two parameters
+are supplied for you: C<node> is the current node considered, and
+C<tree> is the top-level node for the entire tree.
+
+=cut
+
+.namespace [ 'TGE' ]
+
+.sub '__onload' :load
+ # use other modules
+ load_bytecode 'compilers/tge/TGE/Rule.pir'
+ load_bytecode 'compilers/tge/TGE/Instance.pir'
+ load_bytecode "compilers/tge/TGE/Parser.pir"
+
+ # define the class
+ .local pmc base
+ newclass base, 'TGE'
+ addattribute base, 'rules' # the rules in the grammar (an array)
+ .return ()
+.end
+
+=head2 new
+
+Create a new grammar object. [Not implemented: Optionally pass it a
+grammar specification in a string.] The grammar object holds a an array
+of TGE::Rule objects, which are the semantics defined by the grammar.
+
+=cut
+
+.sub __init method
+ $P1 = new PerlArray
+ setattribute self, 'rules', $P1
+.end
+
+=head2 agrule
+
+Add a rule to the current attribute grammar.
+
+=cut
+
+.sub 'agrule' method
+ .param pmc type
+ .param pmc name
+ .param pmc parent
+ .param pmc action
+
+ # create a new attribute grammar rule
+ .local pmc rule
+ rule = new 'TGE::Rule'
+ setattribute rule, 'type', type
+ setattribute rule, 'name', name
+ setattribute rule, 'parent', parent
+ setattribute rule, 'action', action
+
+ # add the new rule to the grammar object
+ $P3 = getattribute self, 'rules'
+ push $P3, rule
+.end
+
+=head2 agcompile
+
+Compile a grammar from a source string.
+
+=cut
+
+.sub 'agcompile' method
+ .param string source
+ .local pmc agparse
+ .local pmc rule_data
+
+ agparse = find_global 'TGE::Parser', 'agparse'
+ rule_data = agparse(source)
+
+ # Construct grammar rules from the data structure of rule info
+ .local pmc rule
+ .local pmc code
+ .local pmc iter
+ iter = new Iterator, rule_data # loop over the rule info
+ iter = 0 # start at the beginning
+loop_start:
+ unless iter goto loop_end
+ rule = shift iter
+ $P1 = rule["type"]
+ $P2 = rule["name"]
+ $P3 = rule["parent"]
+ $P4 = rule["action"]
+ code = new PerlString
+ code = ".sub _anon :anon\n"
+ code .= " .param pmc tree\n"
+ code .= " .param pmc node\n"
+ code .= $P4
+ code .= "\n.end"
+ $P5 = compreg "PIR"
+ $P6 = $P5(code)
+ self.agrule($P1, $P2, $P3, $P6)
+ goto loop_start
+loop_end:
+ .return ()
+.end
+
+=head2 apply
+
+Use a precompiled grammar on a data structure. This returns an
+object on which you can call methods to fetch attributes on the
+I<top node> of the data structure.
+
+=cut
+
+.sub 'apply' method
+ .param pmc tree
+ .local pmc newtree
+ .local pmc visit
+ newtree = new 'TGE::Instance'
+ setattribute newtree, 'data', tree
+ visit = getattribute newtree, 'visit'
+ # Build up the visit hash
+ .local pmc rules
+ .local int index
+ .local pmc currule
+ .local pmc cell
+ .local pmc typename
+ rules = getattribute self, 'rules'
+
+ index = rules
+loop:
+ dec index
+ if index < 0 goto end_loop
+ currule = rules[index]
+ typename = getattribute currule, 'type'
+ $P2 = visit[typename]
+ $S1 = typeof $P2
+ if $S1 == 'PerlArray' goto array_exists
+ $P2 = new PerlArray
+ visit[typename] = $P2
+array_exists:
+ push $P2, currule
+ goto loop
+end_loop:
+
+ newtree._scan_node(tree, 'ROOT')
+ .return (newtree)
+.end
+
+=head2 dump
+
+Produce a data dump of the current contents of the grammar object.
+
+=cut
+
+.sub 'dump' method
+ $P0 = getattribute self, 'rules'
+ $I1 = $P0
+
+ print "VAR1 => { \n\t 'rules' =>\n"
+LOOP:
+ dec $I1
+ $P1 = $P0[$I1]
+ print "\t\t [\n"
+ $P1.dump()
+ print "\t\t ],\n"
+ if $I1 > 0 goto LOOP
+
+
+ print "\t}\n"
+.end
+
+=head1 AUTHOR
+
+Allison Randal <[EMAIL PROTECTED]>
+
+=cut
Added: trunk/compilers/tge/TGE/Instance.pir
==============================================================================
--- (empty file)
+++ trunk/compilers/tge/TGE/Instance.pir Thu Nov 10 19:02:30 2005
@@ -0,0 +1,266 @@
+# Copyright 2005, The Perl Foundation.
+
+=head1 NAME
+
+TGE::Instance - the runtime engine for TGE
+
+=head1 DESCRIPTION
+
+=cut
+
+.namespace [ "TGE::Instance" ]
+
+.sub "__onload" :load
+ # define the class
+ .local pmc base
+ newclass base, "TGE::Instance"
+ addattribute base, "cell" # a hash for storing values of tree nodes
+ addattribute base, "visit" # arrays of rules that apply to each node type
+ addattribute base, "data" # the original unmodified tree
+ .return ()
+.end
+
+=head2 new
+
+Returns a simple initialized TGE::Instance object. Doesn't accept any
+constructor parameters.
+
+=cut
+
+.sub __init method
+ $P0 = new PerlHash
+ $P1 = new PerlHash
+ $P2 = new PerlUndef
+ setattribute self, "cell", $P0
+ setattribute self, "visit", $P1
+ setattribute self, "data", $P2
+.end
+
+# Call all visitors for a given node
+.sub _scan_node method
+ .param pmc node
+ .param pmc name
+ .local string type
+
+ # If the user passed in a special name, look up visit actions for that one,
+ # otherwise look them up for the type name of the node.
+ $I1 = defined name
+ if $I1 goto name_from_arg
+ type = typeof node
+ goto name_set
+name_from_arg:
+ type = name
+name_set:
+
+ # Iterate over the elements of the visit hash for the given type
+ .local pmc actions
+ .local int index
+ .local pmc currule
+ $P2 = getattribute self, 'visit'
+ actions = $P2[type]
+ $I2 = defined actions
+ unless $I2 goto end_loop
+ index = actions
+loop:
+ dec index
+ if index < 0 goto end_loop
+ currule = actions[index]
+ self._install_action(node, currule)
+ goto loop
+end_loop:
+ .return()
+.end
+
+=head2 get
+
+ value = AGI.get('attrname')
+
+Fetches the value of a particular attribute from the root node of the
+grammar.
+
+ value = AGI.get('attrname', node)
+ value = AGI.get('attrname', node, 'type')
+
+Fetches the value of a particular attribute from the node passed in.
+When working with a tree where the nodes don't know their type (PGE
+match objects, for example), you must also tell C<get> the type of the
+node.
+
+=cut
+
+.sub get method
+ .param pmc name
+ .param pmc node
+ .param pmc type
+
+ # If no node was passed in, use top level node.
+ unless null node goto node_exists
+ node = getattribute self, 'data'
+node_exists:
+
+ .local pmc id
+ id = _lookup_id(node)
+
+ .local pmc cell
+ $P1 = getattribute self, "cell"
+ # First check to see if cell is defined
+ $P2 = $P1[name]
+ $I1 = defined $P2
+ if $I1 goto name_hash_exists
+ $P2 = new PerlHash
+ $P1[name] = $P2
+ goto scan_name
+name_hash_exists:
+ cell = $P2[id]
+ $I0 = defined cell
+ if $I0 goto eval_cell
+scan_name:
+ self._scan_node(node,type)
+ # Second check to see if _scan_node defined the cell
+ cell = $P2[id]
+ $I0 = defined cell
+ if $I0 goto eval_cell
+ # Cell still not defined, grammar is unresolvable.
+ print "Cannot find the attribute '"
+ print name
+ print "' ("
+ $S1 = typeof node
+ print $S1
+ print ") that you asked for.\n"
+ .return ()
+eval_cell:
+ $P3 = self._eval_cell(cell,node)
+ .return($P3)
+.end
+
+# Evaluate a thunk.
+.sub _eval_cell method
+ .param pmc cell
+ .param pmc node
+ .local pmc value
+ $I0 = cell['thunk']
+ if $I0 goto run_thunk_action
+ goto return_value
+run_thunk_action:
+ # the stored node (parent for inherited attributes, self for
+ # synthesized attributes)
+ $P1 = cell['node']
+ $P0 = cell['action']
+ value = $P0(self, $P1)
+ cell['value'] = value
+ cell['thunk'] = 0
+
+return_value:
+ value = cell['value']
+ .return (value)
+.end
+
+# Install a thunk in a particular attribute slot of a particular object.
+.sub _install_action method
+ .param pmc node
+ .param pmc rule
+
+ # Grab the 'cell' hash from the grammar object.
+ .local pmc cell_hash
+ cell_hash = getattribute self, 'cell'
+
+ # Retrieve the hash within 'cell' keyed by the name of the attribute.
+ # If the hash doesn't exist, create it.
+ .local pmc name
+ .local pmc cellattr
+ name = getattribute rule, "name"
+ cellattr = cell_hash[name]
+ $I1 = defined cellattr
+ if $I1 goto name_hash_exists
+ cellattr = new PerlHash
+ cell_hash[name] = cellattr
+name_hash_exists:
+
+ # Decide which node to operate on. If 'parent' was '.', then operate on
+ # the node passed in, otherwise, operate on a child node named in
+ # 'parent'.
+ .local pmc id
+ .local pmc parent
+ parent = getattribute rule, 'parent'
+ if parent == '.' goto use_parent_id
+ .local pmc child_node
+ child_node = self._lookup_child(node, parent)
+ id = _lookup_id(child_node)
+ goto use_child_id
+use_parent_id:
+ id = _lookup_id(node)
+use_child_id:
+
+ # Check that the entry (by attribute name and id) in the "cell" hash
+ # doesn't already exist (the grammar should only create one entry
+ # for each unique node id).
+ $P3 = cellattr[id]
+ $I2 = defined $P3
+ if $I2 goto error_defined
+
+ # Create the entry in the "cell" tree that stores the action to
+ # calculate the value of a given attribute in a given node. Also
+ # store an empty space for the value after it has been calculated,
+ # and a flag ("thunk") noting whether the action has been run.
+ .local pmc thunk
+ thunk = new PerlHash
+ thunk['thunk'] = 1
+ $P4 = getattribute rule, "action"
+ thunk['action'] = $P4
+ $P5 = new PerlUndef
+ thunk['value'] = $P5
+ thunk['node'] = node
+ cellattr[id] = thunk
+
+ .return()
+error_defined:
+ print "Nonlinear attribute: you have two or more ways to "
+ print "assign a value to the attribute '"
+ print name
+ print "' near grammar line "
+ $P7 = getattribute rule, "line"
+ print $P7
+ print "\n"
+ end
+.end
+
+# This determines the semantics of .attr.
+.sub _lookup_child method
+ .param pmc node
+ .param pmc name
+ $S0 = name
+ $S1 = substr $S0, 1
+ $P1 = getattribute node, $S1
+ .return($P1)
+.end
+
+.sub _lookup_id
+ .param pmc node
+ .local pmc id
+ # Get the id of the node, or if it doesn't exist, generate one.
+ id = getprop "agid", node
+ $I0 = defined id
+ if $I0 goto got_id
+ id = new PerlInt
+ id = _new_id()
+ setprop node, "agid", id
+got_id:
+ .return (id)
+.end
+
+# Autoincrementing id generator
+.sub _new_id
+ .local int id
+ id = 0
+loop:
+ inc id
+ .yield(id)
+ goto loop
+.end
+
+
+=head1 AUTHOR
+
+Allison Randal <[EMAIL PROTECTED]>
+
+=cut
Added: trunk/compilers/tge/TGE/Parser.pir
==============================================================================
--- (empty file)
+++ trunk/compilers/tge/TGE/Parser.pir Thu Nov 10 19:02:30 2005
@@ -0,0 +1,200 @@
+# Copyright 2005, The Perl Foundation.
+
+=head1 NAME
+
+TGE::Parser - parser for the grammar syntax of TGE
+
+=head1 DESCRIPTION
+
+=cut
+
+.namespace [ 'TGE::Parser' ]
+
+.sub _load :load
+ load_bytecode 'PGE.pbc'
+
+ .local string classname
+ classname = 'TGE::Parser'
+ $P0 = getclass 'PGE::Rule'
+ $P1 = subclass $P0, classname
+
+ # Construct the grammar
+ .local pmc p6rule
+ find_global p6rule, 'PGE', 'p6rule'
+
+ p6rule('[<TGE::Parser::skip>|<TGE::Parser::rule>]*$', classname, 'input')
+ p6rule('<TGE::Parser::type> \: <TGE::Parser::attrdef> \s*', classname,
'rule')
+ p6rule('<TGE::Parser::name> <TGE::Parser::parenlist> \=
<TGE::Parser::codeblock>', classname, 'attrdef')
+ p6rule('\( \s* (.*?) \s* \)\s*', classname, 'parenlist')
+ p6rule('\s* { \s* (.*?) \s* }', classname, 'codeblock')
+ p6rule('[ \:\: ]? \w+ [ \:\: \w+ ]*', classname, 'type')
+ p6rule('\s*(\w+)\s*', classname, 'name')
+ p6rule('\s* \# \N*? $$\s*', classname, 'skip')
+.end
+
+=head2 agparse
+
+Take the source string for a tree grammar, and return a sensible data
+structure.
+
+=cut
+
+.sub agparse
+ .param string source
+
+ # Parse the source string and build a match tree
+ .local pmc match
+ .local pmc start_rule
+ start_rule = find_global "TGE::Parser", "input"
+ match = start_rule(source)
+ # Verify the parse
+ $I0 = match.__get_bool()
+ unless $I0 goto err_parse # if parse fails, stop
+
+ .local pmc grammar
+ grammar = _load_grammar()
+
+ # Transform the parse tree and return the result
+ .local pmc tree_match
+ tree_match = grammar.apply(match)
+ $P5 = tree_match.get('result')
+ .return($P5)
+
+ err_parse:
+ print "Unable to parse the tree grammar.\n"
+ end
+.end
+
+.sub _load_grammar
+ # Construct a tree grammar for manipulating the parse tree
+ .local pmc grammar
+ grammar = new "TGE"
+ $P3 = find_global "TGE::Parser", "ROOT_result"
+ grammar.agrule("ROOT", "result", ".", $P3)
+ $P3 = find_global "TGE::Parser", "rule_result"
+ grammar.agrule("rule", "result", ".", $P3)
+ $P3 = find_global "TGE::Parser", "type_value"
+ grammar.agrule("type", "value", ".", $P3)
+ $P3 = find_global "TGE::Parser", "attrdef_name"
+ grammar.agrule("attrdef", "name", ".", $P3)
+ $P3 = find_global "TGE::Parser", "attrdef_parent"
+ grammar.agrule("attrdef", "parent", ".", $P3)
+ $P3 = find_global "TGE::Parser", "attrdef_action"
+ grammar.agrule("attrdef", "action", ".", $P3)
+
+ .return (grammar)
+.end
+
+.sub ROOT_result
+ .param pmc tree
+ .param pmc node
+ .local pmc rules
+ $I0 = defined node["TGE::Parser::rule"]
+ unless $I0 goto err_no_tree
+ $P0 = node["TGE::Parser::rule"]
+
+ # Iterate over the list of rules, and generate a processed tree for
+ # each rule. Return an array of all the processed rules.
+ .local pmc iter
+ rules = new PerlArray
+ iter = new Iterator, $P0 # loop over the array
+ iter = 0 # start at the beginning
+loop_start:
+ unless iter goto loop_end
+ $P1 = shift iter
+ $P2 = tree.get('result', $P1, 'rule')
+ push rules, $P2
+ goto loop_start
+loop_end:
+ .return (rules)
+
+err_no_tree:
+ print "This grammar contained no rules.\n"
+ .return ()
+.end
+
+.sub rule_result
+ .param pmc tree
+ .param pmc node
+ .local pmc rule
+ rule = new PerlHash
+
+ # Get the type name
+ $I0 = defined node["TGE::Parser::type"]
+ unless $I0 goto err_no_rule
+ $P1 = node["TGE::Parser::type"]
+ $P2 = tree.get('value', $P1, 'type')
+ rule["type"] = $P2
+
+ $I0 = defined node["TGE::Parser::attrdef"]
+ unless $I0 goto err_no_rule
+ $P3 = node["TGE::Parser::attrdef"]
+ $P4 = tree.get('name', $P3, 'attrdef')
+ rule["name"] = $P4
+ $P4 = tree.get('parent', $P3, 'attrdef')
+ rule["parent"] = $P4
+ $P4 = tree.get('action', $P3, 'attrdef')
+ rule["action"] = $P4
+ $S0 = typeof $P1
+ .return (rule)
+
+err_no_rule:
+ print "Unable to find all the components of a rule definition\n"
+ return ()
+.end
+
+# The attribute 'value' on nodes of type 'type'.
+.sub type_value
+ .param pmc tree
+ .param pmc node
+ .local pmc value
+ value = new PerlString
+ $S2 = node
+ value = $S2
+ .return (value)
+.end
+
+# The attribute 'name' on nodes of type 'attrdef'.
+.sub attrdef_name
+ .param pmc tree
+ .param pmc node
+ .local pmc name
+ name = new PerlString
+ $P2 = node["TGE::Parser::name"]
+ $P3 = $P2[0]
+ $S1 = $P3
+ name = $S1
+ .return (name)
+.end
+
+# The attribute 'parent' on nodes of type 'attrdef'.
+.sub attrdef_parent
+ .param pmc tree
+ .param pmc node
+ .local pmc name
+ name = new PerlString
+ $P2 = node["TGE::Parser::parenlist"]
+ $P3 = $P2[0]
+ $S1 = $P3
+ name = $S1
+ .return (name)
+.end
+
+# The attribute 'action' on nodes of type 'attrdef'.
+.sub attrdef_action
+ .param pmc tree
+ .param pmc node
+ .local pmc name
+ name = new PerlString
+ $P2 = node["TGE::Parser::codeblock"]
+ $P3 = $P2[0]
+ $S1 = $P3
+ name = $S1
+ .return (name)
+.end
+
+=head1 AUTHOR
+
+Allison Randal <[EMAIL PROTECTED]>
+
+=cut
Added: trunk/compilers/tge/TGE/Rule.pir
==============================================================================
--- (empty file)
+++ trunk/compilers/tge/TGE/Rule.pir Thu Nov 10 19:02:30 2005
@@ -0,0 +1,70 @@
+# Copyright 2005, The Perl Foundation.
+
+=head1 NAME
+
+TGE::Rule - a single rule in the attribute grammar
+
+=head1 DESCRIPTION
+
+A basic class to hold defined attribute grammar rules.
+
+=cut
+
+.namespace [ "TGE::Rule" ]
+
+# Possibly better named "type", "name", "parent", "action/exec",
+# "copy/value"
+
+.sub "__onload" :load
+ .local pmc base
+ newclass base, "TGE::Rule"
+ addattribute base, "type" # node type that this rule applies to
+ addattribute base, "name" # name of attribute being defined
+ addattribute base, "parent" # where the attribute is applied
+ # (current node or child node)
+ addattribute base, "action" # a compiled subroutine
+ addattribute base, "line" # line number in the grammar source file
+ .return ()
+.end
+
+=head2 new
+
+Create a new rule object. A rule object holds the semantics for a single
+attribute grammar rule.
+
+=cut
+
+.sub __init method
+ $P0 = new PerlUndef
+ $P1 = new PerlUndef
+ $P2 = new PerlUndef
+ $P3 = new PerlUndef
+ $P4 = new PerlUndef
+ $P5 = new Sub
+ setattribute self, "type", $P0
+ setattribute self, "name", $P1
+ setattribute self, "parent", $P2
+ setattribute self, "line", $P4
+ setattribute self, "action", $P5
+.end
+
+=head2 dump
+
+Produce a data dump of the current contents of the rule object.
+
+=cut
+
+.sub "dump" method
+ $P0 = getattribute self, "type"
+ print "\t\t\t'type' => '"
+ print $P0
+ print "',\n"
+ $P1 = getattribute self, "name"
+ print "\t\t\t'name' => '"
+ print $P1
+ print "',\n"
+ $P2 = getattribute self, "parent"
+ print "\t\t\t'parent' => '"
+ print $P2
+ print "',\n"
+.end
Added: trunk/compilers/tge/t/basic.t
==============================================================================
--- (empty file)
+++ trunk/compilers/tge/t/basic.t Thu Nov 10 19:02:30 2005
@@ -0,0 +1,73 @@
+#! perl -w
+# Copyright 2005, The Perl Foundation.
+
+=head1 NAME
+
+t/basic.t - testing a few basic components of TGE and TGE::Instance
+
+=head1 SYNOPSIS
+
+ $ perl t/basic.t
+
+=cut
+
+use strict;
+
+use lib qw(t . lib ../lib ../../lib ../../../lib);
+
+use Parrot::Test tests => 2;
+
+pir_output_is(<<'CODE', <<'OUT', 'build up a basic rule in a grammar');
+
+.sub _main :main
+ load_bytecode 'compilers/tge/TGE.pir'
+
+ .local pmc AG
+ AG = new 'TGE'
+ AG.agrule('Leaf', 'min', '.', '.return(1)')
+
+ $P1 = getattribute AG, 'rules'
+ .local pmc rule_obj
+ rule_obj = $P1[0]
+ $P2 = getattribute rule_obj, 'type'
+ print $P2
+ print "\n"
+ $P3 = getattribute rule_obj, 'name'
+ print $P3
+ print "\n"
+ $P4 = getattribute rule_obj, 'parent'
+ print $P4
+ print "\n"
+ end
+.end
+
+CODE
+Leaf
+min
+.
+OUT
+
+pir_output_is(<<'CODE', <<'OUT', 'autoincrementing id generator');
+.sub _main :main
+ load_bytecode 'compilers/tge/TGE/Instance.pir'
+
+ .local pmc new_id
+ new_id = find_global 'TGE::Instance', '_new_id'
+ .local int id
+ id = new_id()
+ print id
+ print "\n"
+ id = new_id()
+ print id
+ print "\n"
+ id = new_id()
+ print id
+ print "\n"
+ end
+.end
+
+CODE
+1
+2
+3
+OUT
Added: trunk/compilers/tge/t/grammar.t
==============================================================================
--- (empty file)
+++ trunk/compilers/tge/t/grammar.t Thu Nov 10 19:02:30 2005
@@ -0,0 +1,228 @@
+#! perl -w
+# Copyright 2005, The Perl Foundation.
+
+=head1 NAME
+
+t/parser.t - TGE::Parser tests
+
+=head1 SYNOPSIS
+
+ $ perl t/parser.t
+
+=head1 DESCRIPTION
+
+This is a test script to try out constructing a tree grammar from a tree
+grammar syntax file, and using the constructed grammar to transform a
+tree of the specified type.
+
+=cut
+
+use strict;
+
+use lib qw(t . lib ../lib ../../lib ../../../lib);
+
+use Parrot::Test tests => 1;
+
+pir_output_is(<<'CODE', <<'OUT', "complete example: Branch/Leaf tree grammar");
+
+.sub _main :main
+ .param pmc argv
+
+ load_bytecode "compilers/tge/TGE.pir"
+
+ # Load the grammar in a string
+ .local string source
+ source = <<'GRAMMAR'
+ Leaf: min(.) = {
+ $P1 = getattribute node, "value"
+ .return ($P1)
+ }
+
+ Branch: min(.) = {
+ .local pmc left
+ .local pmc right
+ .local pmc min
+ .local pmc left_val
+ .local pmc right_val
+
+ left = getattribute node, "left"
+ left_val = tree.get('min', left)
+ right = getattribute node, "right"
+ right_val = tree.get('min', right)
+
+ min = left_val
+ if min <= right_val goto got_min
+ min = right_val
+ got_min:
+ .return (min)
+ }
+
+ # find the global minimum and propagate it back down the tree
+ ROOT: gmin(.) = {
+ .local pmc gmin
+ gmin = new PerlInt
+ gmin = tree.get('min', node)
+ .return (gmin)
+ }
+
+ Branch: gmin(.left) = {
+ .local pmc gmin
+ gmin = tree.get('gmin', node)
+ .return (gmin)
+ }
+
+ Branch: gmin(.right) = {
+ .local pmc gmin
+ gmin = tree.get('gmin', node)
+ .return (gmin)
+ }
+
+ # reconstruct the tree with every leaf replaced with the minimum
+ # value
+ Leaf: result(.) = {
+ .local pmc newnode
+
+ newnode = new 'Leaf'
+ $P1 = tree.get('gmin', node)
+ setattribute newnode, 'value', $P1
+ .return(newnode)
+ }
+
+ Branch: result(.) = {
+ .local pmc newnode
+ .local pmc left_child
+ .local pmc right_child
+ newnode = new 'Branch'
+ left_child = getattribute node, 'left'
+ right_child = getattribute node, 'right'
+ $P1 = tree.get('result', left_child)
+ $P2 = tree.get('result', right_child)
+
+ setattribute newnode, 'left', $P1
+ setattribute newnode, 'right', $P2
+ .return(newnode)
+ }
+GRAMMAR
+
+ # Compile a grammar from the source
+ .local pmc grammar
+ grammar = new 'TGE'
+ grammar.agcompile(source)
+
+ # Build up the tree for testing
+ .local pmc tree
+ tree = buildtree()
+
+ # Apply the grammar to the test tree
+ .local pmc AGI
+ AGI = grammar.apply(tree)
+
+ # Retrieve the value of a top level attribute
+ $P4 = AGI.get('gmin')
+ print "the global minimum attribute value is: "
+ print $P4
+ print " of type: "
+ $S4 = typeof $P4
+ print $S4
+ print "\n"
+
+ # Rerieve the transformed tree
+ $P5 = AGI.get('result')
+
+ $P6 = getattribute tree, 'left'
+ $P7 = getattribute $P6, 'left'
+ $P8 = getattribute $P7, 'value'
+ print "before transform, the value of the left-most leaf is: "
+ print $P8
+ print "\n"
+
+ $P6 = getattribute $P5, 'left'
+ $P7 = getattribute $P6, 'left'
+ $P8 = getattribute $P7, 'value'
+ print "after transform, the value of the left-most leaf is: "
+ print $P8
+ print "\n"
+
+ $P10 = getattribute tree, 'right'
+ $P11 = getattribute $P10, 'right'
+ $P12 = getattribute $P11, 'right'
+ $P13 = getattribute $P12, 'value'
+ print "before transform, the value of the right-most leaf is: "
+ print $P13
+ print "\n"
+
+ $P10 = getattribute $P5, 'right'
+ $P11 = getattribute $P10, 'right'
+ $P12 = getattribute $P11, 'right'
+ $P13 = getattribute $P12, 'value'
+ print "after transform, the value of the right-most leaf is: "
+ print $P13
+ print "\n"
+
+ end
+
+ err_parse:
+ print "Unable to parse the tree grammar.\n"
+ end
+.end
+
+# ----------------------------------
+.sub buildtree
+ # Create Leaf class
+ newclass $P1, "Leaf"
+ addattribute $P1, "value" # the value of the leaf node
+
+ # Create Branch class
+ newclass $P2, "Branch"
+ addattribute $P2, "left" # left child
+ addattribute $P2, "right" # right child
+
+ $P0 = build_Leaf(5)
+ $P1 = build_Leaf(9)
+ $P2 = build_Branch($P0, $P1)
+
+ $P3 = build_Leaf(1)
+ $P4 = build_Branch($P3, $P2)
+
+ $P5 = build_Leaf(2)
+ $P6 = build_Leaf(3)
+ $P7 = build_Branch($P5, $P6)
+
+ $P8 = build_Branch($P7, $P4)
+
+ .return($P8)
+.end
+
+.sub build_Leaf
+ .param int value
+ .local pmc newnode
+ newnode = new 'Leaf'
+ $P1 = new PerlInt
+ $P1 = value
+ setattribute newnode, 'value', $P1
+ .return(newnode)
+.end
+
+.sub build_Branch
+ .param pmc left_child
+ .param pmc right_child
+ .local pmc newnode
+ newnode = new 'Branch'
+ setattribute newnode, 'left', left_child
+ setattribute newnode, 'right', right_child
+ .return(newnode)
+.end
+
+CODE
+the global minimum attribute value is: 1 of type: PerlInt
+before transform, the value of the left-most leaf is: 2
+after transform, the value of the left-most leaf is: 1
+before transform, the value of the right-most leaf is: 9
+after transform, the value of the right-most leaf is: 1
+OUT
+
+=head1 AUTHOR
+
+Allison Randal <[EMAIL PROTECTED]>
+
+=cut
Added: trunk/compilers/tge/t/harness
==============================================================================
--- (empty file)
+++ trunk/compilers/tge/t/harness Thu Nov 10 19:02:30 2005
@@ -0,0 +1,25 @@
+#! perl -w
+
+use strict;
+
+use Test::Harness;
+use File::Spec;
+
+my @files;
+
+# Per Leo on 18APR2005, run the test suite with --gc-debug
+
+if ($ENV{TEST_PROG_ARGS} && $ENV{TEST_PROG_ARGS} !~ /\b--gc-debug\b/) {
+ $ENV{TEST_PROG_ARGS} .= " --gc-debug";
+}
+
+if (@ARGV) {
+ # Someone specified tests for me to run.
+ @files = grep {-f $_} @ARGV
+} else {
+ # Called with no args, run the full suite.
+ @files = glob( File::Spec->catfile( "t", "*.t" ) );
+}
+
+exit unless @files;
+runtests(@files);
Added: trunk/compilers/tge/t/parser.t
==============================================================================
--- (empty file)
+++ trunk/compilers/tge/t/parser.t Thu Nov 10 19:02:30 2005
@@ -0,0 +1,64 @@
+#! perl -w
+# Copyright 2005, The Perl Foundation.
+
+=head1 NAME
+
+t/parser.t - TGE::Parser tests
+
+=head1 SYNOPSIS
+
+ $ perl t/parser.t
+
+=cut
+
+use strict;
+
+use lib qw(t . lib ../lib ../../lib ../../../lib);
+
+use Parrot::Test tests => 1;
+
+pir_output_is(<<'CODE', <<'OUT', "parse a basic attribute grammar");
+
+.sub _main :main
+ load_bytecode "compilers/tge/TGE/Parser.pir"
+
+ .local string source
+ source = <<'GRAMMAR'
+ Leaf: min(.) = {
+ $P1 = getattribute node, "value"
+ .return ($P1)
+ }
+ # A test comment
+ Branch: gmin(.left) = {
+ .local pmc gmin
+ gmin = tree.get('gmin', node)
+ .return (gmin)
+ }
+GRAMMAR
+
+ # Match against the source
+ .local pmc match
+ .local pmc start_rule
+ start_rule = find_global "TGE::Parser", "input"
+ print "loaded start rule\n"
+ match = start_rule(source)
+ print "matched start rule\n"
+
+ # Verify the match
+ $I0 = match.__get_bool()
+ unless $I0 goto match_fail # if match fails stop
+ print "parse succeeded\n"
+ goto cleanup
+
+ match_fail:
+ print "parse failed\n"
+
+ cleanup:
+ end
+.end
+
+CODE
+loaded start rule
+matched start rule
+parse succeeded
+OUT
Modified: trunk/config/gen/makefiles.pl
==============================================================================
--- trunk/config/gen/makefiles.pl (original)
+++ trunk/config/gen/makefiles.pl Thu Nov 10 19:02:30 2005
@@ -55,6 +55,9 @@ sub makefiles {
genfile('config/gen/makefiles/pge.in' => 'compilers/pge/Makefile',
commentType => '#',
replace_slashes => 1);
+ genfile('config/gen/makefiles/tge.in' => 'compilers/tge/Makefile',
+ commentType => '#',
+ replace_slashes => 1);
genfile('config/gen/makefiles/editor.in' => 'editor/Makefile',
commentType => '#',
replace_slashes => 1);
Added: trunk/config/gen/makefiles/tge.in
==============================================================================
--- (empty file)
+++ trunk/config/gen/makefiles/tge.in Thu Nov 10 19:02:30 2005
@@ -0,0 +1,54 @@
+# $Id: /offline/parrot/config/gen/makefiles/pge.in 555
2005-11-02T15:45:50.040165Z svm $
+
+# Setup some commands
+LN_S = ${lns}
+PERL = ${perl}
+RM_RF = ${rm_rf}
+PARROT = ..${slash}..${slash}parrot${exe}
+CP = ${cp}
+
+# Where to put things
+PARROT_LIBRARY = ..${slash}..${slash}runtime${slash}parrot${slash}library
+
+# the default target
+all: $(PARROT_LIBRARY)${slash}TGE.pbc
+
+$(PARROT_LIBRARY)${slash}TGE.pbc: TGE.pbc
+ $(CP) TGE.pbc $(PARROT_LIBRARY)
+
+TGE.pbc: TGE.pir TGE/Rule.pir TGE/Parser.pir TGE/Instance.pir
+ $(PARROT) -o TGE.pbc --output-pbc TGE.pir
+
+# This is a listing of all targets, that are meant to be called by users
+help:
+ @echo ""
+ @echo "Following targets are available for the user:"
+ @echo ""
+ @echo " all: TGE.pbc"
+ @echo " This is the default."
+ @echo "Testing:"
+ @echo " test: Run the test suite."
+ @echo " testclean: Clean up test results."
+ @echo ""
+ @echo "Cleaning:"
+ @echo " clean: Basic cleaning up."
+ @echo " realclean: Removes also files generated by
'Configure.pl'"
+ @echo " distclean: Removes also anything built, in theory"
+ @echo ""
+ @echo "Misc:"
+ @echo " help: Print this help message."
+ @echo ""
+
+test: all
+ $(PERL) -Ilib t/harness t/*.t
+
+testclean:
+ $(RM_RF) t/*.pir
+
+clean: testclean
+ $(RM_RF) TGE.pbc $(PARROT_LIBRARY)${slash}TGE.pbc
+
+realclean: clean
+ $(RM_RF) Makefile
+
+distclean: realclean
