Skip to content
Browse files

[STD vs t] user-defined prefix, infix, and postfix ops now derive new…

… languages

(no support for equiv or assoc traits yet, nor for circumfix etc.)
start of support for $?PARSER, now parses 99.74% of t/
traits and sigs may now be intermixed
an anonumous subname may be represented with '&' in sub & is foo {...}
now parses 99.74% of t


git-svn-id: http://svn.pugscode.org/pugs@21819 c213334d-75ef-0310-aa23-eaa082d1ae64
  • Loading branch information...
1 parent 665e55b commit aa077e29ff8b05edfb48d4bc56e8d8ce99e41fb3 lwall committed
Showing with 108 additions and 22 deletions.
  1. +90 −6 Cursor.pmc
  2. +14 −14 STD.pm
  3. +3 −1 gimme5
  4. +1 −1 mangle.pl
View
96 Cursor.pmc
@@ -11,6 +11,8 @@ require 'mangle.pl';
our $CTX = '';
our $DEBUG = $ENV{STD5DEBUG} // 0;
$::DEBUG = $DEBUG;
+
+# various bits of info useful for error messages
$::HIGHWATER = 0;
$::HIGHMESS = '';
$::HIGHEXPECT = {};
@@ -917,16 +919,98 @@ sub cursor_rev { my $self = shift;
sub add_macro { my $lang = shift;
my $start = shift;
+ state $GEN = "500";
$lang->{_from} = $start->{_from};
my $name = $lang->text;
+ my $WHAT = ref $lang;
if ($name =~ s/:/:sym/) {
- print "macro $name\n";
- eval <<'END';
-#package $genpkg;
-#use Moose ':all' => { -prefix => 'moose_' };
-#moose_extends('$WHAT');
-#moose_with(" . join(',', map {"'$_'"} @newmix) . ");
+ my ($sym) = $name =~ /:sym(.*)/;
+ if ($sym =~ s/^«(.*)»$/$1/) {
+ my $ok = "'";
+ for my $try (qw( ' / ! : ; | + - = )) {
+ $ok = $try, last if index($sym,$try) < 0;
+ }
+ $sym = $ok . $sym . $ok;
+ }
+
+ my $rule = "token $name { <sym> }";
+
+ my $mangle = $name;
+ $mangle =~ s/^(\w*):(sym)?//;
+ my $category = $1;
+ my @list;
+ if ($mangle =~ s/^<(.*)>$/$1/ or
+ $mangle =~ s/^«(.*)»$/$1/) {
+ $mangle =~ s/\\(.)/$1/g;
+ @list = $mangle =~ /(\S+)/g;
+ }
+ elsif ($mangle =~ s/^\[(.*)\]$/$1/ or
+ $mangle =~ s/^\{(.*)\}$/$1/) {
+ @list = eval $mangle;
+ }
+ else {
+ @list = $mangle;
+ }
+ $mangle = ::mangle(@list);
+ $mangle = $category . '__S_' . sprintf("%03d",$GEN++) . $mangle;
+
+ # XXX assuming no equiv
+ my $coercion = 'Additive';
+ if ($name =~ /^prefix:/) {
+ if ($sym =~ /^\W/) {
+ $coercion = 'Symbolic_unary';
+ }
+ else {
+ $coercion = 'Named_unary';
+ }
+ }
+ elsif ($name =~ /^postfix:/) {
+ $coercion = 'Methodcall';
+ }
+
+ my $genpkg = $WHAT . '::_' . $mangle;
+ my $e = <<"END";
+package $genpkg;
+use Moose ':all' => { -prefix => 'moose_' };
+moose_extends('$WHAT');
+
+# $rule
+
+my \$retree = {
+ '$mangle' => bless({
+ 'kind' => 'token',
+ 'min' => 12345,
+ 're' => bless({
+ 'a' => 0,
+ 'i' => 0,
+ 'min' => 12345,
+ 'name' => 'sym',
+ 'rest' => '',
+ 'sym' => q$sym,
+ }, 'RE_method'),
+ }, 'RE'),
+};
+
+sub $mangle {
+ my \$self = shift;
+ local \$CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
+ if (\$self->{_peek}) {
+ return \$self->_AUTOLEXpeek('$mangle',\$retree)
+ }
+ my %args = \@_;
+ my \$sym = \$args{sym} // q$sym;
+
+ my \$C = \$self;
+ \$C->{'sym'} = \$sym;
+
+ \$self->_MATCHIFY( Cursor::lazymap sub { STD::$coercion->coerce(\$_[0]) },
+ \$C->_SYM(\$sym, 0)
+ );
+}
+1;
END
+ eval $e or die "Can't create $name: $@\n";
+ $::PARSER = $lang->cursor_fresh($genpkg);
}
$lang;
}
View
28 STD.pm
@@ -5,6 +5,7 @@ my $PKGDECL is context = "";
my $PKG is context = "";
my @PKGS;
my $GOAL is context = "(eof)";
+my $PARSER is context<rw>;
# random rule for debugging, please ignore
regex foo {
@@ -531,6 +532,7 @@ token regex_block {
# statement semantics
rule statementlist {
+ :my $PARSER is context<rw> = self;
[
| <?before <[\)\]\}]> >
| [<statement><.eat_terminator> ]*
@@ -562,6 +564,7 @@ token label {
token statement {
:my $endargs is context = -1;
<!before <[\)\]\}]> >
+ <!!{ bless $¢, ref $PARSER; }>
[
| <label> <statement> {*} #= label
| <statement_control> {*} #= control
@@ -806,7 +809,6 @@ token noun {
| <type_declarator>
| <circumfix>
| <dotty>
-# | <subcall>
| <value>
| <capterm>
| <sigterm>
@@ -932,8 +934,6 @@ token post {
{ $+prevop = $<O> }
}
-# Note: backtracks, or we'd never get to parse [LIST] on seeing [+ and such.
-# (Also backtracks if on \op when no \op infix exists.)
regex prefix_circumfix_meta_operator:reduce (--> List_prefix) {
$<s> = (
'['
@@ -1514,7 +1514,8 @@ token twigil:sym<=> { <sym> }
token deflongname {
<name>
- [ <colonpair>+ { $¢ = $¢.add_macro($<name>); } ]?
+ # XXX too soon
+ [ <colonpair>+ { $¢.add_macro($<name>); } ]?
}
token longname {
@@ -1540,7 +1541,8 @@ token morename {
token subshortname {
[
- | <category> <colonpair>+
+ | <category>
+ [ <colonpair>+ { $¢.add_macro($<category>); } ]?
| <desigilname>
]
}
@@ -2345,14 +2347,14 @@ rule multisig {
}
rule routine_def {
- <deflongname>? <multisig>?
- <trait>*
+ [ '&'<deflongname>? | <deflongname> ]? [ <multisig> | <trait> ]*
+ <!!{ bless $¢, ref $PARSER; }>
<block>
}
rule method_def {
[
- | '!'?<longname> <multisig>?
+ | '!'?<longname> [ <multisig> | <trait> ]*
| <sigil> '.'
[
| '(' :: <in: ')', 'signature'>
@@ -2360,22 +2362,19 @@ rule method_def {
| '{' :: <in: '}', 'signature'>
| <?before '<'> <postcircumfix>
]
+ <trait>*
]
- <trait>*
<block>
}
rule regex_def {
<longname>?
- [ ':'?'(' <signature> ')']?
- <trait>*
+ [ [ ':'?'(' <signature> ')'] | <trait> ]*
<regex_block>
}
-# XXX redundant with routine_def?
rule macro_def {
- <deflongname>? <multisig>?
- <trait>*
+ [ '&'<deflongname>? | <deflongname> ]? [ <multisig> | <trait> ]*
<block>
}
@@ -2383,6 +2382,7 @@ rule trait {
[
| <trait_verb>
| <trait_auxiliary>
+ | <colonpair>
]
}
View
4 gimme5
@@ -70,10 +70,12 @@ sub unangle {
sub un6 {
my $f = shift;
+ #my $trace = $f =~ /PARSER/;
my $t;
$f =~ s/\\x([0-9a-fA-F]{3,4})/\\x{$1}/g;
$f =~ s!\$([0-9]+)!\$\$C{$1}!g;
while ($f ne "") {
+ #print "$f\n" if $trace;
$f =~ s/^\)</.</ and $t .= ')', next;
$f =~ s/^\.\(/(/ and $t .= '->', next;
$f =~ s/^\[\*-1\]// and $t .= '[-1]';
@@ -183,7 +185,7 @@ sub un6 {
$f =~ s/^\belsif\s+(.*?) \{/($1) {/ and $t .= qq/elsif /, next;
$f =~ s/^\bwhile\s+(.*?) \{/($1) {/ and $t .= qq/while /, next;
$f =~ s/^\bfor\s+(.*?) \{/($1) {/ and $t .= qq/for /, next;
- $f =~ s/^\bmy\s+(?:[A-Z]\w+)?\s*([\$\@%]\w+)\s+is\s+context(?:<rw>)?\s*(?:is\s*rw)?\s*=\s*(.*);/$2;/s
+ $f =~ s/^\bmy\s+(?:[A-Z]\w+)?\s*([\$\@%]\w+)\s+is\s+context(?:<rw>)?\s*(?:is\s*rw)?\s*=(\s*.*);/$2;/s
and $t .= qq/local $1 = /, $OUR{$1}++, next;
$f =~ s/^\bdo given\s+(.*?\S)\s+\{/$1; if (0) {}/
and $t .= qq/do { my \$_ = /, next;
View
2 mangle.pl
@@ -36,7 +36,7 @@ sub mangle {
s/\./Dot/g;
s/\?/Question/g;
s/\//Slash/g;
- s/(\W)/sprintf("_%02x_",ord($1))/eg;
+ s/([^a-zA-Z_0-9])/sprintf("_%02x_",ord($1))/eg;
}
join '_', @list;
}

0 comments on commit aa077e2

Please sign in to comment.
Something went wrong with that request. Please try again.