| 1 | #!/usr/local/bin/perl |
|---|
| 2 | |
|---|
| 3 | use 5.010; |
|---|
| 4 | use strict; |
|---|
| 5 | use warnings; |
|---|
| 6 | use Text::Balanced qw(extract_bracketed); |
|---|
| 7 | binmode(STDIN, ":utf8"); |
|---|
| 8 | binmode(STDOUT, ":utf8"); |
|---|
| 9 | binmode(STDERR, ":utf8"); |
|---|
| 10 | use Encode; |
|---|
| 11 | use utf8; |
|---|
| 12 | |
|---|
| 13 | my $failover = 0; |
|---|
| 14 | if (@ARGV) { |
|---|
| 15 | if ($ARGV[0] eq '-fo') { |
|---|
| 16 | $failover = 1; shift; |
|---|
| 17 | } |
|---|
| 18 | } |
|---|
| 19 | |
|---|
| 20 | use YAML::Syck; |
|---|
| 21 | |
|---|
| 22 | our $SEQ = 0; |
|---|
| 23 | |
|---|
| 24 | our %OUR = ( '$CTX' => 1 ); |
|---|
| 25 | our $RETREE = {}; |
|---|
| 26 | our @RETREE = {}; |
|---|
| 27 | |
|---|
| 28 | our $STOP = ""; |
|---|
| 29 | our $REV = ""; |
|---|
| 30 | our $NAME = ""; |
|---|
| 31 | our @BINDINGS; # list of names to bind to |
|---|
| 32 | our %BINDINGS; # count of how many times name used in this rule |
|---|
| 33 | our $BINDNUM = 1; # is this a singular or plural binding? |
|---|
| 34 | our $KIND = ""; |
|---|
| 35 | our $PARSEBIND = 0; |
|---|
| 36 | our $PAREN = 0; |
|---|
| 37 | our %adverbs = ('i' => 0, 'a' => 0,); |
|---|
| 38 | our %fixedprefix; |
|---|
| 39 | our $PURE; |
|---|
| 40 | our $MAYBACKTRACK; |
|---|
| 41 | our @STUFFED; |
|---|
| 42 | our @DECL; |
|---|
| 43 | our $SYM; |
|---|
| 44 | our $ENDSYM; |
|---|
| 45 | our $NEEDMATCH; |
|---|
| 46 | our %NEEDSEMI; |
|---|
| 47 | our $NEEDORIGARGS; |
|---|
| 48 | our $PKG = "main"; |
|---|
| 49 | our $TOP = "STD"; |
|---|
| 50 | our @PKG = (); |
|---|
| 51 | our $ALTNAME; |
|---|
| 52 | our $ALTNAMES; |
|---|
| 53 | our $PROTO; |
|---|
| 54 | our $ENDMATTER; |
|---|
| 55 | |
|---|
| 56 | my %pkg_really; |
|---|
| 57 | my %proto; |
|---|
| 58 | my %protosig; |
|---|
| 59 | |
|---|
| 60 | my $TRACE = 0; |
|---|
| 61 | my $METHOD = "method"; |
|---|
| 62 | |
|---|
| 63 | my @impure = qw/ ws fail commit before after panic /; |
|---|
| 64 | my %impure; |
|---|
| 65 | |
|---|
| 66 | require "mangle.pl"; |
|---|
| 67 | |
|---|
| 68 | sub unangle { |
|---|
| 69 | my $s = shift; |
|---|
| 70 | $s =~ s/<(\w*)>/{$1}/g; |
|---|
| 71 | $s =~ s/<([^>]*)>/{'$1'}/g; |
|---|
| 72 | $s =~ s/«([^»]*)»/{'$1'}/g; |
|---|
| 73 | $s =~ s/ /','/g; |
|---|
| 74 | $s; |
|---|
| 75 | } |
|---|
| 76 | |
|---|
| 77 | sub un6 { |
|---|
| 78 | my $f = shift; |
|---|
| 79 | #my $trace = $f =~ /PARSER/; |
|---|
| 80 | my $t; |
|---|
| 81 | $f =~ s/\\x([0-9a-fA-F]{3,4})/\\x{$1}/g; |
|---|
| 82 | $f =~ s!\$([0-9]+)!\$\$C{$1}!g; |
|---|
| 83 | $f =~ s/(\S+)\s*:(exists|delete)/$2 $1/g if $f =~ /:(exists|delete)/; |
|---|
| 84 | while ($f ne "") { |
|---|
| 85 | #print "$f\n" if $trace; |
|---|
| 86 | $f =~ s/^\)</.</ and $t .= ')', next; |
|---|
| 87 | $f =~ s/^\.\(/(/ and $t .= '->', next; |
|---|
| 88 | $f =~ s/^\[\*-1\]// and $t .= '[-1]'; |
|---|
| 89 | $f =~ s!^('.*?')!! and $t .= $1, next; |
|---|
| 90 | $f =~ s!^(".*?")!! and $t .= $1, next; |
|---|
| 91 | $f =~ s!^ self\.WHAT!! and $t .= ' (ref($self)||$self)', next; |
|---|
| 92 | $f =~ s!^ self\.pos\b!! and $t .= ' $self->{_pos}', next; |
|---|
| 93 | $f =~ s!^\$¢\.pos\b!! and $t .= '$C->{_pos}', next; |
|---|
| 94 | $f =~ s!^//!! and $t .= "//", next; # default operator |
|---|
| 95 | $f =~ s!^m:p5(\W)(.+?)\1/!! and $t .= "m$1$2$1", next; |
|---|
| 96 | $f =~ s!^s:p5(\W)(.+?)\1(.*?)\1/!! and $t .= "s$1$2$1$3$1", next; |
|---|
| 97 | $f =~ s!^q/(.*?)/!! and $t .= "q/$1/", next; |
|---|
| 98 | $f =~ s!^s/(.*?)/!! and $t .= "s/$1/", next; |
|---|
| 99 | $f =~ s!^(?:rx)?/(.+?)/!! and $t .= "qr/$1/", next; |
|---|
| 100 | $f =~ s/^\$¢\.\$parser// and $t .= qq/\$C->\$parser/, next; |
|---|
| 101 | $f =~ s/^\$¢// and $t .= qq/\$C/, next; |
|---|
| 102 | $f =~ s/^\$\/\.// and $t .= qq/\$M->/, $NEEDMATCH++, next; |
|---|
| 103 | $f =~ s/^\$\*(\w+)// and $t .= qq/\$::$1/, next; |
|---|
| 104 | $f =~ s/^\$\/</.</ and $t .= qq/\$M/, $NEEDMATCH++, next; |
|---|
| 105 | $f =~ s/^ ::(\w+(?:::\w+)*)\[(.*?)\]/$2)/ and $t .= qq/ '@{[ $pkg_really{$1} || "${PKG}::$1" ]}'->__instantiate__(/, next; |
|---|
| 106 | $f =~ s/^ ::($TOP(?:::\w+)*)// and $t .= qq/ '$1'/, next; |
|---|
| 107 | $f =~ s/^ ::(\w+(?:::\w+)*)// and $t .= qq/ '@{[ $pkg_really{$1} || "${PKG}::$1" ]}'/, next; |
|---|
| 108 | $f =~ s/^([^:]):(\w+)\((.*?)\)/ ($3)/ and $t .= qq/$1'$2' =>/, next; |
|---|
| 109 | $f =~ s/^([^:]):([\$\@%])(\w+)// and $t .= qq/$1'$3' => $2$3/, next; |
|---|
| 110 | $f =~ s/^([^:]):(\w+)<(.*?)>// and $t .= qq/$1'$2' => '$3'/, next; |
|---|
| 111 | $f =~ s/^([^:]):(\w+)«(.*?)»// and $t .= qq/$1'$2' => '$3'/, next; |
|---|
| 112 | $f =~ s/^([^:]):(\w+)// and $t .= qq/$1'$2' => 1/, next; |
|---|
| 113 | $f =~ s/^([^:]):!(\w+)// and $t .= qq/$1'$2' => 0/, next; |
|---|
| 114 | $f =~ s/^\%::\((.*?)\)// and $t .= ("do { no strict 'refs'; \\%{$1}}"), next; |
|---|
| 115 | $f =~ s/^\%\+?(\w+)((<[^>]*>)+)// and $t .= ('$' . $1 . unangle($2)), next; |
|---|
| 116 | $f =~ s/^\%\+?(\w+)\{@// and $t .= qq/\@$1\{@/, next; # durn slices... |
|---|
| 117 | $f =~ s/^\%\+?(\w+)\{// and $t .= qq/\$$1\{/, next; |
|---|
| 118 | $f =~ s/^\@\+(\w+)\[// and $t .= qq/\$$1\[/, next; |
|---|
| 119 | $f =~ s/^\$(\w+)((<[^>]*>)+)// and $t .= ('$' . $1 . '->' . unangle($2)), next; |
|---|
| 120 | $f =~ s/^[\$\@%]((<[^>]*>)+)// and $t .= ('$M->' . unangle($1)), $NEEDMATCH++, next; |
|---|
| 121 | $f =~ s/^ \.((<[^>]*>)+)// and $t .= (' $_->' . unangle($1)), next; |
|---|
| 122 | $f =~ s/^ < ([^«»])/$1/ and $t .= qq/ < /, next; |
|---|
| 123 | $f =~ s/^(\s)<([^>) ,]*)>// and $t .= qq/$1q($2)/, next; |
|---|
| 124 | $f =~ s/^(\s)<([^>),]*)>,// and $t .= qq/$1qw($2),/, next; |
|---|
| 125 | $f =~ s/^(\s)<([^>),]*)>// and $t .= qq/$1\[qw($2)\]/, next; |
|---|
| 126 | $f =~ s/^(\s)<([^> ]*)>// and $t .= qq/$1q[$2]/, next; |
|---|
| 127 | $f =~ s/^(\s)<([^>]*)>// and $t .= qq/$1\[qw[$2]\]/, next; |
|---|
| 128 | $f =~ s/^«([^») ]*)»// and $t .= qq/q($1)/, next; |
|---|
| 129 | $f =~ s/^«([^»)]*)»// and $t .= qq/\[qw($1)\]/, next; |
|---|
| 130 | $f =~ s/^«([^» ]*)»// and $t .= qq/q[$1]/, next; |
|---|
| 131 | $f =~ s/^«([^»]*)»// and $t .= qq/\[qw[$1]\]/, next; |
|---|
| 132 | $f =~ s/^ «\s*([^»]+)»// and $t .= do {my $x=$1; $x =~ s/ +$//; $x =~ s! !','!g; "['$x']"}, next; |
|---|
| 133 | $f =~ s/^ <\s*([^>]+)>// and $t .= do {my $x=$1; $x =~ s/ +$//; $x =~ s! !','!g; "['$x']"}, next; |
|---|
| 134 | $f =~ s/^\.<\s*([^>]+)>// and $t .= do {my $x=$1; $x =~ s/ +$//; $x =~ s! !','!g; "->{'$x'}"}, next; |
|---|
| 135 | $f =~ s/^<\s*([^>]+)>// and $t .= do {my $x=$1; $x =~ s/ +$//; $x =~ s! !','!g; "{'$x'}"}, next; |
|---|
| 136 | $f =~ s/^(\w+)((<[^>]*>)+)// and $t .= ($1 . '->' . unangle($2)), next; |
|---|
| 137 | $f =~ s/^(\w+)((«[^»]*»)+)// and $t .= ($1 . '->' . unangle($2)), next; |
|---|
| 138 | $f =~ s/^\.pos\b// and $t .= qq/->{_pos}/, next; |
|---|
| 139 | $f =~ s/^self\.orig\b// and $t .= qq/\$::ORIG/, next; |
|---|
| 140 | $f =~ s!^\.pos\b!! and $t .= '->{_pos}', next; |
|---|
| 141 | $f =~ s/^(\$\w+)\.pos// and $t .= $1 . '->{_pos}', next; |
|---|
| 142 | $f =~ s/^(\$\w+)\.// and $t .= qq/$1->/, next; |
|---|
| 143 | $f =~ s/^(\$\w+)\(/(/ and $t .= qq/$1->/, next; |
|---|
| 144 | $f =~ s/^\(\$s:\)// and $t .= qq/(\$s)/, next; |
|---|
| 145 | $f =~ s/^\$[!.](\w+)// and $t .= qq/\$self->{$1}/, next; |
|---|
| 146 | $f =~ s/^\@[!.](\w+)\././ and $t .= qq/\$self->{$1}/, next; |
|---|
| 147 | $f =~ s/^\%[!.](\w+)\././ and $t .= qq/\$self->{$1}/, next; |
|---|
| 148 | $f =~ s/^\@[!.](\w+)([\[{<])/.$2/ and $t .= qq/\$self->{$1}/, next; |
|---|
| 149 | $f =~ s/^\%[!.](\w+)([\[{<])/.$2/ and $t .= qq/\$self->{$1}/, next; |
|---|
| 150 | $f =~ s/^\@[!.](\w+)// and $t .= qq/\@{\$self->{$1}}/, next; |
|---|
| 151 | $f =~ s/^\%[!.](\w+)// and $t .= qq/\%{\$self->{$1}}/, next; |
|---|
| 152 | $f =~ s/^\&(${TOP}::)// and $t .= qq/*$1/, next; |
|---|
| 153 | $f =~ s/^\@(\w+)([\[{])/$2/ and $t .= qq/\$$1/, next; |
|---|
| 154 | $f =~ s/^\%(\w+)([\[{])/$2/ and $t .= qq/\$$1/, next; |
|---|
| 155 | $f =~ s/^\|%/%/ and next; |
|---|
| 156 | $f =~ s/^\.HOW// and $t .= qq/->meta/, next; |
|---|
| 157 | $f =~ s/^HOW// and $t .= qq/meta/, next; |
|---|
| 158 | $f =~ s/^\.([a-z]\w+)// and $t .= qq/->$1/, next; |
|---|
| 159 | $f =~ s/^!===?// and $t .= qq/!=/, next; |
|---|
| 160 | $f =~ s/^===// and $t .= qq/==/, next; |
|---|
| 161 | $f =~ s/^!eqv// and $t .= qq/ne/, next; |
|---|
| 162 | $f =~ s/^eqv// and $t .= qq/eq/, next; |
|---|
| 163 | $f =~ s/^item %// and $t .= qq/\\%/, next; |
|---|
| 164 | $f =~ s/^ \+@// and $t .= qq/ 0+@/, next; |
|---|
| 165 | $f =~ s/^ is rw// and $t .= qq//, next; |
|---|
| 166 | $f =~ s/^my\s+(?:[A-Z]\w+)?\s*([\$\@%]\w+)\s+is\s+context(?:<rw>)?\s*(?:is\s+rw)?\s*;// |
|---|
| 167 | and $t .= qq/local $1;/, $OUR{$1}++, next; |
|---|
| 168 | $f =~ s/^\borelse\b// and $t .= qq/or/, next; |
|---|
| 169 | $f =~ s/^\bfail\b// and $t .= qq/die/, next; |
|---|
| 170 | $f =~ s/^\blet\b // and $t .= qq//, next; |
|---|
| 171 | $f =~ s/^\bTrue\b// and $t .= qq/1/, next; |
|---|
| 172 | $f =~ s/^\bFalse\b// and $t .= qq/0/, next; |
|---|
| 173 | $f =~ s/^\$?self\.pos\b// and $t .= qq/\$self->{_pos}/, next; |
|---|
| 174 | $f =~ s/^\$?self\.// and $t .= qq/\$self->/, next; |
|---|
| 175 | $f =~ s/^\$?self\b// and $t .= qq/\$self/, next; |
|---|
| 176 | $f =~ s/^\.panic// and $t .= qq/->panic/, next; |
|---|
| 177 | $f =~ s/^(\s)\+&(\s)/$2/ and $t .= qq/$1&/, next; |
|---|
| 178 | $f =~ s/^(\s)!~~(\s)/$2/ and $t .= qq/$1!~/, next; |
|---|
| 179 | $f =~ s/^(\s)~~(\s)/$2/ and $t .= qq/$1=~/, next; |
|---|
| 180 | $f =~ s/^(\s)~=(\s)/$2/ and $t .= qq/$1.=/, next; |
|---|
| 181 | $f =~ s/^(\s)~(\s)/$2/ and $t .= qq/$1./, next; |
|---|
| 182 | $f =~ s/^(\s):=(\s)/$2/ and $t .= qq/$1=/, next; |
|---|
| 183 | $f =~ s/^(\s)\?\?(\s)/$2/ and $t .= qq/$1?/, next; |
|---|
| 184 | $f =~ s/^(\s)!!(\s)/$2/ and $t .= qq/$1:/, next; |
|---|
| 185 | $f =~ s/^\btry \{// and $t .= qq/eval {/, next; |
|---|
| 186 | $f =~ s/^\bloop \{// and $t .= qq/for (;;) {/, next; |
|---|
| 187 | $f =~ s/^\bwhen\s+\*\s+\{// and $t .= qq/else {/, next; |
|---|
| 188 | $f =~ s/^\bdefault\s+\{// and $t .= qq/else {/, next; |
|---|
| 189 | $f =~ s/^\btemp\b// and $t .= qq/local/, next; |
|---|
| 190 | $f =~ s/^\bchars\(// and $t .= qq/length(/, next; |
|---|
| 191 | $f =~ s/^\$\?PACKAGE// and $t .= qq/__PACKAGE__/, next; |
|---|
| 192 | |
|---|
| 193 | # the following must do partial rescan of final expression |
|---|
| 194 | |
|---|
| 195 | $f =~ s/^\@\((.*?)\)/{$1}/ and $t .= qq/\@/, next; |
|---|
| 196 | $f =~ s/^\bif\s+(.*?) \{/($1) {/ and $t .= qq/if /, next; |
|---|
| 197 | $f =~ s/^\belsif\s+(.*?) \{/($1) {/ and $t .= qq/elsif /, next; |
|---|
| 198 | $f =~ s/^\bwhile\s+(.*?) \{/($1) {/ and $t .= qq/while /, next; |
|---|
| 199 | $f =~ s/^\bfor\s+(.*?) \{/($1) {/ and $t .= qq/for /, next; |
|---|
| 200 | $f =~ s/^\bmy\s+(?:[A-Z]\w+)?\s*([\$\@%]\w+)\s+is\s+context(?:<rw>)?\s*(?:is\s*rw)?\s*=(\s*.*);/$2;/s |
|---|
| 201 | and $t .= qq/local $1 = /, $OUR{$1}++, next; |
|---|
| 202 | $f =~ s/^\bdo given\s+(.*?\S)\s+\{/$1; if (0) {}/ |
|---|
| 203 | and $t .= qq/do { my \$_ = /, next; |
|---|
| 204 | $f =~ s/^\bgiven\s+(.*?\S)\s+\{/$1; if (0) {}/ |
|---|
| 205 | and $t .= qq/do { my \$_ = /, next; |
|---|
| 206 | $f =~ s/^\bwhen\s+(.*?\S)\s+\{/$1) {/ |
|---|
| 207 | and $t .= 'elsif ($_ eq ', next; |
|---|
| 208 | |
|---|
| 209 | $f =~ s/^(.)//s and $t .= $1; |
|---|
| 210 | } |
|---|
| 211 | $t; |
|---|
| 212 | } |
|---|
| 213 | |
|---|
| 214 | { |
|---|
| 215 | open(IN, $ARGV[0]) or die "Can't open $ARGV[0]: $!\n"; |
|---|
| 216 | { |
|---|
| 217 | local $/; |
|---|
| 218 | binmode(IN, ':utf8'); |
|---|
| 219 | $_ = <IN>; |
|---|
| 220 | } |
|---|
| 221 | close IN; |
|---|
| 222 | push @impure, m/^method (\w+)/mg; |
|---|
| 223 | @impure{@impure} = (1) x @impure; |
|---|
| 224 | #warn "@impure\n"; |
|---|
| 225 | } |
|---|
| 226 | my $all = $_; |
|---|
| 227 | |
|---|
| 228 | sub indent { |
|---|
| 229 | my $x = shift || ''; |
|---|
| 230 | my $i = shift || 1; |
|---|
| 231 | my $s = ' ' x $i; |
|---|
| 232 | $x =~ s/^/$s/mg; |
|---|
| 233 | $x; |
|---|
| 234 | } |
|---|
| 235 | |
|---|
| 236 | sub panic { |
|---|
| 237 | my $line = 0; |
|---|
| 238 | while (length($all) > length($_)) { |
|---|
| 239 | if ($all =~ s/^#line (\d+)\n//) { |
|---|
| 240 | $line = $1; |
|---|
| 241 | } |
|---|
| 242 | else { |
|---|
| 243 | $all =~ s/^.*\n//; |
|---|
| 244 | $line++; |
|---|
| 245 | } |
|---|
| 246 | } |
|---|
| 247 | die @_, |
|---|
| 248 | " at line ", $line - 1, |
|---|
| 249 | " near '", /^(.{0,30}) /s, |
|---|
| 250 | "'\n"; |
|---|
| 251 | } |
|---|
| 252 | |
|---|
| 253 | my $out = ""; |
|---|
| 254 | |
|---|
| 255 | sub MAIN { |
|---|
| 256 | |
|---|
| 257 | if (s/^\s*grammar (\w+)(?::\w+<.*?>)*(?:\s*is\s+(\w+))?;\n//) { |
|---|
| 258 | $TOP = $PKG = $1; |
|---|
| 259 | my $extends = $2 // 'Cursor'; |
|---|
| 260 | $out .= "package $PKG;\n"; |
|---|
| 261 | $out .= <<"END"; |
|---|
| 262 | use strict; |
|---|
| 263 | use warnings; |
|---|
| 264 | no warnings 'qw', 'recursion'; |
|---|
| 265 | use $extends; # for base class as well as DEBUG constants |
|---|
| 266 | use Moose ':all' => { -prefix => "moose_" }; |
|---|
| 267 | moose_extends('$extends'); |
|---|
| 268 | my \$retree; |
|---|
| 269 | use feature 'state', 'say'; |
|---|
| 270 | use utf8; |
|---|
| 271 | |
|---|
| 272 | \$DB::deep = \$DB::deep = 1000; # suppress used-once warning |
|---|
| 273 | |
|---|
| 274 | sub BUILD { |
|---|
| 275 | my \$self = shift; |
|---|
| 276 | END |
|---|
| 277 | |
|---|
| 278 | $out .= <<'END' if $TOP eq 'STD'; |
|---|
| 279 | $self->_AUTOLEXpeek('termish',$retree); |
|---|
| 280 | END |
|---|
| 281 | |
|---|
| 282 | $out .= <<'END'; |
|---|
| 283 | } |
|---|
| 284 | |
|---|
| 285 | use YAML::Syck; |
|---|
| 286 | |
|---|
| 287 | END |
|---|
| 288 | } |
|---|
| 289 | |
|---|
| 290 | while ($_ ne "") { |
|---|
| 291 | |
|---|
| 292 | if ( s/^(#line.*\n)// ) { next } |
|---|
| 293 | if ( s/^([ \t]*\n)// ) { $out .= $1; next; }; |
|---|
| 294 | |
|---|
| 295 | if (s/^ (=begin \s+ (\w+) .*? \n =end \s+ \2 .*? \n) //sx) { |
|---|
| 296 | my $c = $1; |
|---|
| 297 | $c =~ s/^/# /mg; |
|---|
| 298 | $out .= $c; |
|---|
| 299 | next; |
|---|
| 300 | } |
|---|
| 301 | |
|---|
| 302 | if ( s/^(#.*\n)// ) { $out .= $1; next } |
|---|
| 303 | |
|---|
| 304 | my $remaining = length($_); |
|---|
| 305 | |
|---|
| 306 | if (s/^(\s*)(proto \s+ (regex|rule|token|method) \s+ |
|---|
| 307 | (\w+) \s* |
|---|
| 308 | (?:\(([^)]*)\))?.*?\{[<.!>\s]*}.*?\n)//x) |
|---|
| 309 | { |
|---|
| 310 | $out .= '#' . $2; |
|---|
| 311 | my $name = $4; |
|---|
| 312 | my $pkgname = $PKG . '::' . $name; |
|---|
| 313 | $proto{$name}++; |
|---|
| 314 | $protosig{$name} = $5; |
|---|
| 315 | $out .= <<"END"; |
|---|
| 316 | sub ${name}__PEEK { \$_[0]->_AUTOLEXpeek('$name:*',\$retree); } |
|---|
| 317 | sub $name { |
|---|
| 318 | my \$self = shift; |
|---|
| 319 | my \$subs; |
|---|
| 320 | |
|---|
| 321 | local \$CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call; |
|---|
| 322 | |
|---|
| 323 | my \$C = \$self; |
|---|
| 324 | my \$S = \$C->{_pos}; |
|---|
| 325 | |
|---|
| 326 | my \@result = eval { |
|---|
| 327 | my \$trystate; |
|---|
| 328 | my (\$tag, \$try); |
|---|
| 329 | my \@try; |
|---|
| 330 | my \$relex; |
|---|
| 331 | if (my \$fate = \$C->{_fate}) { |
|---|
| 332 | if (\$fate->[1] eq '$name') { |
|---|
| 333 | \$C->deb("Fate passed to $name: ", ::fatestr(\$fate)) if \$DEBUG & DEBUG::fates; |
|---|
| 334 | (\$C->{_fate}, \$tag, \$try) = \@\$fate; |
|---|
| 335 | \@try = (\$try); |
|---|
| 336 | } |
|---|
| 337 | } |
|---|
| 338 | |
|---|
| 339 | my \@gather = (); |
|---|
| 340 | for (;;) { |
|---|
| 341 | if (not \@try) { |
|---|
| 342 | \$relex //= \$C->cursor_fate('$PKG', '$name:*', \$retree); |
|---|
| 343 | \@try = \$relex->(\$C, \$trystate); |
|---|
| 344 | } |
|---|
| 345 | last unless \@try; |
|---|
| 346 | \$try = shift(\@try) // next; |
|---|
| 347 | |
|---|
| 348 | if (ref \$try eq 'ARRAY') { |
|---|
| 349 | (\$C->{_fate}, \$tag, \$try) = \@\$try; # next candidate fate |
|---|
| 350 | } |
|---|
| 351 | |
|---|
| 352 | \$C->deb("$name trying \$tag \$try") if \$::DEBUG & DEBUG::try_processing; |
|---|
| 353 | push \@gather, \$C->\$try(\@_); |
|---|
| 354 | last if \@gather; |
|---|
| 355 | } |
|---|
| 356 | \$self->_MATCHIFY(\$S, "$name", \@gather); |
|---|
| 357 | }; |
|---|
| 358 | if (\$@) { |
|---|
| 359 | return () if \$@ =~ /^ABORTRULE/; |
|---|
| 360 | die \$@; |
|---|
| 361 | } |
|---|
| 362 | \@result; |
|---|
| 363 | } |
|---|
| 364 | |
|---|
| 365 | END |
|---|
| 366 | next; |
|---|
| 367 | } |
|---|
| 368 | |
|---|
| 369 | if (s/^([ \t]*)(?:multi\s+)? |
|---|
| 370 | (regex|rule|token) \s+ |
|---|
| 371 | (\w+) ( :\w+ ( <.*?> |
|---|
| 372 | | «.*?» |
|---|
| 373 | | \{.*?\} |
|---|
| 374 | | \[.*?\] |
|---|
| 375 | )? |
|---|
| 376 | ) \s* |
|---|
| 377 | (?:\(([^)]*)\))?//x) |
|---|
| 378 | { |
|---|
| 379 | my $indent = $1; |
|---|
| 380 | my $kind = $2; |
|---|
| 381 | my $name = $3; |
|---|
| 382 | my $adv = $4; |
|---|
| 383 | my $sig = $6; |
|---|
| 384 | |
|---|
| 385 | my $newdflt = $adv; |
|---|
| 386 | $newdflt =~ s/:(\w+)$/'$1'/ or |
|---|
| 387 | $newdflt =~ s/:sym(<.*?>)/$1/ or |
|---|
| 388 | $newdflt =~ s/:sym(«.*?»)/$1/ or |
|---|
| 389 | $newdflt =~ s/:sym(\(.*?\))/$1/ or |
|---|
| 390 | $newdflt =~ s/:sym(\[.*?\])/$1/; |
|---|
| 391 | |
|---|
| 392 | my $newparm = ":\$sym is context<rw> = $newdflt"; |
|---|
| 393 | |
|---|
| 394 | my $newsig = $protosig{$name} || ""; |
|---|
| 395 | if ($sig and $sig =~ s/( *--> *\w* *$)//) { $newsig .= ' ' . $1 } |
|---|
| 396 | if ($newsig =~ /^\s*-->/) { |
|---|
| 397 | $newsig =~ s/-->/$newparm -->/; |
|---|
| 398 | } |
|---|
| 399 | elsif ($newsig =~ /-->/) { |
|---|
| 400 | $newsig =~ s/-->/, $newparm -->/; |
|---|
| 401 | } |
|---|
| 402 | elsif ($newsig) { |
|---|
| 403 | $newsig .= ', ' . $newparm; |
|---|
| 404 | } |
|---|
| 405 | else { |
|---|
| 406 | $newsig = $newparm; |
|---|
| 407 | } |
|---|
| 408 | my $mangle = $adv; |
|---|
| 409 | $mangle =~ s/^:(sym)?//; |
|---|
| 410 | my @list; |
|---|
| 411 | if ($mangle =~ s/^<(.*)>$/$1/ or |
|---|
| 412 | $mangle =~ s/^«(.*)»$/$1/) { |
|---|
| 413 | $mangle =~ s/\\(.)/$1/g; |
|---|
| 414 | @list = $mangle =~ /(\S+)/g; |
|---|
| 415 | } |
|---|
| 416 | elsif ($mangle =~ s/^\[(.*)\]$/$1/ or |
|---|
| 417 | $mangle =~ s/^\{(.*)\}$/$1/) { |
|---|
| 418 | @list = eval $mangle; |
|---|
| 419 | } |
|---|
| 420 | else { |
|---|
| 421 | @list = $mangle; |
|---|
| 422 | } |
|---|
| 423 | $mangle = ::mangle(@list); |
|---|
| 424 | $mangle = $name . '__S_' . sprintf("%03d",$SEQ++) . $mangle; |
|---|
| 425 | substr($_,0,0,"$indent$kind $mangle ($newsig) ") |
|---|
| 426 | } |
|---|
| 427 | |
|---|
| 428 | if (s/^(\s*)} # end (class|grammar|role).*\n//) { |
|---|
| 429 | my $ws = $1; |
|---|
| 430 | dumpretree(); |
|---|
| 431 | $out .= "$ws$ENDMATTER ## end $2\n"; |
|---|
| 432 | $RETREE = pop(@RETREE); |
|---|
| 433 | $PKG = pop(@PKG) if @PKG; |
|---|
| 434 | $ENDMATTER = '}'; |
|---|
| 435 | } |
|---|
| 436 | |
|---|
| 437 | if ( s/^([ \t]*)(proto)?\s*(method|rule|token|regex)(\s+)(\w+)(.*?)\s+{//s ) { |
|---|
| 438 | my $indent = $1; |
|---|
| 439 | my $proto = $2; |
|---|
| 440 | local $KIND = $3; |
|---|
| 441 | my $ws = $4; |
|---|
| 442 | local $NAME = $5; |
|---|
| 443 | my $argstuff = $6; |
|---|
| 444 | |
|---|
| 445 | my $comment = "$1$3$4$5$6\n"; |
|---|
| 446 | $comment =~ s/^/## /mg; |
|---|
| 447 | $out .= $comment; |
|---|
| 448 | |
|---|
| 449 | local $PAREN = 0; |
|---|
| 450 | local $SYM; |
|---|
| 451 | local $ENDSYM; |
|---|
| 452 | local $NEEDORIGARGS = 0; |
|---|
| 453 | my $args = ""; |
|---|
| 454 | my $coercion = ""; |
|---|
| 455 | if ($argstuff =~ s/\((.*)\)//s) { |
|---|
| 456 | $args = $1; |
|---|
| 457 | $args =~ s/^\s+//; |
|---|
| 458 | $args =~ s/\s+$//; |
|---|
| 459 | } |
|---|
| 460 | warn "ARGSTUFF in $NAME: ", $argstuff if $argstuff =~ /\S/; |
|---|
| 461 | my $p = ""; |
|---|
| 462 | |
|---|
| 463 | local $MAYBACKTRACK = 1; |
|---|
| 464 | $adverbs{r} = 0; |
|---|
| 465 | $adverbs{s} = 0; |
|---|
| 466 | $adverbs{dba} = $NAME; |
|---|
| 467 | if ($KIND eq 'token' or $KIND eq 'rule') { |
|---|
| 468 | $MAYBACKTRACK = 0; |
|---|
| 469 | $adverbs{r} = 1; |
|---|
| 470 | if ($KIND eq 'rule') { |
|---|
| 471 | $adverbs{s} = 1; |
|---|
| 472 | } |
|---|
| 473 | } |
|---|
| 474 | |
|---|
| 475 | my $pkg; |
|---|
| 476 | if ($args =~ s/ *--> *(\w*) *$//) { |
|---|
| 477 | $pkg = $pkg_really{$1} || "${PKG}::$1"; |
|---|
| 478 | } |
|---|
| 479 | $args .= ', '; |
|---|
| 480 | my $sym = ""; |
|---|
| 481 | |
|---|
| 482 | $args =~ s/is rw//g; |
|---|
| 483 | while ($args =~ s/^([A-Z]\w+)?\s*([\$\@%&]\w+)\s*(is\s+context(?:<rw>)?)?\s*([^=?,]*?),\s*//) { |
|---|
| 484 | my $type = $1; |
|---|
| 485 | my $var = $2; |
|---|
| 486 | my $decl = $3 ? ($OUR{$var}++, "local") : "my"; |
|---|
| 487 | warn "EXTRA: ", $4 if $4; |
|---|
| 488 | $sym .= " $decl $var = shift;\n"; |
|---|
| 489 | $args =~ s/^,\s*//; |
|---|
| 490 | } |
|---|
| 491 | |
|---|
| 492 | while ($args =~ s/^([A-Z]\w+)?\s*([\$\@%&]\w+)\s*(is\s+context(?:<rw>)?)?\s*=(.*?),\s*//) { |
|---|
| 493 | my $type = $1; |
|---|
| 494 | my $var = $2; |
|---|
| 495 | my $decl = $3 ? ($OUR{$var}++, "local") : "my"; |
|---|
| 496 | my $dflt = un6($4); |
|---|
| 497 | $sym .= " $decl $var = shift() //$dflt;\n"; # XXX close enough |
|---|
| 498 | $args =~ s/^,\s*//; |
|---|
| 499 | } |
|---|
| 500 | |
|---|
| 501 | my $didargs = 0; |
|---|
| 502 | while ($args =~ s/^([A-Z]\w+)?\s*:([\$\@%&](\w+))\s*(is\s+context(?:<rw>)?)?\s*(=((<[^>]*>|«[^»]*»|.)*?))?,\s*//) { |
|---|
| 503 | my $type = $1; |
|---|
| 504 | my $var = $2; |
|---|
| 505 | my $name = $3; |
|---|
| 506 | my $decl = $4 ? ($OUR{$var}++, "local") : "my"; |
|---|
| 507 | my $eq = $5; |
|---|
| 508 | my $dflt = $6; |
|---|
| 509 | $sym .= " my %args = \@_;\n" unless $didargs++; # simulate named args from variadics |
|---|
| 510 | if ($name eq 'sym') { |
|---|
| 511 | warn "NO DFLT: ", $args unless $dflt; |
|---|
| 512 | $SYM = $dflt; |
|---|
| 513 | $SYM =~ s/^\s+//; |
|---|
| 514 | $SYM =~ s/^'(.*)'$/$1/ or |
|---|
| 515 | $SYM =~ s/^"(.*)"$/$1/ or |
|---|
| 516 | $SYM =~ s/^<(.*)>$/$1/ or |
|---|
| 517 | $SYM =~ s/^«(.*)»$/$1/ or |
|---|
| 518 | $SYM =~ s/^\{'(.*)','(.*)'\}$/$1 $2/ or |
|---|
| 519 | $SYM =~ s/^\{'(.*)'\}$/$1/; |
|---|
| 520 | $SYM =~ s/^\s+//; |
|---|
| 521 | $SYM =~ s/\s+$//; |
|---|
| 522 | $SYM =~ s/\\(.)/$1/g; |
|---|
| 523 | } |
|---|
| 524 | if ($name eq 'endsym') { |
|---|
| 525 | warn "NO DFLT: ", $args unless $dflt; |
|---|
| 526 | $ENDSYM = $dflt; |
|---|
| 527 | $ENDSYM =~ s/^\s+//; |
|---|
| 528 | $ENDSYM =~ s/\s+$//; |
|---|
| 529 | $ENDSYM =~ s/^'(.*)'$/$1/ or |
|---|
| 530 | $ENDSYM =~ s/^"(.*)"$/$1/; |
|---|
| 531 | } |
|---|
| 532 | if ($eq) { |
|---|
| 533 | $dflt = un6($dflt); |
|---|
| 534 | $sym .= " $decl $var = \$args{$name} //$dflt;\n"; |
|---|
| 535 | } |
|---|
| 536 | else { |
|---|
| 537 | $sym .= " $decl $var = \$args{$name};\n"; |
|---|
| 538 | } |
|---|
| 539 | $args =~ s/^,\s*//; |
|---|
| 540 | } |
|---|
| 541 | |
|---|
| 542 | if ($args =~ s/^([A-Z]\w+)?\s*\*([\$\@%&]\w+)\s*(is\s+context(?:<rw>)?)?\s*([^=?,]*?),\s*//) { |
|---|
| 543 | my $type = $1; |
|---|
| 544 | my $var = $2; |
|---|
| 545 | my $decl = $3 ? ($OUR{$var}++, "local") : "my"; |
|---|
| 546 | warn "EXTRA: ", $4 if $4; |
|---|
| 547 | $sym .= " $decl $var = \@_;\n"; |
|---|
| 548 | $args =~ s/^,\s*//; |
|---|
| 549 | } |
|---|
| 550 | warn "EXTRA: ", $args if $args =~ /[^, ]/; |
|---|
| 551 | |
|---|
| 552 | if ($KIND eq 'method') { |
|---|
| 553 | $out .= <<"END"; |
|---|
| 554 | ${indent}sub $NAME { |
|---|
| 555 | ${indent} my \$self = shift; |
|---|
| 556 | $sym |
|---|
| 557 | END |
|---|
| 558 | next; |
|---|
| 559 | } |
|---|
| 560 | |
|---|
| 561 | local @BINDINGS; |
|---|
| 562 | local %BINDINGS; |
|---|
| 563 | local @DECL; |
|---|
| 564 | |
|---|
| 565 | local $ALTNAME = $NAME; |
|---|
| 566 | local $ALTNAMES = "00"; |
|---|
| 567 | my $re = regex('\\}'); |
|---|
| 568 | $re->{pkg} = $pkg; |
|---|
| 569 | |
|---|
| 570 | my $old = substr($all, length($all) - $remaining, $remaining - length($_)+1); |
|---|
| 571 | $old =~ s/^/## /mg; |
|---|
| 572 | $out .= "$old\n\n"; |
|---|
| 573 | |
|---|
| 574 | local $PURE = 1; |
|---|
| 575 | local $PROTO = $proto; |
|---|
| 576 | my $meat = ::indent($re->walk(), 2); |
|---|
| 577 | |
|---|
| 578 | $re->{kind} = $KIND; |
|---|
| 579 | $RETREE->{$NAME} = $re; |
|---|
| 580 | $re->remember_alts(); |
|---|
| 581 | |
|---|
| 582 | my $body = <<"END"; |
|---|
| 583 | sub$ws${NAME}__PEEK { <<PEEK>> } |
|---|
| 584 | sub$ws$NAME { |
|---|
| 585 | my \$self = shift; |
|---|
| 586 | END |
|---|
| 587 | if ($NEEDORIGARGS) { |
|---|
| 588 | $body .= " my \@origargs = \@_;\n"; |
|---|
| 589 | } |
|---|
| 590 | $body .= <<'END'; |
|---|
| 591 | local $CTX = $self->callm() if $::DEBUG & DEBUG::trace_call; |
|---|
| 592 | <<DECL>> |
|---|
| 593 | |
|---|
| 594 | my $C = $self; |
|---|
| 595 | my $S = $C->{_pos}; |
|---|
| 596 | END |
|---|
| 597 | |
|---|
| 598 | for my $binding ( keys %BINDINGS ) { |
|---|
| 599 | next unless $BINDINGS{$binding} > 1; |
|---|
| 600 | $body .= <<"END"; |
|---|
| 601 | \$C->{'$binding'} = []; |
|---|
| 602 | END |
|---|
| 603 | } |
|---|
| 604 | if ($SYM and $meat !~ /->_SYM\(\$sym\)/) { |
|---|
| 605 | $body .= <<"END"; |
|---|
| 606 | \$C->{'sym'} = \$sym; |
|---|
| 607 | END |
|---|
| 608 | } |
|---|
| 609 | |
|---|
| 610 | if ($proto) { |
|---|
| 611 | $body .= <<'END'; |
|---|
| 612 | |
|---|
| 613 | <<MEAT>> |
|---|
| 614 | END |
|---|
| 615 | } |
|---|
| 616 | else { |
|---|
| 617 | if ($pkg) { |
|---|
| 618 | if ($MAYBACKTRACK) { |
|---|
| 619 | $coercion = " Cursor::lazymap sub { $pkg->coerce(\$_[0]) }, "; |
|---|
| 620 | } |
|---|
| 621 | else { |
|---|
| 622 | $coercion = " map { $pkg->coerce(\$_) } "; |
|---|
| 623 | } |
|---|
| 624 | } |
|---|
| 625 | my $ratchet = $MAYBACKTRACK ? '' : 'r'; |
|---|
| 626 | $body .= <<"END"; |
|---|
| 627 | |
|---|
| 628 | \$self->_MATCHIFY$ratchet(\$S, "$NAME", $coercion |
|---|
| 629 | <<MEAT>> |
|---|
| 630 | ); |
|---|
| 631 | END |
|---|
| 632 | } |
|---|
| 633 | |
|---|
| 634 | my $PROTONAME = $NAME; |
|---|
| 635 | $PROTONAME =~ s/__.*// or $PROTONAME = "panic"; |
|---|
| 636 | if ($impure{$NAME}) { |
|---|
| 637 | $body =~ s/<<PEEK>>/''/; |
|---|
| 638 | } |
|---|
| 639 | else { |
|---|
| 640 | $body =~ s/<<PEEK>>/\$_[0]->_AUTOLEXpeek('<<NAME>>',\$retree)/; |
|---|
| 641 | } |
|---|
| 642 | $body =~ s/<<PKG>>/$PKG/g; |
|---|
| 643 | $body =~ s/<<NAME>>/$NAME/g; |
|---|
| 644 | $body =~ s/<<PROPS>>//g; |
|---|
| 645 | $body =~ s/<<PROTONAME>>/$PROTONAME/g; |
|---|
| 646 | $body =~ s/<<DECL>>/$sym@DECL/; |
|---|
| 647 | $body =~ s/<<MEAT>>/$meat/; |
|---|
| 648 | $body =~ s/\$\+(\w+)/\$::$1/g; |
|---|
| 649 | $out .= $body; |
|---|
| 650 | next; |
|---|
| 651 | } |
|---|
| 652 | |
|---|
| 653 | if (s/^\s*multi method tweak\s*\((.*?)\)\s+{//) { |
|---|
| 654 | my $sig = $1; |
|---|
| 655 | if ($sig =~ m/^:(\w+)\(:(\$(\w+))\)$/) { |
|---|
| 656 | $out .= " elsif (\$k eq '$1' or \$k eq '$3') {\n my $2 = \$v; "; |
|---|
| 657 | } |
|---|
| 658 | elsif ($sig =~ m/^:(\w+)\((\$\w+)\)$/) { |
|---|
| 659 | $out .= " elsif (\$k eq '$1') {\n my $2 = \$v; "; |
|---|
| 660 | } |
|---|
| 661 | elsif ($sig =~ m/^:(\$(\w+))$/) { |
|---|
| 662 | $out .= " elsif (\$k eq '$2') {\n my $1 = \$v; "; |
|---|
| 663 | } |
|---|
| 664 | elsif ($sig =~ m/^\*%x$/) { |
|---|
| 665 | $out .= " elsif (1) {\n my %x = (\$k, \$v); "; |
|---|
| 666 | } |
|---|
| 667 | else { |
|---|
| 668 | warn "Can't translate tweak: $sig"; |
|---|
| 669 | } |
|---|
| 670 | next; |
|---|
| 671 | } |
|---|
| 672 | |
|---|
| 673 | if (s/^#begin p5\n(.*?\n)#end p5\n//s) { |
|---|
| 674 | $out .= $1; |
|---|
| 675 | next; |
|---|
| 676 | } |
|---|
| 677 | |
|---|
| 678 | # from here on we assume all nibbles are line-sized or less. |
|---|
| 679 | if (s/^(.*\n)//) { |
|---|
| 680 | my $line = $1; |
|---|
| 681 | if ($line =~ /^(\s*).*?given/) { |
|---|
| 682 | my $len = length($1); |
|---|
| 683 | $NEEDSEMI{$len} = 1; |
|---|
| 684 | } |
|---|
| 685 | elsif ($line =~ /^(\s*)}\n/) { |
|---|
| 686 | my $len = length($1); |
|---|
| 687 | if (delete $NEEDSEMI{$len}) { |
|---|
| 688 | $line =~ s/}/};/; |
|---|
| 689 | } |
|---|
| 690 | } |
|---|
| 691 | if ($line =~ m/# begin tweaks/) { |
|---|
| 692 | $out .= <<'END'; |
|---|
| 693 | sub multitweak { # begin tweaks |
|---|
| 694 | my $self = shift; |
|---|
| 695 | my ($k, $v) = @_; |
|---|
| 696 | |
|---|
| 697 | if (0) {} |
|---|
| 698 | END |
|---|
| 699 | next; |
|---|
| 700 | } |
|---|
| 701 | elsif ($line =~ m/# end tweaks/) { |
|---|
| 702 | $out .= " else { die 'NOMATCH' }\n} # end tweaks\n"; |
|---|
| 703 | next; |
|---|
| 704 | } |
|---|
| 705 | if ($line =~ m/^#/) { |
|---|
| 706 | $out .= $line; |
|---|
| 707 | next; |
|---|
| 708 | } |
|---|
| 709 | if ($line =~ m/^(\s*)has\s+(?:[A-Z]\w+\s+)?[\$\@%][.!](\w+).*/) { |
|---|
| 710 | $out .= "$1moose_has '$2' => (is => 'rw');"; |
|---|
| 711 | next; |
|---|
| 712 | } |
|---|
| 713 | |
|---|
| 714 | $line = un6($line); |
|---|
| 715 | |
|---|
| 716 | $line =~ s/COMPILING::<(\W+)(\w+)>/$1COMPILING::$2/g; |
|---|
| 717 | $line =~ s/&reduce = ->/\$reduce = sub/; |
|---|
| 718 | $line =~ s/ -> (.+?) {/sub { my ($1) = \@_;/; |
|---|
| 719 | $line =~ s/ -> {/sub {/; |
|---|
| 720 | $line =~ s/\breduce\(\)/\$reduce->()/; |
|---|
| 721 | $line =~ s/([\$\@%])\+(\w+)/${1}::$2/g; # assume localized |
|---|
| 722 | if ($line =~ s/^constant %/our %/) { |
|---|
| 723 | $line =~ tr/{}/()/; |
|---|
| 724 | $line = ::un6($line); |
|---|
| 725 | } |
|---|
| 726 | $line =~ s/^constant /my /; |
|---|
| 727 | $line =~ s/\bmy ([A-Z]\w+) /my /; |
|---|
| 728 | |
|---|
| 729 | $line =~ s/(\s*)class (\w+)\s*(.*?)\s+\{/${1}{ package ${PKG}::$2;\n$1 use Moose ':all' => { -prefix => "moose_" };\n$1 my \$retree;/ |
|---|
| 730 | and do { |
|---|
| 731 | my $ws = $1; |
|---|
| 732 | my $name = $2; |
|---|
| 733 | my $is = $3; |
|---|
| 734 | my @is; |
|---|
| 735 | my @does; |
|---|
| 736 | my @list = split ' ', $is; |
|---|
| 737 | my $which; |
|---|
| 738 | while (@list) { |
|---|
| 739 | my $next = shift @list; |
|---|
| 740 | if ($next eq 'is') { |
|---|
| 741 | $which = \@is; |
|---|
| 742 | } |
|---|
| 743 | elsif ($next eq 'does') { |
|---|
| 744 | $which = \@does; |
|---|
| 745 | } |
|---|
| 746 | else { |
|---|
| 747 | push @$which, $pkg_really{$next} || "${PKG}::$next"; |
|---|
| 748 | } |
|---|
| 749 | } |
|---|
| 750 | push(@PKG, $PKG); |
|---|
| 751 | push(@RETREE, $RETREE); |
|---|
| 752 | $RETREE = {}; |
|---|
| 753 | $pkg_really{$name} = $PKG = "${PKG}::$name"; |
|---|
| 754 | $line .= "$ws moose_extends(qw(@is)); " if @is; |
|---|
| 755 | $line .= "$ws moose_with(qw(@does));" if @does; |
|---|
| 756 | $pkg_really{$1} = $PKG = "${PKG}::$1"; |
|---|
| 757 | }; |
|---|
| 758 | |
|---|
| 759 | $line =~ s/^(\s*)grammar (\w+)\s+(.*?)\{/${1}{ package ${PKG}::$2;\n$1 use Moose ':all' => { -prefix => "moose_" };\n$1 my \$retree;/ |
|---|
| 760 | and do { |
|---|
| 761 | my $ws = $1; |
|---|
| 762 | my $name = $2; |
|---|
| 763 | my $is = $3; |
|---|
| 764 | |
|---|
| 765 | my @is; |
|---|
| 766 | my @does; |
|---|
| 767 | my @list = split ' ', $is; |
|---|
| 768 | my $which; |
|---|
| 769 | while (@list) { |
|---|
| 770 | my $next = shift @list; |
|---|
| 771 | if ($next eq 'is') { |
|---|
| 772 | $which = \@is; |
|---|
| 773 | } |
|---|
| 774 | elsif ($next eq 'does') { |
|---|
| 775 | $which = \@does; |
|---|
| 776 | } |
|---|
| 777 | else { |
|---|
| 778 | push @$which, $pkg_really{$next} || "${PKG}::$next"; |
|---|
| 779 | } |
|---|
| 780 | } |
|---|
| 781 | push(@PKG, $PKG); |
|---|
| 782 | push(@RETREE, $RETREE); |
|---|
| 783 | $RETREE = {}; |
|---|
| 784 | $pkg_really{$name} = $PKG = "${PKG}::$name"; |
|---|
| 785 | $line .= "$ws moose_extends(qw(@is));" if @is; |
|---|
| 786 | $line .= "$ws moose_with(qw(@does));" if @does; |
|---|
| 787 | $line =~ s/${TOP}::$TOP/$TOP/g; |
|---|
| 788 | $ENDMATTER = '}'; |
|---|
| 789 | }; |
|---|
| 790 | |
|---|
| 791 | if ($line =~ s/^(\s*)role (\w+)(?:\[(.*?)\])?\s+(.*?)\{//) { |
|---|
| 792 | my $ws = $1; |
|---|
| 793 | my $name = $2; |
|---|
| 794 | my $params = $3; |
|---|
| 795 | my $is = $4; |
|---|
| 796 | my @is; |
|---|
| 797 | my @does; |
|---|
| 798 | my @list = split ' ', $is; |
|---|
| 799 | my $which; |
|---|
| 800 | |
|---|
| 801 | if ($params) { # parametric type? resort to eval... |
|---|
| 802 | my $qp = '{ ' . $params . ' }'; |
|---|
| 803 | $qp =~ s/(\$\w+)/'$1' => $1/g; |
|---|
| 804 | $line = <<"END"; |
|---|
| 805 | ${ws}{ package ${PKG}::$name; |
|---|
| 806 | $ws sub __instantiate__ { my \$self = shift; |
|---|
| 807 | $ws my ($params) = \@_; |
|---|
| 808 | $ws my \$mangle = ::mangle($params); |
|---|
| 809 | $ws my \$mixin = "${PKG}::${name}::" . \$mangle; |
|---|
| 810 | $ws return \$mixin if \$INSTANTIATED{\$mixin}++; |
|---|
| 811 | $ws ::deb("\t\tinstantiating \$mixin") if \$::DEBUG & DEBUG::mixins; |
|---|
| 812 | $ws my \$eval = "package \$mixin" . q{; |
|---|
| 813 | $ws use Moose::Role ':all' => { -prefix => "moose_" }; |
|---|
| 814 | $ws my \$retree; |
|---|
| 815 | $ws sub _PARAMS { $qp } |
|---|
| 816 | END |
|---|
| 817 | $ENDMATTER = <<"END"; |
|---|
| 818 | $ws }; |
|---|
| 819 | $ws eval \$eval; |
|---|
| 820 | $ws return \$mixin; |
|---|
| 821 | $ws } |
|---|
| 822 | $ws} |
|---|
| 823 | END |
|---|
| 824 | } |
|---|
| 825 | else { |
|---|
| 826 | $line = <<"END"; |
|---|
| 827 | ${ws}{ package ${PKG}::$name; |
|---|
| 828 | $ws use Moose::Role ':all' => { -prefix => "moose_" }; |
|---|
| 829 | $ws my \$retree; |
|---|
| 830 | END |
|---|
| 831 | $ENDMATTER = '}'; |
|---|
| 832 | } |
|---|
| 833 | |
|---|
| 834 | while (@list) { |
|---|
| 835 | my $next = shift @list; |
|---|
| 836 | if ($next eq 'is') { |
|---|
| 837 | $which = \@is; |
|---|
| 838 | } |
|---|
| 839 | elsif ($next eq 'does') { |
|---|
| 840 | $which = \@does; |
|---|
| 841 | } |
|---|
| 842 | else { |
|---|
| 843 | push @$which, $pkg_really{$next} || "${PKG}::$next"; |
|---|
| 844 | } |
|---|
| 845 | } |
|---|
| 846 | |
|---|
| 847 | push(@PKG, $PKG); |
|---|
| 848 | push(@RETREE, $RETREE); |
|---|
| 849 | $RETREE = {}; |
|---|
| 850 | $pkg_really{$name} = $PKG = "${PKG}::$name"; |
|---|
| 851 | $line .= "$ws moose_extends(qw(@is));\n" if @is; |
|---|
| 852 | $line .= "$ws moose_with(qw(@does));\n" if @does; |
|---|
| 853 | $line =~ s/${TOP}::$TOP/$TOP/g; |
|---|
| 854 | $out .= $line; |
|---|
| 855 | next; |
|---|
| 856 | } |
|---|
| 857 | |
|---|
| 858 | $line =~ s/\(state %(\w+)\)/(state \$$1)->/; |
|---|
| 859 | $line =~ s/(\S+) xx /($1) x /; |
|---|
| 860 | $line =~ s/(\S+) xx /($1) x /; |
|---|
| 861 | $line =~ s/ x \?/ x !!/; |
|---|
| 862 | $line =~ s/\|%start/%start/; |
|---|
| 863 | if ($line =~ m/method UNIT/) { |
|---|
| 864 | $OUR{'$unitstopper'}++; |
|---|
| 865 | $line =~ s/method UNIT \(\$unitstopper is context = "_EOS"\) \{/sub UNIT { |
|---|
| 866 | my \$self = shift; |
|---|
| 867 | local \$unitstopper = shift || "_EOS";/; |
|---|
| 868 | } |
|---|
| 869 | elsif ($line =~ m/Method nounphrase/) { |
|---|
| 870 | $line = <<'END'; |
|---|
| 871 | sub nounphrase { |
|---|
| 872 | my $self = shift; |
|---|
| 873 | my %args = @_; |
|---|
| 874 | my $noun = $args{noun}; |
|---|
| 875 | my $pre = $args{pre}; |
|---|
| 876 | my $post = $args{post}; |
|---|
| 877 | END |
|---|
| 878 | } |
|---|
| 879 | elsif ($line =~ s/^(\s*)method (\w+)\s*(.*?)\{/$1sub $2 { my \$self = shift; my $3= \@_; /) { |
|---|
| 880 | $out .= "# $1method $2 $3\n"; |
|---|
| 881 | $line =~ s/Match //g; |
|---|
| 882 | $line =~ s/Str //g; |
|---|
| 883 | $line =~ s/my \(\) = \@_;//g; |
|---|
| 884 | $line =~ s/my *= \@_;//g; |
|---|
| 885 | } |
|---|
| 886 | elsif ($line =~ s/^(\s*)sub (\w+)\s*(.*?)\{/$1sub $2 { my $3= \@_; /) { |
|---|
| 887 | $line =~ s/Match //g; |
|---|
| 888 | $line =~ s/Str //g; |
|---|
| 889 | $line =~ s/my \(\) = \@_;//g; |
|---|
| 890 | $line =~ s/\*\@/\@/; |
|---|
| 891 | $line =~ s/my *= \@_;//g; |
|---|
| 892 | } |
|---|
| 893 | |
|---|
| 894 | $out .= $line; |
|---|
| 895 | } |
|---|
| 896 | } |
|---|
| 897 | dumpretree(); |
|---|
| 898 | |
|---|
| 899 | print "# Emulate context vars by localizing 'our' vars living in main\n"; |
|---|
| 900 | for (sort keys(%OUR)) { |
|---|
| 901 | print "our $_;\n"; |
|---|
| 902 | } |
|---|
| 903 | print <<'END'; |
|---|
| 904 | |
|---|
| 905 | our $moreinput; |
|---|
| 906 | our $DEBUG; |
|---|
| 907 | our $DELIM; |
|---|
| 908 | |
|---|
| 909 | our %INSTANTIATED; |
|---|
| 910 | require 'mangle.pl'; |
|---|
| 911 | use utf8; |
|---|
| 912 | |
|---|
| 913 | END |
|---|
| 914 | |
|---|
| 915 | print $out; |
|---|
| 916 | print "# vim: sw=4 ft=perl\n"; |
|---|
| 917 | } |
|---|
| 918 | |
|---|
| 919 | sub dumpretree { |
|---|
| 920 | if (%$RETREE) { |
|---|
| 921 | $out .= "BEGIN {\n \$retree = YAML::Syck::Load(<<'RETREE_END');\n"; |
|---|
| 922 | $out .= Encode::decode("utf8", Dump($RETREE)); |
|---|
| 923 | $out .= "RETREE_END\n}\n"; |
|---|
| 924 | } |
|---|
| 925 | } |
|---|
| 926 | |
|---|
| 927 | sub here { |
|---|
| 928 | print STDERR +(caller(0))[3],": ",/^(.{0,20})/,"\n" if $TRACE; |
|---|
| 929 | } |
|---|
| 930 | |
|---|
| 931 | #############################################3333 |
|---|
| 932 | ## Regex |
|---|
| 933 | #############################################3333 |
|---|
| 934 | |
|---|
| 935 | sub ws { |
|---|
| 936 | return if $adverbs{s}; # meta whitespace parsed in atom |
|---|
| 937 | for (;;) { |
|---|
| 938 | # next if s/^(?!=[\0-~])\s+//; |
|---|
| 939 | next if s/^[\x20\t\n\r]+//; |
|---|
| 940 | last unless s/^#//; |
|---|
| 941 | next if s/^\(.*?\)//s; |
|---|
| 942 | next if s/^\{.*?\}//s; |
|---|
| 943 | next if s/^\[.*?\]//s; |
|---|
| 944 | next if s/^\<.*?\>//s; |
|---|
| 945 | next if s/^.*\n//; |
|---|
| 946 | last; |
|---|
| 947 | } |
|---|
| 948 | } |
|---|
| 949 | |
|---|
| 950 | sub wsany { |
|---|
| 951 | for (;;) { |
|---|
| 952 | next if s/^\s+//; |
|---|
| 953 | next if s/^#\(.*?\)//s; |
|---|
| 954 | next if s/^#\{.*?\}//s; |
|---|
| 955 | next if s/^#\[.*?\]//s; |
|---|
| 956 | next if s/^#\<.*?\>//s; |
|---|
| 957 | next if s/^#.*\n//; |
|---|
| 958 | last; |
|---|
| 959 | } |
|---|
| 960 | } |
|---|
| 961 | |
|---|
| 962 | sub regex { |
|---|
| 963 | here(); |
|---|
| 964 | ws(); |
|---|
| 965 | local $STOP = shift; |
|---|
| 966 | local %adverbs = %adverbs; |
|---|
| 967 | |
|---|
| 968 | my @decl; |
|---|
| 969 | while (s/^\s*:(my|state|our|constant)\b/$1/) { |
|---|
| 970 | my $code = unbalanced(";"); |
|---|
| 971 | s/^;// or panic "Missing ;"; |
|---|
| 972 | push @decl, bless { text => $code, min => 0, max => 0, %adverbs }, "RE_decl"; |
|---|
| 973 | } |
|---|
| 974 | |
|---|
| 975 | my $od = first(); |
|---|
| 976 | return bless { decl => [@decl], re => $od, min => $od->{min} }, "RE"; |
|---|
| 977 | } |
|---|
| 978 | |
|---|
| 979 | sub first { |
|---|
| 980 | here(); |
|---|
| 981 | my @kids; |
|---|
| 982 | my $min = 1_000_000_000; |
|---|
| 983 | |
|---|
| 984 | s/^\s*\|\|//; |
|---|
| 985 | |
|---|
| 986 | do { |
|---|
| 987 | ws(); |
|---|
| 988 | my $k = every(); |
|---|
| 989 | push @kids, $k; |
|---|
| 990 | my $kidmin = $k->{min}; |
|---|
| 991 | $min = $kidmin if $kidmin < $min; |
|---|
| 992 | ws(); |
|---|
| 993 | } while s/^\|\|//; |
|---|
| 994 | |
|---|
| 995 | return $kids[0] if @kids == 1; |
|---|
| 996 | return bless { zyg => [@kids], min => $min, %adverbs}, "RE_first"; |
|---|
| 997 | } |
|---|
| 998 | |
|---|
| 999 | sub every { |
|---|
| 1000 | here(); |
|---|
| 1001 | my @kids; |
|---|
| 1002 | my $min = 0; |
|---|
| 1003 | |
|---|
| 1004 | do { |
|---|
| 1005 | ws(); |
|---|
| 1006 | my $k = submatch(); |
|---|
| 1007 | push @kids, $k; |
|---|
| 1008 | my $kidmin = $k->{min}; |
|---|
| 1009 | $min = $kidmin if $kidmin > $min; |
|---|
| 1010 | ws(); |
|---|
| 1011 | } while s/^\&\&//; |
|---|
| 1012 | |
|---|
| 1013 | return $kids[0] if @kids == 1; |
|---|
| 1014 | return bless { zyg => [@kids], min => $min, %adverbs }, "RE_every"; |
|---|
| 1015 | } |
|---|
| 1016 | |
|---|
| 1017 | sub submatch { |
|---|
| 1018 | here(); |
|---|
| 1019 | my @kids; |
|---|
| 1020 | |
|---|
| 1021 | do { |
|---|
| 1022 | ws(); |
|---|
| 1023 | push @kids, any(); |
|---|
| 1024 | ws(); |
|---|
| 1025 | } while s/^\!?\~\~//; |
|---|
| 1026 | |
|---|
| 1027 | return $kids[0] if @kids == 1; |
|---|
| 1028 | return bless { zyg => [@kids], min => 0, %adverbs }, "RE_submatch"; |
|---|
| 1029 | } |
|---|
| 1030 | |
|---|
| 1031 | sub any { |
|---|
| 1032 | here(); |
|---|
| 1033 | my @kids; |
|---|
| 1034 | my $min = 1_000_000_000; |
|---|
| 1035 | local $ALTNAME = $NAME . '_' . $ALTNAMES++; |
|---|
| 1036 | my $name = $ALTNAME; |
|---|
| 1037 | |
|---|
| 1038 | s/^ \s*\| (?!\|) //x; |
|---|
| 1039 | |
|---|
| 1040 | do { |
|---|
| 1041 | ws(); |
|---|
| 1042 | my $k = all(); |
|---|
| 1043 | push @kids, $k; |
|---|
| 1044 | my $kidmin = $k->{min}; |
|---|
| 1045 | $min = $kidmin if $kidmin < $min; |
|---|
| 1046 | ws(); |
|---|
| 1047 | } while s/^ \| (?!\|) //x; |
|---|
| 1048 | |
|---|
| 1049 | return $kids[0] if @kids == 1; |
|---|
| 1050 | |
|---|
| 1051 | return bless { zyg => [@kids], min => $min, altname => $ALTNAME, name => $name, %adverbs }, |
|---|
| 1052 | "RE_any"; |
|---|
| 1053 | } |
|---|
| 1054 | |
|---|
| 1055 | sub all { |
|---|
| 1056 | here(); |
|---|
| 1057 | my @kids; |
|---|
| 1058 | my $min = 0; |
|---|
| 1059 | |
|---|
| 1060 | do { |
|---|
| 1061 | ws(); |
|---|
| 1062 | my $k = sequence(); |
|---|
| 1063 | push @kids, $k; |
|---|
| 1064 | my $kidmin = $k->{min}; |
|---|
| 1065 | warn "no kidmin $k\n" unless defined $kidmin; |
|---|
| 1066 | $min = $kidmin if $kidmin > $min; |
|---|
| 1067 | ws(); |
|---|
| 1068 | } while s/^ \& (?!\&) //x; |
|---|
| 1069 | |
|---|
| 1070 | return $kids[0] if @kids == 1; |
|---|
| 1071 | return bless { zyg => [@kids], min => $min, %adverbs }, "RE_all"; |
|---|
| 1072 | } |
|---|
| 1073 | |
|---|
| 1074 | sub sequence { |
|---|
| 1075 | here(); |
|---|
| 1076 | my @kids; |
|---|
| 1077 | my $k; |
|---|
| 1078 | my $min = 0; |
|---|
| 1079 | my $lastws = 0; |
|---|
| 1080 | |
|---|
| 1081 | while ($k = quantified_atom()) { |
|---|
| 1082 | if ($lastws) { |
|---|
| 1083 | # optimize away any redundant ws |
|---|
| 1084 | $k->remove_leading_ws(); |
|---|
| 1085 | } |
|---|
| 1086 | push(@kids, $k); |
|---|
| 1087 | $lastws = ref $k eq 'RE_method' && $k->{name} eq 'ws'; |
|---|
| 1088 | my $kidmin = $k->{min}; |
|---|
| 1089 | $min += $kidmin; |
|---|
| 1090 | } |
|---|
| 1091 | |
|---|
| 1092 | return $kids[0] if @kids == 1; |
|---|
| 1093 | return bless { zyg => [@kids], min => $min, %adverbs }, "RE_sequence"; |
|---|
| 1094 | } |
|---|
| 1095 | |
|---|
| 1096 | sub quantified_atom { |
|---|
| 1097 | here(); |
|---|
| 1098 | my $atom = atom(); |
|---|
| 1099 | return unless defined $atom and $atom ne ''; |
|---|
| 1100 | return $atom if $atom->{noquant}; |
|---|
| 1101 | my $quant = quantifier(); |
|---|
| 1102 | return $atom unless $quant; |
|---|
| 1103 | my $min = $atom->{min} * $quant->[3]; |
|---|
| 1104 | return bless { atom => $atom, quant => $quant, min => $min }, |
|---|
| 1105 | "RE_quantified_atom"; |
|---|
| 1106 | } |
|---|
| 1107 | |
|---|
| 1108 | sub quantifier { |
|---|
| 1109 | if (s/^\s*(\*\*)([?!:+]?)// or |
|---|
| 1110 | s/^\s*(\*)([?!:+]?)// or |
|---|
| 1111 | s/^\s*(\+)([?!:+]?)// or |
|---|
| 1112 | s/^\s*(\?)([?!:+]?)//) { |
|---|
| 1113 | my ($q,$m) = ($1,$2); |
|---|
| 1114 | my $min = 0; |
|---|
| 1115 | if (not $m) { |
|---|
| 1116 | if ($adverbs{r}) { |
|---|
| 1117 | $m = ':'; |
|---|
| 1118 | } |
|---|
| 1119 | else { |
|---|
| 1120 | $m = '!'; |
|---|
| 1121 | } |
|---|
| 1122 | } |
|---|
| 1123 | elsif ($m eq '+') { |
|---|
| 1124 | $m = '!'; |
|---|
| 1125 | } |
|---|
| 1126 | my $x = ""; |
|---|
| 1127 | if ($q eq '**') { |
|---|
| 1128 | if (s/^\s*((\d+)(\.\.(\d+|\*))?)//) { |
|---|
| 1129 | $x = $1; |
|---|
| 1130 | $min = $2; |
|---|
| 1131 | } |
|---|
| 1132 | elsif (/^\s*\{/) { |
|---|
| 1133 | wsany(); |
|---|
| 1134 | $x = block('thunk'); |
|---|
| 1135 | $min = 0; |
|---|
| 1136 | } |
|---|
| 1137 | else { |
|---|
| 1138 | wsany(); |
|---|
| 1139 | $x = atom(); |
|---|
| 1140 | $min = 1; |
|---|
| 1141 | } |
|---|
| 1142 | } |
|---|
| 1143 | elsif ($q eq '+') { |
|---|
| 1144 | $min = 1; |
|---|
| 1145 | } |
|---|
| 1146 | ws(); |
|---|
| 1147 | $MAYBACKTRACK = 1 unless $m eq ':'; |
|---|
| 1148 | return [$q,$m,$x,$min]; |
|---|
| 1149 | } |
|---|
| 1150 | } |
|---|
| 1151 | |
|---|
| 1152 | sub atom { |
|---|
| 1153 | here(); |
|---|
| 1154 | if (@STUFFED) { |
|---|
| 1155 | return shift @STUFFED; |
|---|
| 1156 | } |
|---|
| 1157 | # unspace |
|---|
| 1158 | if (s/^\\\s/ /) { |
|---|
| 1159 | panic("Attempt to quote whitespace"); |
|---|
| 1160 | } |
|---|
| 1161 | # sigspace |
|---|
| 1162 | if (/^[\s\#]/ and $adverbs{s}) { |
|---|
| 1163 | wsany(); |
|---|
| 1164 | return bless { name => 'ws', nobind => 1, noquant => 1, min => 0, rest => '' }, |
|---|
| 1165 | "RE_method"; |
|---|
| 1166 | } |
|---|
| 1167 | return if /^ [\]&|] /x; # XXX an approximation |
|---|
| 1168 | return if /^ \)[^>]/x; |
|---|
| 1169 | return if /^ (?: |
|---|
| 1170 | >(?!>) | |
|---|
| 1171 | !?~~ |
|---|
| 1172 | )/x; |
|---|
| 1173 | return if /^ ( $STOP )/x; |
|---|
| 1174 | |
|---|
| 1175 | if (/^[*+?]/) { panic "quantifier quantifies nothing"; } |
|---|
| 1176 | |
|---|
| 1177 | if (s/^~//) { |
|---|
| 1178 | wsany(); |
|---|
| 1179 | my $beg = length($all) - length($_); |
|---|
| 1180 | my $goal = quantified_atom(); |
|---|
| 1181 | my $end = length($all) - length($_); |
|---|
| 1182 | my $goaltext = substr($all, $beg, $end - $beg); |
|---|
| 1183 | |
|---|
| 1184 | my $dba = $adverbs{dba} // $NAME; |
|---|
| 1185 | $dba =~ s/'/\\\'/g; |
|---|
| 1186 | my $failgoal = bless { name => 'FAILGOAL', rest => "($goaltext, '$dba')", min => 0, nobind => 1 }, "RE_method"; |
|---|
| 1187 | my $check = bless { zyg => [$goal, $failgoal], min => 1, %adverbs}, "RE_first"; |
|---|
| 1188 | my $checkbrack = bless({ decl => [], re => $check, min => 1 }, "RE_bracket"); |
|---|
| 1189 | |
|---|
| 1190 | wsany(); |
|---|
| 1191 | |
|---|
| 1192 | my $nest = quantified_atom(); |
|---|
| 1193 | |
|---|
| 1194 | @STUFFED = ($nest, $checkbrack); |
|---|
| 1195 | return bless { text => '::', min => 0, extra => "local \$::GOAL = $goaltext", %adverbs }, "RE_meta"; |
|---|
| 1196 | } |
|---|
| 1197 | if (s/^ (\w+) (?! \s* [*+?]) //x) { |
|---|
| 1198 | my $word = $1; |
|---|
| 1199 | ws(); |
|---|
| 1200 | return bless { text => $word, min => length($word), %adverbs }, "RE_string"; |
|---|
| 1201 | } |
|---|
| 1202 | if (s/^ (\w) //x) { |
|---|
| 1203 | my $word = $1; |
|---|
| 1204 | ws(); |
|---|
| 1205 | return bless { text => $word, min => length($word), %adverbs }, "RE_string"; |
|---|
| 1206 | } |
|---|
| 1207 | |
|---|
| 1208 | if (s/^\{\*\}//) { |
|---|
| 1209 | my $key = $NAME; |
|---|
| 1210 | if (s/^(.*?)\s*#=\s+(.*)/$1/) { |
|---|
| 1211 | $key .= " $2"; |
|---|
| 1212 | } |
|---|
| 1213 | $key =~ s/ +/_/g; |
|---|
| 1214 | ws(); |
|---|
| 1215 | $key =~ s/(['\\])/\\$1/g; |
|---|
| 1216 | return bless { name => '_REDUCE', args => "\$S, '$key'", min => 0, max => 0}, |
|---|
| 1217 | "RE_method_internal"; |
|---|
| 1218 | } |
|---|
| 1219 | if (/^\{/) { |
|---|
| 1220 | my $b = block('void'); |
|---|
| 1221 | ws(); |
|---|
| 1222 | return $b; |
|---|
| 1223 | } |
|---|
| 1224 | |
|---|
| 1225 | if (s/^\\//) { my $bs = backslash(); ws(); return $bs; } |
|---|
| 1226 | |
|---|
| 1227 | if (s/^\[//) { |
|---|
| 1228 | my $re = regex('\\]'); |
|---|
| 1229 | s/^\]// or panic "Missing ]"; |
|---|
| 1230 | ws(); |
|---|
| 1231 | return bless $re, "RE_bracket"; |
|---|
| 1232 | } |
|---|
| 1233 | |
|---|
| 1234 | if (s/^\(//) { |
|---|
| 1235 | my $re = regex('\\)'); |
|---|
| 1236 | s/^\)// or panic "Missing )"; |
|---|
| 1237 | ws(); |
|---|
| 1238 | $re = bless $re, "RE_paren"; |
|---|
| 1239 | if (not $PARSEBIND) { # XXX leaves quantifier outside? |
|---|
| 1240 | $re = bless { var => $PAREN++, atom => $re, min => $re->{min} }, |
|---|
| 1241 | "RE_bindpos"; |
|---|
| 1242 | } |
|---|
| 1243 | return $re; |
|---|
| 1244 | } |
|---|
| 1245 | |
|---|
| 1246 | if (s/^ : (!?) (\w+)//x) { |
|---|
| 1247 | my $not = $1 ne ''; |
|---|
| 1248 | my $adverb = $2; |
|---|
| 1249 | $adverb =~ s/^sigspace/s/; |
|---|
| 1250 | $adverb =~ s/^ratchet/r/; |
|---|
| 1251 | |
|---|
| 1252 | if (m/^\(/) { |
|---|
| 1253 | pos($_) = 0; |
|---|
| 1254 | my $code = extract_bracketed($_,'(q)'); |
|---|
| 1255 | $code = ::un6($code); |
|---|
| 1256 | $adverbs{$adverb} = $code; |
|---|
| 1257 | ws(); |
|---|
| 1258 | if ($adverb eq 'lang') { |
|---|
| 1259 | $code = "my \$newlang = $code; \$C = \$C->cursor_fresh(\$newlang); "; |
|---|
| 1260 | return bless { text => $code, min => 0, max => 0, noquant => 1, %adverbs }, "RE_decl"; |
|---|
| 1261 | } |
|---|
| 1262 | elsif ($adverb eq 'dba') { |
|---|
| 1263 | $adverbs{$adverb} = eval $code; |
|---|
| 1264 | } |
|---|
| 1265 | } |
|---|
| 1266 | elsif (s/^<(.*?)>//) { |
|---|
| 1267 | $adverbs{$adverb} = $1; |
|---|
| 1268 | } |
|---|
| 1269 | else { |
|---|
| 1270 | $adverbs{$adverb} = 0+!$not; |
|---|
