# New Ticket Created by Bruce Keeler
# Please include the string: [perl #73244]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=73244 >
The attached patch is also available in the 'grammar' branch of my
github fork (bkeeler/rakudo). I'll keep that branch up to date to make
sure it applies cleanly.
Notes:
* regex_declarator now calls regex_def, which is prototyped over
'rule', 'token' and 'regex'. This matches STD.pm
* The <subrule($a, $b)> form of passing arguments to subrules now
uses the Rakudo arglist rule, and so can take arbitrary
expressions. The <subrule: 1, 2> form cannot at preset use the
rakudo arglist, as EXPR tries to eat the closing angle. The colon
form is limited to a list of simple literals.
* builtins/Grammar.pir has been rewritten as core/Grammar.pm
* Signatures may be applied to regexes. Parameters may be
referenced in closures within the regex.
* Named regexes may not be declared outside of a grammar or class.
* The <Foo::Bar> form of calling subrules in another grammar does
not work. This will require changes to the regex engine.
Unfortunately, this holds up a number of tests that would
otherwise pass.
* S05-grammar/action-stubs.t and S05-grammar/methods.t now pass, as
well as two new test files S05-grammar/protos.t and
S05-grammar/signatures.
* I attempted to factor out common code between regex_def and
method_def, but ran into problems and backed out. I'll take
another crack at this sometime soon.
From 1d3b996dee09880c20dbe40dab96158ba1dfe220 Mon Sep 17 00:00:00 2001
From: Bruce Keeler <br...@drangle.com>
Date: Sun, 28 Feb 2010 20:36:20 -0800
Subject: [PATCH] Implementation of grammars
---
build/Makefile.in | 2 +-
src/Perl6/Actions.pm | 186 +++++++++++++++++++++++++++++++++++---------
src/Perl6/Grammar.pm | 44 ++++++++---
src/builtins/Grammar.pir | 94 ----------------------
src/core/Grammar.pm | 16 ++++
src/metamodel/ClassHOW.pir | 3 +-
t/spectest.data | 6 +-
7 files changed, 206 insertions(+), 145 deletions(-)
delete mode 100644 src/builtins/Grammar.pir
create mode 100644 src/core/Grammar.pm
diff --git a/build/Makefile.in b/build/Makefile.in
index edfb97c..5a7a98b 100644
--- a/build/Makefile.in
+++ b/build/Makefile.in
@@ -98,7 +98,6 @@ BUILTINS_PIR = \
src/builtins/EMPTY.pir \
src/builtins/ParrotIter.pir \
src/builtins/List.pir \
- src/builtins/Grammar.pir \
src/builtins/Parcel.pir \
src/builtins/Bool.pir \
src/builtins/Int.pir \
@@ -190,6 +189,7 @@ CORE_SOURCES = \
src/core/Block.pm \
src/core/Regex.pm \
src/core/Junction.pm \
+ src/core/Grammar.pm \
src/core/system.pm \
src/cheats/match-bool.pm \
src/cheats/setup-io.pm \
diff --git a/src/Perl6/Actions.pm b/src/Perl6/Actions.pm
index 5c65c0a..3ee710a 100644
--- a/src/Perl6/Actions.pm
+++ b/src/Perl6/Actions.pm
@@ -1035,33 +1035,135 @@ method method_def($/) {
make $past;
}
-method regex_declarator($/, $key?) {
- if $key ne 'open' {
- # Create regex code object.
- # XXX TODO: token/regex/rule differences, signatures, traits.
- my $past := Regex::P6Regex::Actions::buildsub($<p6regex>.ast);
- $past := create_code_object($past, 'Regex', 0, '');
-
- # Install in lexpad or namespace. XXX Need & on start of name?
- my $name := ~$<deflongname>;
- if $*SCOPE ne 'our' {
- @BLOCK[0][0].push(PAST::Var.new( :name($name), :isdecl(1),
- :viviself($past),
:scope('lexical') ) );
- @BLOCK[0].symbol($name, :scope('lexical') );
- }
+our %REGEX_MODIFIERS;
+method regex_declarator:sym<regex>($/, $key?) {
+ if ($key) {
+ my %h;
+ %REGEX_MODIFIERS := %h;
+ } else {
+ make $<regex_def>.ast;
+ }
+}
- # Otherwise, package scoped; add something to loadinit to install them.
- else {
- @PACKAGE[0].block.loadinit.push(PAST::Op.new(
- :pasttype('bind'),
- PAST::Var.new( :name($name), :scope('package') ),
- $past
- ));
- @BLOCK[0].symbol($name, :scope('package') );
+method regex_declarator:sym<token>($/, $key?) {
+ if ($key) {
+ my %h;
+ %h<r> := 1;
+ %REGEX_MODIFIERS := %h;
+ } else {
+ make $<regex_def>.ast;
+ }
+}
+
+method regex_declarator:sym<rule>($/, $key?) {
+ if ($key) {
+ my %h;
+ %h<r> := 1; %h<s> :=1;
+ %REGEX_MODIFIERS := %h;
+ } else {
+ make $<regex_def>.ast;
+ }
+}
+
+method regex_def($/, $key?) {
+ my $name := ~$<deflongname>[0];
+ my @MODIFIERS := Q:PIR {
+ %r = get_hll_global ['Regex';'P6Regex';'Actions'], '@MODIFIERS'
+ };
+ my $past;
+ if $key eq 'open' {
+ @MODIFIERS.unshift(%REGEX_MODIFIERS);
+ # The following is so that <sym> can work
+ Q:PIR {
+ $P0 = find_lex '$name'
+ set_hll_global ['Regex';'P6Regex';'Actions'], '$REGEXNAME', $P0
+ };
+ return 0;
+ } elsif $*MULTINESS eq 'proto' {
+ @MODIFIERS.shift;
+ @BLOCK.shift;
+ unless ($name) {
+ $/.CURSOR.panic('proto ' ~ ~$<sym> ~ 's cannot be anonymous');
+ }
+# $/.CURSOR.panic('proto ' ~ ~$<sym> ~ 's not implemented yet');
+ our @PACKAGE;
+ unless +...@package {
+ $/.CURSOR.panic("Can not declare named " ~ ~$<sym> ~ " outside of
a package");
+ }
+ my %table;
+ %table := @PACKAGE[0].methods();
+ unless %table{$name} { my %tmp; %table{$name} := %tmp; }
+ if %table{$name} {
+ $/.CURSOR.panic('Cannot declare proto ' ~ ~$<sym> ~ ' ' ~ $name ~
+ ' when another with this name was already declared');
}
+ %table{$name}<code_ref> :=
+ create_code_object(
+ PAST::Block.new( :name($name),
+ PAST::Op.new(
+ PAST::Var.new( :name('self'), :scope('register') ),
+ $name,
+ :name('!protoregex'),
+ :pasttype('callmethod')
+ ),
+ :lexical(0),
+ :blocktype('method'),
+ :pirflags(':anon'),
+ :node($/)
+ ),
+ 'Regex', 0, '');
+ %table{'!PREFIX__' ~ $name}<code_ref> :=
+ create_code_object(
+ PAST::Block.new( :name('!PREFIX__' ~ $name),
+ PAST::Op.new(
+ PAST::Var.new( :name('self'), :scope('register') ),
+ $name,
+ :name('!PREFIX__!protoregex'),
+ :pasttype('callmethod')
+ ),
+ :blocktype('method'),
+ :pirflags(':anon'),
+ :lexical(0),
+ :node($/)
+ ),
+ 'Regex', 0, '');
+ } else {
+ @MODIFIERS.shift;
+ $past := Regex::P6Regex::Actions::buildsub($<p6regex>.ast,
@BLOCK.shift);
+ $past.unshift(PAST::Op.new(
+ :pasttype('inline'),
+ :inline(" .local pmc self\n self = find_lex 'self'")
+ ));
+ my $sig := $<signature> ?? $<signature>[0].ast !!
Perl6::Compiler::Signature.new();
+ $sig.add_invocant();
+ $sig.set_default_parameter_type('Any');
+ $past[0].unshift(PAST::Var.new( :name('self'), :scope('lexical'),
:isdecl(1), :viviself(sigiltype('$')) ));
+ $past.symbol('self', :scope('lexical'));
+ my $sig_setup_block := add_signature($past, $sig, 1);
+ $past.name($name);
+ $past.blocktype("declaration");
+ # If the methods are not :anon they'll conflict at class composition
time.
+ $past.pirflags(':anon');
+ $past := create_code_object($past, 'Regex', 0, $sig_setup_block);
+ if ($name) {
+ our @PACKAGE;
+ unless +...@package {
+ $/.CURSOR.panic("Can not declare named " ~ ~$<sym> ~ " outside
of a package");
+ }
+ my %table;
+ %table := @PACKAGE[0].methods();
+ unless %table{$name} { my %tmp; %table{$name} := %tmp; }
- make PAST::Var.new( :name($name) );
+ if %table{$name} {
+ $/.CURSOR.panic('Cannot declare ' ~ ~$<sym> ~ ' ' ~ $name ~
+ ' when another with this name was already declared');
+ }
+ %table{$name}<code_ref> := $past;
+ make PAST::Stmts.new();
+ return 0;
+ }
}
+ make $past;
}
method type_declarator:sym<enum>($/) {
@@ -1949,23 +2051,31 @@ class Perl6::RegexActions is Regex::P6Regex::Actions {
method codeblock($/) {
my $block := $<block>.ast;
$block.blocktype('immediate');
- my $past :=
- PAST::Regex.new(
- PAST::Stmts.new(
+ make bindmatch($block);
+ }
+
+ method p6arglist($/) {
+ my $arglist := $<arglist>.ast;
+# make bindmatch($arglist);
+ make $arglist;
+ }
+
+ sub bindmatch($past) {
+ PAST::Regex.new(
+ PAST::Stmts.new(
+ PAST::Op.new(
+ PAST::Var.new( :name('$/') ),
PAST::Op.new(
- PAST::Var.new( :name('$/') ),
- PAST::Op.new(
- PAST::Var.new( :name('$¢') ),
- :name('MATCH'),
- :pasttype('callmethod')
- ),
- :pasttype('bind')
+ PAST::Var.new( :name('$¢') ),
+ :name('MATCH'),
+ :pasttype('callmethod')
),
- $block
+ :pasttype('bind')
),
- :pasttype('pastnode')
- );
- make $past;
+ $past
+ ),
+ :pasttype('pastnode')
+ );
}
}
@@ -2321,3 +2431,5 @@ sub prevent_null_return($block) {
$block[1].push(PAST::Op.new( :name('&Nil') ));
}
}
+
+# vim: ft=perl6
diff --git a/src/Perl6/Grammar.pm b/src/Perl6/Grammar.pm
index 41e1672..d325012 100644
--- a/src/Perl6/Grammar.pm
+++ b/src/Perl6/Grammar.pm
@@ -759,18 +759,28 @@ rule post_constraint {
]
}
-rule regex_declarator {
+proto token regex_declarator { <...> }
+token regex_declarator:sym<rule> {
+ <sym> {*} #= open
+ <regex_def>
+}
+token regex_declarator:sym<token> {
+ <sym> {*} #= open
+ <regex_def>
+}
+token regex_declarator:sym<regex> {
+ <sym> {*} #= open
+ <regex_def>
+}
+
+rule regex_def {
[
- | $<proto>=[proto] [regex|token|rule]
- <deflongname>
- '{' '<...>' '}'<?ENDSTMT>
- | $<sym>=[regex|token|rule]
- <deflongname>
+ <deflongname>?
<.newpad>
- [ '(' <signature> ')' ]?
+ [ [ ':'?'(' <signature> ')'] | <trait> ]*
{*} #= open
- '{'<p6regex=.LANG('Regex','nibbler')>'}'<?ENDSTMT>
- ]
+ '{'[ '<...>' |<p6regex=.LANG('Regex','nibbler')>]'}'<?ENDSTMT>
+ ] || <.panic: "Malformed regex">
}
proto token type_declarator { <...> }
@@ -1235,6 +1245,21 @@ grammar Perl6::Regex is Regex::P6Regex::Grammar {
token codeblock {
<block=.LANG('MAIN','block')>
}
+
+ token assertion:sym<name> {
+ $<longname>=[\w+]
+ [
+ | <?before '>'>
+ | '=' <assertion>
+ | ':' <arglist>
+ | '(' <arglist=p6arglist> ')'
+ | <.normspace> <nibbler>
+ ]?
+ }
+
+ token p6arglist {
+ <arglist=.LANG('MAIN','arglist')>
+ }
}
@@ -1285,4 +1310,3 @@ sub parse_name($name) {
.return (list)
}
}
-
diff --git a/src/builtins/Grammar.pir b/src/builtins/Grammar.pir
deleted file mode 100644
index ab4fa01..0000000
--- a/src/builtins/Grammar.pir
+++ /dev/null
@@ -1,94 +0,0 @@
-## $Id$
-
-=head1 TITLE
-
-Grammar - Perl 6 Grammar class
-
-=head1 DESCRIPTION
-
-This file implements the Grammar class.
-
-=cut
-
-.sub '' :anon :init :load
- .local pmc p6meta
- p6meta = get_hll_global ['Mu'], '$!P6META'
- p6meta.'new_class'('Grammar', 'parent'=>'Any')
-
- # XXX pmichaud++ needs to fix this bunch. kplzthnxbai jnthn :-)
- #p6meta.'new_class'('Grammar', 'parent'=>'Match')
-
- #$P0 = get_root_namespace ['parrot';'PGE';'Grammar']
- #$P0 = get_class $P0
- #.const 'Sub' $P1 = 'Grammar.parse'
- #$P0.'add_method'('parse', $P1)
-.end
-
-=head2 Methods
-
-=over
-
-=item parse(string)
-
-Parse a string according to the TOP rule in the grammar.
-
-=cut
-
-=item parse(topic)
-
-Invokes the TOP rule in the grammar on the given topic.
-
-=cut
-
-.namespace ['Grammar']
-.sub 'parse' :method :subid('Grammar.parse')
- .param pmc topic
- .param pmc options :slurpy :named
- .local pmc TOP
-
- # If there's a TOP rule, invoke it.
- push_eh no_TOP
- TOP = find_method self, "TOP"
- pop_eh
- .local pmc match, p6meta
- p6meta = get_hll_global ['Mu'], '$!P6META'
- $P0 = p6meta.'get_parrotclass'(self)
- $P0 = inspect $P0, 'namespace'
- $P0 = $P0.'get_name'()
- $S0 = shift $P0
- $S0 = join '::', $P0
- match = TOP(topic, options :named :flat, 'grammar' => $S0)
- $P0 = getinterp
- $P1 = $P0['lexpad';1]
- $P1['$/'] = match
- .return(match)
-
- no_TOP:
- pop_eh
- 'die'("The grammar has no TOP rule to invoke.")
-.end
-
-
-=item parsefile(filename)
-
-Reads in the file in filename and then invokes the TOP rule in the
-grammar on it.
-
-=cut
-
-.sub 'parsefile' :method
- .param string filename
- .param pmc options :slurpy :named
- $S0 = 'slurp'(filename)
- .tailcall self.'parse'($S0, options :named :flat)
-.end
-
-=back
-
-=cut
-
-# Local Variables:
-# mode: pir
-# fill-column: 100
-# End:
-# vim: expandtab shiftwidth=4 ft=pir:
diff --git a/src/core/Grammar.pm b/src/core/Grammar.pm
new file mode 100644
index 0000000..f045243
--- /dev/null
+++ b/src/core/Grammar.pm
@@ -0,0 +1,16 @@
+class Grammar is Regex::Cursor {
+ method parsefile($file, *%options) {
+ my $fh = open($file, :r)
+ || die "$file: $!";
+ my $str = $fh.slurp;
+ self.parse($str, %options);
+ }
+}
+
+our sub make($ast) {
+ Q:PIR {
+ $P0 = find_dynamic_lex '$/'
+ $P1 = find_lex '$ast'
+ $P0.'!make'($P1)
+ }
+}
diff --git a/src/metamodel/ClassHOW.pir b/src/metamodel/ClassHOW.pir
index a9d338a..2f51316 100644
--- a/src/metamodel/ClassHOW.pir
+++ b/src/metamodel/ClassHOW.pir
@@ -108,7 +108,8 @@ Creates a new instance of the meta-class and returns it in
an associated
# Stash in metaclass instance.
have_parrotclass:
- how = new ['ClassHOW']
+ $P0 = typeof self
+ how = new [$P0]
setattribute how, 'parrotclass', parrotclass
$P0 = root_new ['parrot';'ResizablePMCArray']
setattribute how, '$!composees', $P0
diff --git a/t/spectest.data b/t/spectest.data
index 6d16ff3..8ecca34 100644
--- a/t/spectest.data
+++ b/t/spectest.data
@@ -220,11 +220,13 @@ S04-statements/while.t
# S05-capture/dot.t
# S05-capture/named.t
# S05-capture/subrule.t
-# S05-grammar/action-stubs.t
+S05-grammar/action-stubs.t
# S05-grammar/inheritance.t
-# S05-grammar/methods.t
+S05-grammar/methods.t
# S05-grammar/namespace.t
# S05-grammar/parse_and_parsefile.t
+S05-grammar/protos.t
+S05-grammar/signatures.t
# S05-grammar/ws.t
# S05-mass/named-chars.t # icu
# S05-mass/properties-block.t # icu
--
1.7.0
