Skip to content

Commit

Permalink
Merge branch 'master' of github.com:partcl/partcl-nqp
Browse files Browse the repository at this point in the history
  • Loading branch information
coke committed Nov 29, 2009
2 parents 951de03 + 2bff6f8 commit 0241721
Show file tree
Hide file tree
Showing 6 changed files with 161 additions and 0 deletions.
12 changes: 12 additions & 0 deletions build/Makefile.in
Expand Up @@ -43,6 +43,9 @@ PMTCL_A_PIR = src/gen/pmtcl-actions.pir
PMTCL_C_PIR = src/gen/pmtcl-compiler.pir
PMTCL_B_PIR = src/gen/pmtcl-commands.pir
TCLLEXPAD_PIR = src/gen/tcllexpad.pir
ARE_G_PIR = src/gen/are-grammar.pir
ARE_A_PIR = src/gen/are-actions.pir
ARE_C_PIR = src/gen/are-compiler.pir

PMTCL_SOURCES = \
src/PmTcl.pir \
Expand All @@ -51,6 +54,9 @@ PMTCL_SOURCES = \
$(PMTCL_C_PIR) \
$(PMTCL_B_PIR) \
$(TCLLEXPAD_PIR) \
$(ARE_G_PIR) \
$(ARE_A_PIR) \
$(ARE_C_PIR) \
src/tcllist.pir

CLEANUPS = \
Expand All @@ -76,6 +82,12 @@ $(PMTCL_B_PIR): src/PmTcl/Commands.pm
$(PARROT_NQP) --target=pir -o $(PMTCL_B_PIR) src/PmTcl/Commands.pm
$(TCLLEXPAD_PIR): src/TclLexPad.pm
$(PARROT_NQP) --target=pir -o $(TCLLEXPAD_PIR) src/TclLexPad.pm
$(ARE_G_PIR): src/ARE/Grammar.pm
$(PARROT_NQP) --target=pir -o $(ARE_G_PIR) src/ARE/Grammar.pm
$(ARE_A_PIR): src/ARE/Actions.pm
$(PARROT_NQP) --target=pir -o $(ARE_A_PIR) src/ARE/Actions.pm
$(ARE_C_PIR): src/ARE/Compiler.pm
$(PARROT_NQP) --target=pir -o $(ARE_C_PIR) src/ARE/Compiler.pm

## testing

Expand Down
92 changes: 92 additions & 0 deletions src/ARE/Actions.pm
@@ -0,0 +1,92 @@
class ARE::Actions is HLL::Actions;

method TOP($/) {
my $past := buildsub( $<nibbler>.ast );
$past.node($/);
make $past;
}

method nibbler($/) {
my $past;
if +$<termish> > 1 {
$past := PAST::Regex.new( :pasttype('alt'), :node($/) );
for $<termish> { $past.push($_.ast); }
}
else {
$past := $<termish>[0].ast;
}
make $past;
}

method termish($/) {
my $past := PAST::Regex.new( :pasttype('concat'), :node($/) );
my $lastlit := 0;
for $<noun> {
my $ast := $_.ast;
if $ast {
if $lastlit && $ast.pasttype eq 'literal'
&& !PAST::Node.ACCEPTS($ast[0]) {
$lastlit[0] := $lastlit[0] ~ $ast[0];
}
else {
$past.push($ast);
$lastlit := $ast.pasttype eq 'literal'
&& !PAST::Node.ACCEPTS($ast[0])
?? $ast !! 0;
}
}
}
make $past;
}

method quantified_atom($/) {
my $past := $<atom>.ast;
if $<quantifier> {
my $qast := $<quantifier>[0].ast;
$qast.unshift($past);
$past := $qast;
}
make $past;
}

method atom($/) {
my $past := $<metachar>
?? $<metachar>.ast
!! PAST::Regex.new( ~$/, :pasttype<literal>, :node($/) );
make $past;
}

method quantifier:sym<*>($/) {
make PAST::Regex.new( :pasttype<quant>, :node($/) );
}
method quantifier:sym<+>($/) {
make PAST::Regex.new( :pasttype<quant>, :min(1), :node($/) );
}
method quantifier:sym<?>($/) {
make PAST::Regex.new( :pasttype<quant>, :min(0), :max(1), :node($/) );
}

method metachar:sym<.>($/) {
make PAST::Regex.new( :pasttype<charclass>, :subtype<.>, :node($/) );
}

method metachar:sym<back>($/) { make $<backslash>.ast; }

method backslash:sym<w>($/) {
make PAST::Regex.new( :pasttype<charclass>, :subtype(~$<sym>), :node($/));
}

sub buildsub($rpast, $block = PAST::Block.new() ) {
$rpast := PAST::Regex.new(
PAST::Regex.new( :pasttype('scan') ),
$rpast,
PAST::Regex.new( :pasttype('pass') ),
:pasttype('concat'),
);
unless $block.symbol('') { $block.symbol('', :scope<lexical>); }
unless $block.symbol('$/') { $block.symbol('$/', :scope<lexical>); }
$block.push($rpast);
$block.blocktype('method');
$block;
}

9 changes: 9 additions & 0 deletions src/ARE/Compiler.pm
@@ -0,0 +1,9 @@
class ARE::Compiler is HLL::Compiler {
INIT {
ARE::Compiler.parsegrammar(ARE::Grammar);
ARE::Compiler.parseactions(ARE::Actions);
ARE::Compiler.language('ARE');
}
}


38 changes: 38 additions & 0 deletions src/ARE/Grammar.pm
@@ -0,0 +1,38 @@
grammar ARE::Grammar is HLL::Grammar;

token TOP {
<nibbler>
[ $ || <.panic: 'Confused'> ]
}

token nibbler {
<termish> [ '|' <termish> ]*
}

token termish {
<noun=.quantified_atom>+
}

token quantified_atom {
<atom> <quantifier>?
}

token atom {
[
| \w [ \w+! <?before \w> ]?
| <metachar>
]
}

proto token quantifier { <...> }
token quantifier:sym<*> { <sym> }
token quantifier:sym<+> { <sym> }
token quantifier:sym<?> { <sym> }

proto token metachar { <...> }
token metachar:sym<.> { <sym> }
token metachar:sym<back> { \\ <backslash> }

proto token backslash { <...> }
token backslash:sym<w> { $<sym>=[<[dswDSW]>] }

3 changes: 3 additions & 0 deletions src/PmTcl.pir
Expand Up @@ -19,6 +19,9 @@
.include 'src/gen/pmtcl-compiler.pir'
.include 'src/gen/pmtcl-commands.pir'
.include 'src/gen/tcllexpad.pir'
.include 'src/gen/are-grammar.pir'
.include 'src/gen/are-actions.pir'
.include 'src/gen/are-compiler.pir'

.namespace []
.sub 'main' :main
Expand Down
7 changes: 7 additions & 0 deletions src/PmTcl/Commands.pm
Expand Up @@ -271,6 +271,13 @@ our sub puts(*@args) {
'';
}

our sub regexp($exp, $string) {
## my &dumper := Q:PIR { %r = get_root_global ['parrot'], '_dumper' };
## &dumper(ARE::Compiler.compile($exp, :target<parse>));
my $regex := ARE::Compiler.compile($exp);
?Regex::Cursor.parse($string, :rule($regex), :c(0));
}

## "return" is special -- we want to be able to throw a
## CONTROL_RETURN exception without the sub itself catching
## it. So we create a bare block for the return (bare blocks
Expand Down

0 comments on commit 0241721

Please sign in to comment.