5 # Copyright 2008-2010, Larry Wall
7 # You may copy this software under the terms of the Artistic License,
8 # version 2.0 or later.
12 no warnings 'recursion';
22 use feature 'say', 'state';
28 $::DEBUG //= 0 + ($ENV{STD5DEBUG} // 0);
31 use constant DEBUG => $::DEBUG;
32 our %LEXERS; # per language, the cache of lexers, keyed by rule identity
33 our %FATECACHE; # fates we've already turned into linked lists
36 sub ::fatestr { my $f = shift;
39 $text .= $f->[1] . " " . $f->[2];
40 $text .= ' ' if $f = $f->[0];
58 use Scalar::Util 'refaddr';
61 our $BLUE = color 'blue';
62 our $GREEN = color 'green';
63 our $CYAN = color 'cyan';
64 our $MAGENTA = color 'magenta';
65 our $YELLOW = color 'yellow';
66 our $RED = color 'red';
67 our $CLEAR = color 'clear';
69 use LazyMap qw(lazymap eager);
70 use constant DEBUG => $::DEBUG;
72 our $REGEXES = { ALL => [] };
76 # this prevents us from inheriting from Moose::Object, which saves a
77 # good 20 seconds on DESTROY/DEMOLISHALL
78 Moose::Meta::Class->create('CursorBase');
81 $::PERL6HERE = $ENV{PERL6HERE} // '⏏';
82 Encode::_utf8_on($::PERL6HERE);
84 binmode(STDIN, ":utf8");
85 binmode(STDERR, ":utf8");
86 binmode(STDOUT, ":utf8");
89 open(::LOG, ">&1") or die "Can't create $0.log: $!";
92 open(::LOG, ">$0.log") or die "Can't create $0.log: $!";
94 binmode(::LOG, ":utf8");
97 #############################################################
99 #############################################################
101 sub _PARAMS {} # overridden in parametric role packages
103 sub from :lvalue { $_[0]->{_from} //= $_[0]->{_pos} }
104 sub to { $_[0]->{_pos} }
105 sub pos :lvalue { $_[0]->{_pos} }
106 sub chars { $_[0]->{_pos} - ($_[0]->{_from} // $_[0]->{_pos}) }
107 sub Str { no warnings; exists $_[0]->{_from} && defined $_[0]->{_pos} ? substr($::ORIG, $_[0]->{_from}, $_[0]->{_pos} - $_[0]->{_from})//'' : '' }
108 sub xact { $_[0]->{_xact} // die "internal error: cursor has no xact!!!" }
109 sub orig { \$::ORIG }
110 sub WHAT { ref $_[0] || $_[0] }
113 sub caps { $_[0] && $_[0]->{'~CAPS'} ? @{$_[0]->{'~CAPS'}} : () }
114 sub chunks { die "unimpl" }
115 sub ast { exists $_[0]->{'_ast'} ? $_[0]->{'_ast'} : $_[0]->Str }
116 sub make { $_[0]->{'_ast'} = $_[1]; $_[0] }
119 bless { 'file' => $::FILE->{name}, 'pos' => $_[0]->{_pos} }, 'LABEL';
122 sub list { my $self = shift;
124 # can't just do this in numerical order because some might be missing
125 # and we don't know the max
126 for my $k (keys %$self) {
127 $result[$k] = $self->{$k} if $k =~ /^\d/;
132 sub hash { my $self = shift;
134 for my $k (keys %$self) {
135 $result{$k} = $self->{$k} if $k !~ /^[_\d~]/;
140 sub deb { my $self = shift;
141 my $pos = ref $self && defined $self->{_pos} ? $self->{_pos} : "?";
142 print ::LOG $pos,'/',$self->lineof($pos), "\t", $CTX, ' ', @_, "\n";
147 delete $self->{_fate};
148 delete $self->{_pos}; # EXPR blows up without this for some reason
149 delete $self->{_reduced};
150 for my $k (values %$self) {
152 if (ref $k eq 'ARRAY') {
155 $k2->clean if ref $k2;
171 delete $copy{_reduced};
173 my $text = STD::Dump(\%copy);
177 #############################################################
179 #############################################################
184 { no warnings; @::ORIG = unpack("U*", $::ORIG); }
185 $::MEMOS[@::ORIG] = undef; # memos kept by position
186 my %args = ('_pos' => 0, '_from' => 0);
189 $args{'_' . $name} = shift;
191 my $self = bless \%args, ref $class || $class;
192 $self->{_xact} = ['MATCH',0,0];
199 local $::FILE = { name => '(eval)' };
200 $class->initparse($text,@_);
206 local $::FILE = { name => $file };
208 my $tmp_prefix = $args{tmp_prefix} // $ENV{STD5PREFIX} // '';
209 local $::TMP_PREFIX = $tmp_prefix;
211 open(FILE, '<:utf8', $file) or die "Can't open $file: $!\n";
220 $result = $class->initparse($text,@_);
222 if ($::YOU_WERE_HERE) {
223 $result->you_were_here;
225 elsif ($file =~ /\.pm6?$/) {
226 $result->you_were_here;
231 ## method initparse ($text, :$rule = 'TOP', :$tmp_prefix = '', :$setting = 'CORE', :$actions = '')
236 my $rule = $args{rule} // 'TOP';
237 my $tmp_prefix = $args{tmp_prefix} // $ENV{STD5PREFIX} // '';
238 my $setting = $args{setting} // 'CORE';
239 my $actions = $args{actions} // '';
241 local $::TMP_PREFIX = $tmp_prefix;
242 local $::SETTINGNAME = $setting;
243 local $::ACTIONS = $actions;
244 local @::MEMOS = @::MEMOS;
246 local @::ACTIVE = ();
248 # various bits of info useful for error messages
249 local $::HIGHWATER = 0;
250 local $::HIGHMESS = '';
251 local $::HIGHEXPECT = {};
253 local $::LAST_NIBBLE = bless { firstline => 0, lastline => 0 }, 'Cursor';
254 local $::LAST_NIBBLE_MULTILINE = bless { firstline => 0, lastline => 0 }, 'Cursor';
255 local $::GOAL = "(eof)";
256 $text .= "\n" unless substr($text,-1,1) eq "\n";
257 $::ORIG = $text; # original string
259 my $result = $self->new()->$rule();
260 delete $result->{_xact};
262 # XXX here attach stuff that will enable :cont
270 my $syml = $::TMP_PREFIX . 'syml';
271 my $file = "$syml/$setting.syml";
273 bless($self->load_yaml_pad($setting),'Stash');
276 bless($self->load_perl_pad($setting),'Stash');
284 return $PADS{$setting} if $PADS{$setting};
285 my $file = "$setting.pad";
286 my $syml = $::TMP_PREFIX . 'syml';
287 my $store = "$syml/$setting.pad.store";
288 mkdir $syml unless -d $syml;
289 if (-f $store and -M $file and -M $file > -M $store) {
290 $PADS{$setting} = retrieve($store);
293 $PADS{$setting} = require $file;
294 store($PADS{$setting}, $store);
301 open my $fh, $file or die "Can't open $file: $!";
302 my $text = do { local $/; <$fh>; };
311 return $PADS{$setting} if $PADS{$setting};
312 my $syml = $::TMP_PREFIX . 'syml';
313 my $file = "$syml/$setting.syml";
314 my $store = "$syml/$setting.syml.store";
315 mkdir $syml unless -d $syml;
316 if (-f $store and -M $file and -M $file > -M $store) {
317 $PADS{$setting} = retrieve($store);
320 $PADS{$setting} = LoadFile($file);
321 store($PADS{$setting}, $store);
323 # say join ' ', sort keys %{ $PADS{$setting} };
329 $::YOU_WERE_HERE = $::CURPAD;
335 my $file = $::FILE->{name};
337 $file =~ s/(\.setting)?$/.syml/;
340 $file = $::TMP_PREFIX . "syml/" . $file;
343 if ($::YOU_WERE_HERE) {
345 $all->{SETTING} = $::YOU_WERE_HERE;
348 eval { $::UNIT->{'$?SETTING_ID'} = $STD::ALL->{SETTING}->id };
350 eval { $::UNIT->{'$?CORE_ID'} = $STD::ALL->{CORE}->id };
354 for my $key (keys %{$STD::ALL}) {
355 next if $key =~ /^MY:file<\w+\.setting>/ or $key eq 'CORE' or $key eq 'SETTING';
356 $all->{$key} = $STD::ALL->{$key};
361 my @parts = split('/',$file);
362 my $newfile = shift @parts;
364 mkdir $newfile unless -d $newfile;
365 $newfile .= '/' . shift @parts;
368 open(SETTING, ">$file") or die "Can't open new setting file $file: $!";
369 print SETTING Dump($all);
380 sub new { my $self = shift;
385 sub from { my $self = shift;
389 sub to { my $self = shift;
394 #############################################################
395 # Cursor transformations
396 #############################################################
398 sub cursor_xact { my $self = shift;
400 if (DEBUG & DEBUG::cursors) {
402 for (my $x = $self->{_xact}; $x; $x = $x->[-1]) {
406 $pedigree .= ($x->[-2] ? " - " : " + ") . $n;
408 $self->deb("cursor_xact $name$pedigree");
410 # doing this in place is slightly dangerous, but seems to work
411 $self->{_xact} = [$name,0,$self->{_xact}];
415 sub cursor_fresh { my $self = shift;
417 my $lang = @_ && $_[0] ? shift() : ref $self;
418 $self->deb("cursor_fresh lang $lang") if DEBUG & DEBUG::cursors;
419 @r{'_pos','_fate','_xact'} = @$self{'_pos','_fate','_xact'};
420 $r{_herelang} = $self->{_herelang} if $self->{_herelang};
421 bless \%r, ref $lang || $lang;
424 sub cursor_herelang { my $self = shift;
425 $self->deb("cursor_herelang") if DEBUG & DEBUG::cursors;
427 $r{_herelang} = $self;
433 delete $self->{_fate};
434 delete $_->{_xact} for @_;
438 sub cursor_bind { my $self = shift; # this is parent's match cursor
439 my $bindings = shift;
440 my $submatch = shift; # this is the submatch's cursor
441 $self->prepbind($submatch);
443 $self->deb("cursor_bind @$bindings") if DEBUG & DEBUG::cursors;
445 @caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'}; # must copy elems
448 for my $binding (@$bindings) {
449 if (ref $r{$binding} eq 'ARRAY') {
450 push(@{$r{$binding}}, $submatch);
453 $r{$binding} = $submatch;
455 next if $binding eq 'PRE';
456 next if $binding eq 'POST';
457 push @caps, $binding, $submatch;
459 $r{'~CAPS'} = \@caps;
461 $submatch->{_from} = $r{_from} = $r{_pos};
462 $r{_pos} = $submatch->{_pos};
463 $r{_xact} = $self->{_xact};
464 bless \%r, ref $self; # return new match cursor for parent
467 sub cursor_fate { my $self = shift;
471 # $_[0] is now ref to a $trystate;
473 $self->deb("cursor_fate $pkg $name") if DEBUG & DEBUG::cursors;
474 my $key = refaddr($retree->{$name}) // $name;
476 my $lexer = $::LEXERS{ref $self}->{$key} // do {
478 $self->_AUTOLEXpeek($name,$retree);
480 if ($self->{_pos} >= $::HIGHWATER) {
481 if ($self->{_pos} > $::HIGHWATER) {
485 $::HIGHEXPECT->{$lexer->{DBA}}++;
486 $::HIGHWATER = $self->{_pos};
489 my $P = $self->{_pos};
494 $self->cursor_fate_dfa($pkg, $name, $lexer, $P);
497 sub cursor_fate_dfa {
498 my ($self, $pkg, $name, $lexer, $P) = @_;
500 my $state = $lexer->{S};
504 print ::LOG "=" x 10,"\n$p DFA for ${pkg}::$name in ", ref $self, "\n" if DEBUG & DEBUG::autolexer;
506 push @rfates, @{ $state->[0] // _jit_dfa_node($lexer, $state) };
507 if (DEBUG & DEBUG::autolexer) {
508 for (@{ $state->[0] }) {
510 for (my $f = $_; $f; $f = $f->[0]) {
513 print ::LOG " [adding fate @b]\n";
516 last if $p == @::ORIG;
517 my $chi = $::ORIG[$p++];
518 print ::LOG "--- ", pack("U", $chi), "\n" if DEBUG & DEBUG::autolexer;
519 if ($state->[1]{$chi}) {
520 $state = $state->[1]{$chi};
521 print ::LOG "specific -> ", $state->[1]{ID}, "\n"
522 if DEBUG & DEBUG::autolexer;
526 my $dt = $state->[2];
527 while (defined $dt) {
528 if (ref $dt eq 'ARRAY') {
529 if (DEBUG & DEBUG::autolexer) {
530 print ::LOG $dt->[2][-1],
531 (vec($dt->[2][$chi >> 10], $chi & 1023, 1) ?
532 "? yes\n" : "? no\n");
534 $dt = $dt->[vec($dt->[2][$chi >> 10], $chi & 1023, 1)];
536 print ::LOG " -> ", $$dt->[1]{ID}, "\n" if DEBUG & DEBUG::autolexer;
537 $state = $state->[1]{$chi} = $$dt;
543 sub { @rfates ? pop(@rfates) : () };
546 sub cursor_all { my $self = shift;
550 $self->deb("cursor_all from $fpos to $tpos") if DEBUG & DEBUG::cursors;
552 @r{'_from','_pos'} = ($fpos,$tpos);
554 bless \%r, ref $self;
557 sub makestr { my $self = shift;
558 $self->deb("maketext @_") if DEBUG & DEBUG::cursors;
564 sub cursor_tweak { my $self = shift;
567 if (DEBUG & DEBUG::cursors) {
568 my $peek = substr($::ORIG,$tpos,20);
571 $self->deb("cursor to $tpos --------->$GREEN$peek$CLEAR");
573 $self->{_pos} = $tpos;
574 return () if $tpos > @::ORIG;
579 sub cursor_incr { my $self = shift;
580 my $tpos = $self->{_pos} + 1;
582 $self->panic("Unexpected EOF") if $tpos > length($::ORIG);
583 if (DEBUG & DEBUG::cursors) {
584 my $peek = substr($::ORIG,$tpos,20);
587 $self->deb("cursor to $tpos --------->$GREEN$peek$CLEAR");
589 $self->{_pos} = $tpos;
590 return () if $tpos > @::ORIG;
595 sub cursor { my $self = shift;
598 $self->panic("Unexpected EOF") if $tpos > length($::ORIG);
599 if (DEBUG & DEBUG::cursors) {
600 my $peek = substr($::ORIG,$tpos,20);
603 $self->deb("cursor to $tpos --------->$GREEN$peek$CLEAR");
606 # $r{_from} = $self->{_pos} // 0;
609 bless \%r, ref $self;
612 sub cursor_force { my $self = shift;
615 $self->panic("Unexpected EOF") if $tpos > length($::ORIG);
616 if (DEBUG & DEBUG::cursors) {
617 my $peek = substr($::ORIG,$tpos,20);
620 $self->deb("cursor to $tpos --------->$GREEN$peek$CLEAR");
623 # $r{_from} = $self->{_pos} // 0;
624 $r{_pos} = $::HIGHWATER = $tpos;
626 bless \%r, ref $self;
629 sub cursor_rev { my $self = shift;
632 if (DEBUG & DEBUG::cursors) {
633 my $peek = substr($::ORIG,$fpos,20);
636 $self->deb("cursor_ref to $fpos --------->$GREEN$peek$CLEAR");
641 bless \%r, ref $self;
644 #############################################################
645 # Regex service routines
646 #############################################################
648 sub callm { my $self = shift;
650 my $class = ref($self) || $self;
655 if (DEBUG & DEBUG::callm_show_subnames) {
656 while (my @c = caller($lvl)) {
662 elsif ($s =~ /^Cursor(?:Base)?::/) {
665 elsif ($s =~ /^LazyMap::/) {
668 elsif ($s =~ /^\(eval\)/) {
672 $extralvl = $lvl unless $extralvl;
679 while (my @c = caller($lvl)) { $lvl++; }
681 my ($package, $file, $line, $subname, $hasargs) = caller(1);
687 $self->deb($name, " [", $file, ":", $line, "] $class") if DEBUG & DEBUG::trace_call;
688 if (DEBUG & DEBUG::callm_show_subnames) {
689 $RED . join(' ', reverse @subs) . $CLEAR . ':' x $extralvl;
697 return $_[0] unless DEBUG & DEBUG::trace_call;
699 warn "Returning non-Cursor: $self\n" unless exists $self->{_pos};
700 my ($package, $file, $line, $subname, $hasargs) = caller(1);
701 $self->deb($subname, " returning @{[$self->{_pos}]}");
705 sub _MATCHIFY { my $self = shift;
709 my $xact = $self->{_xact};
710 my @result = lazymap( sub { my $x = shift; $x->{_xact} = $xact; $x->_REDUCE($S, $name)->retm() }, @_);
719 sub _MATCHIFYr { my $self = shift;
724 # $var->{_from} = $self->{_from};
725 my $xact = $self->{_xact};
726 $var->{_xact} = $xact;
727 $var->_REDUCE($S, $name)->retm();
730 sub _SCANf { my $self = shift;
732 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
735 my $pos = $self->{_pos};
736 my $C = $self->cursor_xact("SCANf $pos");
739 lazymap( sub { $self->cursor($_[0])->retm() }, LazyRange->new($xact, $pos,$eos) );
742 sub _SCANg { my $self = shift;
744 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
745 my $pos = $self->{_pos};
747 my $C = $self->cursor_xact("SCANg $pos");
750 lazymap( sub { $C->cursor($_[0])->retm() }, LazyRangeRev->new($xact, $eos,$pos) );
753 sub _STARf { my $self = shift;
755 no warnings 'recursion';
757 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
759 my $pos = $self->{_pos};
760 my $C = $self->cursor_xact("SCANf $pos");
763 lazymap(sub { $_[0]->retm() },
765 LazyMap->new(sub { $C->_PLUSf($_[0]) }, $block));
768 sub _STARg { my $self = shift;
770 no warnings 'recursion';
772 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
774 my $pos = $self->{_pos};
775 my $C = $self->cursor_xact("STARg $pos");
776 # my $xact = $C->xact;
778 lazymap(sub { $_[0]->retm() }, reverse
780 $C->cursor($self->{_pos}),
785 sub _STARr { my $self = shift;
787 no warnings 'recursion';
789 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
790 my $pos = $self->{_pos};
791 my $prev = $self->cursor_xact("STARr $pos");
792 # my $xact = $prev->xact;
794 my $prev_pos = $prev->{_pos} // 0;
799 last if $prev->{_pos} == $eos;
800 my @matches = $block->($prev); # XXX shouldn't read whole list
802 last unless @matches;
803 my $first = $matches[0]; # no backtracking into block on ratchet
804 last if $first->{_pos} == $prev_pos;
805 $prev_pos = $first->{_pos};
809 $self->cursor($prev_pos)->retm();
812 sub _PLUSf { my $self = shift;
814 no warnings 'recursion';
816 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
818 my $pos = $self->{_pos};
819 my $x = $self->cursor_xact("PLUSf $pos");
822 # don't go beyond end of string
823 return () if $self->{_pos} == @::ORIG;
830 $self->cursor($_[0]->{_pos})->retm()
831 }, $x, LazyMap->new(sub { $x->_PLUSf($_[0]) }, $block)
837 sub _PLUSg { my $self = shift;
839 no warnings 'recursion';
841 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
843 my $pos = $self->{_pos};
844 my $C = $self->cursor_xact("PLUSg $pos");
845 # my $xact = $C->xact;
847 reverse eager($C->_PLUSf($block, @_));
850 sub _PLUSr { my $self = shift;
852 no warnings 'recursion';
854 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
858 my $pos = $self->{_pos};
859 my $to = $self->cursor_xact("PLUSr $pos");
860 # my $xact = $to->xact;
863 last if $to->{_pos} == $eos;
864 my @matches = $block->($to); # XXX shouldn't read whole list
865 last unless @matches;
866 my $first = $matches[0]; # no backtracking into block on ratchet
867 #$first->deb($matches->perl) if DEBUG;
871 return () unless @all;
872 $self->cursor($to->{_pos})->retm();
875 sub _REPSEPf { my $self = shift;
878 no warnings 'recursion';
880 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
883 # don't go beyond end of string
884 return () if $self->{_pos} == @::ORIG;
886 my $pos = $self->{_pos};
887 my $C = $self->cursor_xact("REPSEPf $pos");
888 # my $xact = $C->xact;
891 for my $x ($block->($C)) {
892 for my $s ($sep->($x)) {
893 push @result, lazymap(sub { $C->cursor($_[0]->{_pos}) }, $x, $s->_REPSEPf($sep,$block));
897 lazymap(sub { $_[0]->retm() }, @result);
900 sub _REPSEPg { my $self = shift;
903 no warnings 'recursion';
905 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
907 my $pos = $self->{_pos};
908 my $C = $self->cursor_xact("REPSEPg $pos");
909 # my $xact = $C->xact;
911 reverse eager($C->_REPSEPf($sep, $block, @_));
914 sub _REPSEPr { my $self = shift;
917 no warnings 'recursion';
919 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
923 my $pos = $self->{_pos};
924 my $to = $self->cursor_xact("REPSEPr $pos");
925 # my $xact = $C->xact;
928 last if $to->{_pos} == $eos;
929 my @matches = $block->($to); # XXX shouldn't read whole list
930 last unless @matches;
931 my $first = $matches[0]; # no backtracking into block on ratchet
932 #$first->deb($matches->perl) if DEBUG;
934 my @seps = $sep->($first);
939 return () unless @all;
940 $self->cursor($all[-1]->{_pos})->retm;
943 sub _OPTr { my $self = shift;
945 no warnings 'recursion';
947 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
949 my $pos = $self->{_pos};
950 my $C = $self->cursor_xact("OPTr $pos");
953 my $x = ($block->($C))[0];
954 my $r = $x // $C->cursor_tweak($pos);
955 $r->{_xact} = $self->{_xact};
959 sub _OPTg { my $self = shift;
961 no warnings 'recursion';
963 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
965 my $pos = $self->{_pos};
966 my $C = $self->cursor_xact("OPTg $pos");
967 # my $xact = $C->xact;
969 my @x = $block->($C);
971 lazymap(sub { $_[0]->retm() },
973 $self->cursor($pos));
976 sub _OPTf { my $self = shift;
978 no warnings 'recursion';
980 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
982 my $pos = $self->{_pos};
983 my $C = $self->cursor_xact("OPTf $pos");
984 # my $xact = $C->xact;
986 lazymap(sub { $_[0]->retm() },
987 $C->cursor($C->{_pos}),
991 sub _BRACKET { my $self = shift;
993 no warnings 'recursion';
995 my $oldlang = ref($self);
996 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
997 lazymap(sub { bless($_[0],$oldlang)->retm() },
1001 sub _BRACKETr { my $self = shift;
1003 no warnings 'recursion';
1005 my $oldlang = ref($self);
1006 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1007 my ($val) = $block->($self) or return ();
1008 bless($val,$oldlang)->retm();
1011 sub _PAREN { my $self = shift;
1013 no warnings 'recursion';
1015 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1016 lazymap(sub { $_[0]->retm() },
1020 sub _NOTBEFORE { my $self = shift;
1022 no warnings 'recursion';
1024 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1025 local $::HIGHEXPECT = {}; # don't count lookahead as expectation
1026 local $::HIGHWATER = $::HIGHWATER;
1028 @caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'}; # must copy elems
1029 my @all = $block->($self);
1031 $self->{'~CAPS'} = \@caps;
1032 return $self->cursor($self->{_pos})->retm();
1035 sub _NOTCHAR { my $self = shift;
1037 no warnings 'recursion';
1039 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1040 my @all = $block->($self);
1042 return $self->cursor($self->{_pos}+1)->retm();
1045 sub before { my $self = shift;
1047 no warnings 'recursion';
1049 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1050 local $::HIGHEXPECT = {}; # don't count lookahead as expectation
1051 local $::HIGHWATER = $::HIGHWATER;
1053 @caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'}; # must copy elems
1054 my @all = $block->($self);
1055 if (@all and $all[0]) {
1056 $all[0]->{'~CAPS'} = \@caps;
1057 if ($self->{_ast}) {
1058 $all[0]->{'_ast'} = $self->{_ast};
1061 delete $all[0]->{'_ast'};
1063 return $all[0]->cursor_all(($self->{_pos}) x 2)->retm();
1068 sub suppose { my $self = shift;
1070 no warnings 'recursion';
1072 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1073 local $::FATALS = 0;
1076 local $::HIGHWATER = -1;
1078 local $::HIGHEXPECT = {};
1079 local $::IN_SUPPOSE = 1;
1082 @all = $block->($self);
1084 lazymap( sub { $_[0]->retm() }, @all );
1087 sub after { my $self = shift;
1089 no warnings 'recursion';
1091 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1092 local $::HIGHEXPECT = {}; # don't count lookbehind as expectation
1093 my $end = $self->cursor($self->{_pos});
1095 @caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'}; # must copy elems
1096 my @all = $block->($end); # Make sure $_->{_from} == $_->{_pos}
1097 if (@all and $all[0]) {
1098 $all[0]->{'~CAPS'} = \@caps;
1099 if ($self->{_ast}) {
1100 $all[0]->{'_ast'} = $self->{_ast};
1103 delete $all[0]->{'_ast'};
1105 return $all[0]->cursor_all(($self->{_pos}) x 2)->retm();
1110 sub null { my $self = shift;
1111 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1112 return $self->cursor($self->{_pos})->retm();
1115 sub ws__PEEK { ''; }
1119 local $CTX = $self->callm() if DEBUG & DEBUG::trace_call;
1120 my @stub = return $self if exists $::MEMOS[$self->{_pos}]{ws};
1122 my $S = $self->{_pos};
1123 my $C = $self->cursor_xact("RULE ws $S");
1124 # my $xact = $C->xact;
1126 $::MEMOS[$S]{ws} = undef; # exists means we know, undef means no ws before here
1128 $self->_MATCHIFY($S, 'ws',
1129 $C->_BRACKET( sub { my $C=shift;
1131 push @gather, (map { my $C=$_;
1134 $C->_NOTBEFORE( sub { my $C=shift;
1137 } $C->_COMMITRULE())
1138 } $C->before(sub { my $C=shift;
1141 } $C->before( sub { my $C=shift;
1142 $C->after(sub { my $C=shift;
1147 push @gather, (map { my $C=$_;
1149 scalar(do { $::MEMOS[$C->{_pos}]{ws} = $S unless $C->{_pos} == $S }, $C)
1150 } $C->_STARr(sub { my $C=shift;
1160 sub _ASSERT { my $self = shift;
1162 no warnings 'recursion';
1164 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1165 my @all = $block->($self);
1166 if ((@all and $all[0]->{_bool})) {
1167 return $self->cursor($self->{_pos})->retm();
1172 sub _BINDVAR { my $self = shift;
1175 no warnings 'recursion';
1177 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1178 lazymap(sub { $$var = $_[0]; $_[0]->retm() },
1182 sub _SUBSUME { my $self = shift;
1185 no warnings 'recursion';
1186 no warnings 'recursion';
1188 local $CTX = $self->callm($names ? "@$names" : "") if DEBUG & DEBUG::trace_call;
1189 lazymap(sub { $self->cursor_bind($names, $_[0])->retm() },
1190 $block->($self->cursor_fresh()));
1193 sub _SUBSUMEr { my $self = shift;
1196 no warnings 'recursion';
1197 no warnings 'recursion';
1199 local $CTX = $self->callm($names ? "@$names" : "") if DEBUG & DEBUG::trace_call;
1200 my ($var) = $block->($self->cursor_fresh()) or return ();
1201 $self->cursor_bind($names, $var)->retm();
1204 sub _EXACT_rev { my $self = shift;
1205 my $s = shift() // '';
1206 my @ints = unpack("U*", $s);
1208 local $CTX = $self->callm($s) if DEBUG & DEBUG::trace_call;
1209 my $P = $self->{_pos} // 0;
1211 return () unless ($::ORIG[--$P]//-1) == pop @ints;
1213 return $self->cursor($P)->retm();
1216 sub _EXACT { my $self = shift;
1217 my $s = shift() // '';
1218 my @ints = unpack("U*", $s);
1220 local $CTX = $self->callm($s) if DEBUG & DEBUG::trace_call;
1221 my $P = $self->{_pos} // 0;
1223 return () unless ($::ORIG[$P++]//-1) == shift @ints;
1225 return $self->cursor($P)->retm();
1226 # if (substr($::ORIG, $P, $len) eq $s) {
1227 # $self->deb("EXACT $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1228 # my $r = $self->cursor($P+$len);
1232 # $self->deb("EXACT $s didn't match @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1237 sub _PATTERN { my $self = shift;
1240 local $CTX = $self->callm($qr) if DEBUG & DEBUG::trace_call;
1241 my $P = $self->{_pos} // 0;
1243 if ($::ORIG =~ /$qr/gc) {
1244 my $len = pos($::ORIG) - $P;
1245 $self->deb("PATTERN $qr matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1246 my $r = $self->cursor($P+$len);
1250 $self->deb("PATTERN $qr didn't match at $P") if DEBUG & DEBUG::matchers;
1255 sub _BACKREFn { my $self = shift;
1258 local $CTX = $self->callm($n) if DEBUG & DEBUG::trace_call;
1259 my $P = $self->{_pos} // 0;
1260 my $s = $self->{$n}->Str;
1261 my $len = length($s);
1262 if (substr($::ORIG, $P, $len) eq $s) {
1263 $self->deb("EXACT $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1264 my $r = $self->cursor($P+$len);
1268 $self->deb("EXACT $s didn't match @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1273 sub _SYM { my $self = shift;
1277 $s = $s->[0] if ref $s eq 'ARRAY';
1279 local $CTX = $self->callm($s) if DEBUG & DEBUG::trace_call;
1280 my $P = $self->{_pos} // 0;
1281 my $len = length($s);
1283 ? lc substr($::ORIG, $P, $len) eq lc $s
1284 : substr($::ORIG, $P, $len) eq $s
1286 $self->deb("SYM $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1287 my $r = $self->cursor($P+$len);
1292 $self->deb("SYM $s didn't match @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1297 #sub _EXACT_rev { my $self = shift;
1300 # local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1301 # my $len = length($s);
1302 # my $from = $self->{_pos} - $len;
1303 # if ($from >= 0 and substr($::ORIG, $from, $len) eq $s) {
1304 # my $r = $self->cursor_rev($from);
1308 ## say "EXACT_rev $s didn't match @{[substr($!orig,$from,$len)]} at $from $len";
1313 sub _ARRAY { my $self = shift;
1314 local $CTX = $self->callm(0+@_) if DEBUG & DEBUG::trace_call;
1315 my $P = $self->{_pos} // 0;
1316 my @array = sort { length($b) <=> length($a) } @_; # XXX suboptimal
1318 for my $s (@array) {
1319 my $len = length($s);
1320 if (substr($::ORIG, $P, $len) eq $s) {
1321 $self->deb("ARRAY elem $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1322 my $r = $self->cursor($P+$len);
1323 push @result, $r->retm('');
1329 sub _ARRAY_rev { my $self = shift;
1330 local $CTX = $self->callm(0+@_) if DEBUG & DEBUG::trace_call;
1331 my @array = sort { length($b) <=> length($a) } @_; # XXX suboptimal
1333 for my $s (@array) {
1334 my $len = length($s);
1335 my $from = $self->{_pos} = $len;
1336 if (substr($::ORIG, $from, $len) eq $s) {
1337 $self->deb("ARRAY_rev elem $s matched @{[substr($::ORIG,$from,$len)]} at $from $len") if DEBUG & DEBUG::matchers;
1338 my $r = $self->cursor_rev($from);
1339 push @result, $r->retm('');
1345 sub _DIGIT { my $self = shift;
1346 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1347 my $P = $self->{_pos};
1348 my $char = substr($::ORIG, $P, 1);
1349 if ($char =~ /^\d$/) {
1350 my $r = $self->cursor($P+1);
1354 # say "DIGIT didn't match $char at $P";
1359 sub _DIGIT_rev { my $self = shift;
1360 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1361 my $from = $self->{_pos} - 1;
1363 # say "DIGIT_rev didn't match $char at $from";
1366 my $char = substr($::ORIG, $from, 1);
1367 if ($char =~ /^\d$/) {
1368 my $r = $self->cursor_rev($from);
1372 # say "DIGIT_rev didn't match $char at $from";
1377 sub ww { my $self = shift;
1378 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1379 my $P = $self->{_pos};
1380 return () unless $P;
1381 my $chars = substr($::ORIG, $P-1, 2);
1382 if ($chars =~ /^\w\w$/) {
1383 my $r = $self->cursor($P);
1387 # say "ww didn't match $chars at $P";
1392 sub _ALNUM { my $self = shift;
1393 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1394 my $P = $self->{_pos};
1395 my $char = substr($::ORIG, $P, 1);
1396 if ($char =~ /^\w$/) {
1397 my $r = $self->cursor($P+1);
1401 # say "ALNUM didn't match $char at $P";
1406 sub _ALNUM_rev { my $self = shift;
1407 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1408 my $from = $self->{_pos} - 1;
1410 # say "ALNUM_rev didn't match $char at $from";
1413 my $char = substr($::ORIG, $from, 1);
1414 if ($char =~ /^\w$/) {
1415 my $r = $self->cursor_rev($from);
1419 # say "ALNUM_rev didn't match $char at $from";
1427 for my $ch (0..255) {
1428 my $char = chr($ch);
1429 vec($alpha,$ch,1) = 1 if $char =~ /\w/ and $char !~ /\d/;
1432 sub alpha { my $self = shift;
1433 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1434 my $P = $self->{_pos};
1435 # my $char = substr($::ORIG, $P, 1);
1436 my $ch = $::ORIG[$P];
1437 if (vec($alpha,$ch,1) or ($ch > 255 and chr($ch) =~ /\pL/)) {
1438 # if ($char =~ /^[_[:alpha:]\pL]$/) {
1439 my $r = $self->cursor($P+1);
1443 # say "alpha didn't match $char at $P";
1448 sub alpha_rev { my $self = shift;
1449 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1450 my $from = $self->{_pos} - 1;
1454 my $char = substr($::ORIG, $from, 1);
1455 if ($char =~ /^[_[:alpha:]\pL]$/) {
1456 my $r = $self->cursor_rev($from);
1464 sub _SPACE { my $self = shift;
1465 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1466 my $P = $self->{_pos};
1467 my $char = substr($::ORIG, $P, 1);
1468 if ($char =~ /^\s$/) {
1469 my $r = $self->cursor($P+1);
1473 # say "SPACE didn't match $char at $P";
1478 sub _SPACE_rev { my $self = shift;
1479 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1480 my $from = $self->{_pos} - 1;
1482 # say "SPACE_rev didn't match $char at $from";
1485 my $char = substr($::ORIG, $from, 1);
1486 if ($char =~ /^\s$/) {
1487 my $r = $self->cursor_rev($from);
1491 # say "SPACE_rev didn't match $char at $from";
1496 sub _HSPACE { my $self = shift;
1497 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1498 my $P = $self->{_pos};
1499 my $char = substr($::ORIG, $P, 1);
1500 if ($char =~ /^[ \t\r]$/ or ($char =~ /^\s$/ and $char !~ /^[\n\f\0x0b\x{2028}\x{2029}]$/)) {
1501 my $r = $self->cursor($P+1);
1505 # say "HSPACE didn't match $char at $P";
1510 sub _HSPACE_rev { my $self = shift;
1511 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1512 my $from = $self->{_pos} - 1;
1514 # say "HSPACE_rev didn't match $char at $from";
1517 my $char = substr($::ORIG, $from, 1);
1518 if ($char =~ /^[ \t\r]$/ or ($char =~ /^\s$/ and $char !~ /^[\n\f\0x0b\x{2028}\x{2029}]$/)) {
1519 my $r = $self->cursor_rev($from);
1523 # say "HSPACE_rev didn't match $char at $from";
1528 sub _VSPACE { my $self = shift;
1529 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1530 my $P = $self->{_pos};
1531 my $char = substr($::ORIG, $P, 1);
1532 if ($char =~ /^[\n\f\x0b\x{2028}\x{2029}]$/) {
1533 my $r = $self->cursor($P+1);
1537 # say "VSPACE didn't match $char at $P";
1542 sub _VSPACE_rev { my $self = shift;
1543 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1544 my $from = $self->{_pos} - 1;
1546 # say "VSPACE_rev didn't match $char at $from";
1549 my $char = substr($::ORIG, $from, 1);
1550 if ($char =~ /^[\n\f\x0b\x{2028}\x{2029}]$/) {
1551 my $r = $self->cursor_rev($from);
1555 # say "VSPACE_rev didn't match $char at $from";
1560 sub _CCLASS { my $self = shift;
1563 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1564 my $P = $self->{_pos};
1565 my $char = substr($::ORIG, $P, 1);
1566 if ($char =~ /$cc/) {
1567 my $r = $self->cursor($P+1);
1571 # say "CCLASS didn't match $char at $P";
1576 sub _CCLASS_rev { my $self = shift;
1579 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1580 my $from = $self->{_pos} - 1;
1582 # say "CCLASS didn't match $char at $from";
1585 my $char = substr($::ORIG, $from, 1);
1586 if ($char =~ /$cc/) {
1587 my $r = $self->cursor_rev($from);
1591 # say "CCLASS didn't match $char at $from";
1596 sub _ANY { my $self = shift;
1597 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1598 my $P = $self->{_pos};
1600 $self->cursor($P+1)->retm();
1603 # say "ANY didn't match anything at $P";
1608 sub _ANY_rev { my $self = shift;
1609 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1610 my $from = $self->{_pos} - 1;
1614 return $self->cursor_rev($from)->retm();
1617 sub _BOS { my $self = shift;
1618 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1619 my $P = $self->{_pos};
1621 $self->cursor($P)->retm();
1627 sub _BOS_rev { $_[0]->_BOS }
1629 sub _BOL { my $self = shift;
1630 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1631 my $P = $self->{_pos};
1632 if ($P == 0 or substr($::ORIG, $P-1, 1) =~ /^[\n\f\x0b\x{2028}\x{2029}]$/) {
1633 $self->cursor($P)->retm();
1639 sub _BOL_rev { $_[0]->_BOL }
1641 sub _EOS { my $self = shift;
1642 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1643 my $P = $self->{_pos};
1644 if ($P == @::ORIG) {
1645 $self->cursor($P)->retm();
1651 sub _EOS_rev { $_[0]->_EOS }
1653 sub _EOL { my $self = shift;
1654 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1655 my $P = $self->{_pos};
1656 if ($P == @::ORIG or substr($::ORIG, $P, 1) =~ /^(?:\r\n|[\n\f\x0b\x{2028}\x{2029}])$/) {
1657 $self->cursor($P)->retm();
1663 sub _EOL_rev { $_[0]->_EOL }
1665 sub _RIGHTWB { my $self = shift;
1666 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1667 my $P = $self->{_pos};
1668 pos($::ORIG) = $P - 1;
1669 if ($::ORIG =~ /\w\b/) {
1670 $self->cursor($P)->retm();
1676 sub _RIGHTWB_rev { $_[0]->_RIGHTWB }
1678 sub _LEFTWB { my $self = shift;
1679 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1680 my $P = $self->{_pos};
1682 if ($::ORIG =~ /\b(?=\w)/) {
1683 $self->cursor($P)->retm();
1689 sub _LEFTWB_rev { $_[0]->_LEFTWB }
1691 sub _LEFTRESULT { my $self = shift;
1692 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1693 my $P = $self->{_pos};
1695 if ($::ORIG =~ /\b(?=\w)/) {
1696 $self->cursor($P)->retm();
1702 sub _LEFTRESULT_rev { $_[0]->_LEFTWB }
1704 sub _REDUCE { my $self = shift;
1708 $key .= ' ' . $_[0] if @_;
1710 $self->{_reduced} = $key;
1711 $self->{_from} = $S;
1713 eval { $::ACTIONS->$meth($self, @_) };
1714 warn $@ if $@ and not $@ =~ /locate/;
1716 $self->deb("REDUCE $key from " . $S . " to " . $self->{_pos}) if DEBUG & DEBUG::matchers;
1720 sub _COMMITBRANCH { my $self = shift;
1721 my $xact = $self->xact;
1722 # $self->{LAST} = shift() if @_;
1723 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1724 my $P = $self->{_pos};
1727 $self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
1728 return $self->cursor_xact("CB") if $xact->[0] =~ /^ALT/;
1729 $xact = $xact->[-1];
1731 die "Not in an alternation, so can't commit to a branch";
1734 sub _COMMITLTM { my $self = shift;
1735 my $xact = $self->xact;
1736 # $self->{LAST} = shift() if @_;
1737 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1738 my $P = $self->{_pos};
1741 $self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
1742 return $self->cursor_xact("CL") if $xact->[0] =~ /^ALTLTM/;
1743 $xact = $xact->[-1];
1745 die "Not in a longest token matcher, so can't commit to a longest token";
1748 sub _COMMITRULE { my $self = shift;
1749 my $xact = $self->xact;
1750 # $self->{LAST} = shift() if @_;
1751 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1752 my $P = $self->{_pos};
1755 $self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
1756 return $self->cursor_xact("CR") if $xact->[0] =~ /^RULE/;
1757 $xact = $xact->[-1];
1759 die "Not in a rule, so can't commit to rule";
1762 sub commit { my $self = shift;
1763 my $xact = $self->xact;
1764 # $self->{LAST} = shift() if @_;
1765 local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1766 my $P = $self->{_pos};
1769 $self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
1770 return $self->cursor_xact("CM") if $xact->[0] =~ /^MATCH/;
1771 $xact = $xact->[-1];
1773 die "Not in a match, so can't commit to match";
1776 sub fail { my $self = shift;
1781 sub bless { CORE::bless $_[1], $_[0]->WHAT }
1783 #############################################################
1784 # JIT lexer generator
1785 #############################################################
1788 ## array of (NFA node) ->
1789 ## 0: non extensible (imperative) flag
1790 ## 0: array of fate (array of fate element)
1791 ## array of (label) at odd index, new index at even
1793 ## each DFA node is array:
1794 ## 0: array of object fates
1795 ## 1: hash of specific cases (char => DFAnode)
1796 ## also carries some debug data
1797 ## 2n: reference to a uniprop hash
1798 ## 2n+1: DFAnode is that hash existed
1799 ## Labels: undef is epsilon link.
1800 ## otherwise list - 1 positive, 0+ negative
1801 ## each is: 1 character, else unicode prop in "Gc/L" form
1802 ## "DFA" lexer structure:
1803 ## {DFA} -> array of refs to all DFA nodes
1804 ## {DBA}, {FILE}, {NAME} same as "RE" lexer structure
1805 ## {S} -> ref to DFA root
1806 ## {NFA} -> NFA structure
1807 ## individual fates in the NFA end with a hook which can be 1 to stop adding
1808 ## fates on the end; it's not always possible to associate a unique fate with
1809 ## each NFA node, consider (a|b)*
1810 ## A NFA or DFA node is accepting if it has a nonempty list of fates
1814 package CursorBase::dfa;
1817 for (@$self) { @$_ = (); }
1821 # Steal data from Perl5's Unicode maps
1822 my %unicode_map_cache;
1823 $unicode_map_cache{ALL} = [scalar("\377" x 128) x 1088, "ALL"] ;
1824 sub _get_unicode_map {
1825 my $propname = shift;
1826 $unicode_map_cache{$propname} //= do {
1827 my @top = (("") x 1088, $propname);
1828 for my $l (split("\n", (do "unicore/lib/$propname.pl"))) {
1829 my ($from, $to) = split("\t", $l);
1831 $to = hex $to || $from;
1833 for (my $x = $from; $x <= $to; $x++) {
1834 vec($top[$x >> 10], $x & 1023, 1) = 1;
1841 # This is the fast path handling for JIT DFA lexer generation (although it gets
1842 # short-circuited if the DFALEXERS entry exists, later). The lexer generation
1843 # process sometimes recurses to this, which is tracked using %::AUTOLEXED; if
1844 # the value is already set, we need to suppress recursion.
1848 sub _dump_nfa { my ($name, $nfa) = @_;
1849 print ::LOG "--- BEGIN NFA DUMP ($name) ---\n";
1850 for my $ix (0 .. @$nfa-1) {
1852 for (my $j = 2; $j < @{ $nfa->[$ix] }; $j += 2) {
1853 push @go, "[" . join("-",@{$nfa->[$ix][$j] // []}) . "] => " . $nfa->[$ix][$j+1];
1855 my $h = sprintf "%4d: %-30s %s ", $ix, join(", ", @go),
1856 ($nfa->[$ix][0]{I} ? 'I' : ' ');
1857 my @fate = map { my @x = @$_;
1859 push @x, "..." if $y;
1860 join(" ", "-->", @x) } @{ $nfa->[$ix][1] };
1861 @fate = ('') if !@fate;
1863 print ::LOG $h . $_ . "\n";
1864 $h = ' ' x length($h);
1867 print ::LOG "---- END NFA DUMP ----\n";
1870 sub _dtree_dump { my ($ord, $dt) = @_;
1871 print ::LOG (" " x (2 + $ord));
1873 print ::LOG "END\n";
1874 } elsif (ref $dt ne 'ARRAY') {
1875 print ::LOG ($$dt)->[1]{ID}, "\n";
1877 print ::LOG $dt->[2][-1], "?\n";
1878 _dtree_dump($ord+1, $dt->[1]);
1879 _dtree_dump($ord+1, $dt->[0]);
1883 sub _dfa_dump_node { my ($dfan) = @_;
1885 my @gor = %{ $dfan->[1] };
1886 while (my ($a, $b) = splice @gor, 0, 2) {
1887 next if $a eq 'DESC';
1889 push @go, "'" . ::qm(chr $a) . "' => " . $b->[1]{ID};
1891 printf ::LOG "%-30s %-30s\n", $dfan->[1]{DESC} . ":", join(", ", @go);
1892 _dtree_dump(0, $dfan->[2]);
1893 for (@{ $dfan->[0] }) {
1895 for (my $fate = $_; $fate; $fate = $fate->[0]) {
1896 push @arr, $fate->[1], $fate->[2];
1898 print ::LOG " --> ", join(" ", @arr), "\n";
1902 sub _elem_matches { my ($char, $element) = @_;
1903 if (length($element) == 1) {
1904 return $char eq $element;
1907 return vec(_get_unicode_map($element)->[$i >> 10], $i & 1023, 1);
1911 my %boolean_tables = map { $_, 1 } qw/AHex Alpha BidiC BidiM CE CI CWCF CWCM
1912 CWKCF CWL CWT CWU Cased CompEx DI Dash Dep Dia Ext GrBase GrExt Hex Hyphen
1913 IDC IDS IDSB IDST Ideo JoinC Lower Math NChar NFDQC OAlpha ODI OGrExt OIDC
1914 OIDS OLower OMath OUpper PatSyn PatWS QMark Radical SD STerm Space Term
1915 UIdeo Upper VS XIDC XIDS/;
1916 sub _elem_excludes { my ($up1, $up2) = @_;
1917 my ($t1, $v1) = split "/", $up1;
1918 my ($t2, $v2) = split "/", $up2;
1920 return 0 if $t1 ne $t2;
1921 return 0 if $v1 eq $v2;
1923 return 1 if $boolean_tables{$t1};
1924 return 1 if $t1 eq 'Gc' && (length($v1) == length($v2)
1925 || substr($v1, 0, 1) ne substr($v2, 0, 1));
1930 sub _elem_implies { my ($up1, $up2) = @_;
1931 my ($t1, $v1) = split "/", $up1;
1932 my ($t2, $v2) = split "/", $up2;
1934 return 0 if $t1 ne $t2;
1935 return 1 if $v1 eq $v2;
1937 return 1 if $t1 eq 'Gc' && substr($v1, 0, 1) eq $v2;
1942 sub _elem_dich { my ($up1, $up2) = @_;
1943 my ($t1, $v1) = split "/", $up1;
1944 my ($t2, $v2) = split "/", $up2;
1946 return 0 if $t1 ne $t2;
1947 return 0 if $v1 eq $v2;
1949 return 1 if $boolean_tables{$t1};
1953 sub _decision_tree { my ($thunk, @edges) = @_;
1956 TERM: for (my $i = 0; $i < @edges; $i += 2) {
1957 for my $c (@{ $edges[$i] }) {
1958 next if $c eq 'ALL';
1964 if (defined $branch) {
1968 for (my $i = 0; $i < @edges; $i += 2) {
1969 my ($p, @n) = @{ $edges[$i] };
1971 if (!_elem_excludes($branch, $p) &&
1972 !(grep { _elem_implies($branch, $_) } @n)) {
1973 my $pp = _elem_implies($branch, $p) ? 'ALL' : $p;
1974 my @nn = grep { !_elem_excludes($branch, $_) } @n;
1975 push @true, [ $pp, @nn ], $edges[$i+1];
1978 if (!_elem_implies($p, $branch) &&
1979 !(grep { _elem_dich($branch, $_) } @n)) {
1980 my $pp = _elem_dich($branch, $p) ? 'ALL' : $p;
1981 my @nn = grep { !_elem_implies($_, $branch) } @n;
1982 push @false, [ $pp, @nn ], $edges[$i+1];
1986 return [ _decision_tree($thunk, @false),
1987 _decision_tree($thunk, @true),
1988 _get_unicode_map($branch) ];
1990 # all edges are labelled [ALL]
1992 for (my $i = 1; $i < @edges; $i += 2) {
1993 vec($bm, $edges[$i], 1) = 1;
1995 return ($bm ne '') ? (\ $thunk->($bm)) : undef;
1999 sub _tangle_edges { my ($our_edges, $thunk) = @_;
2003 for (my $i = 0; $i < @$our_edges; $i += 2) {
2004 next unless $our_edges->[$i];
2005 for (@{ $our_edges->[$i] }) {
2006 if (length($_) == 1) {
2007 $used_chars{$_} = 1;
2014 # First, all specifically mentioned characters are floated to the initial
2017 for my $ch (keys %used_chars) {
2019 EDGE: for (my $i = 0; $i < @$our_edges; $i += 2) {
2020 next unless $our_edges->[$i];
2021 next unless _elem_matches($ch, $our_edges->[$i][0]);
2022 for (my $j = 1; $j < @{ $our_edges->[$i] }; $j++) {
2023 next EDGE if _elem_matches($ch, $our_edges->[$i][$j]);
2025 vec($bm, $our_edges->[$i+1], 1) = 1;
2027 $next_1{ord $ch} = $thunk->($bm);
2030 # Now clean them out so the decision tree engine doesn't have to deal with
2032 $our_edges = [ @$our_edges ];
2033 for (my $i = 0; $i < @$our_edges; ) {
2034 if (!$our_edges->[$i] || length($our_edges->[$i][0]) == 1) {
2035 splice @$our_edges, $i, 2;
2037 $our_edges->[$i] = [grep { length($_) > 1 } @{ $our_edges->[$i] }];
2042 \%next_1, _decision_tree($thunk, @$our_edges);
2045 sub _jit_dfa_node { my ($lexer, $node) = @_;
2046 my $nfa2dfa = sub { my $nbm = shift;
2047 $lexer->{NFA2DFA}->{$nbm} //= do {
2049 $node[1] = { ID => scalar(@{ $lexer->{DFA} }), BITS => $nbm };
2050 push @{ $lexer->{DFA} }, \@node;
2055 my $bf = $node->[1]{BITS};
2056 my $id = $node->[1]{ID};
2057 my $nfa = $lexer->{NFA};
2060 my @nfixes = grep { vec($bf, $_, 1) } (0 .. length($bf)*8 - 1);
2065 my $nix = pop @grey;
2066 next if $black{$nix};
2068 my $nfn = $nfa->[$nix];
2070 push @{ $node->[0] }, @{ $nfn->[1] };
2071 for (my $i = 2; $i < @$nfn; $i += 2) {
2073 push @grey, $nfn->[$i+1];
2075 push @ouredges, $nfn->[$i], $nfn->[$i+1];
2080 for my $fate (@{ $node->[0] }) {
2081 my @a = reverse @$fate;
2084 for (my $i = 1; $i < @a; $i += 3) {
2086 $fo = [ $fo, $a[$i+2], $a[$i+1] ];
2091 @{ $node->[0] } = map { $_->[1] } sort { $b->[0] cmp $a->[0] } @{ $node->[0] };
2094 push @$node, _tangle_edges(\@ouredges, $nfa2dfa);
2095 $node->[1]{DESC} = $id . "{" . join(",", @nfixes) . "}";
2096 $node->[1]{ID} = $id;
2098 if (DEBUG & DEBUG::autolexer) {
2099 print ::LOG "JIT DFA node generation:\n";
2100 _dfa_dump_node($node);
2106 sub _scan_regexes { my ($class, $key) = @_;
2108 (${ $class . "::REGEXES" } //= do {
2109 my $stash = \ %{ $class . "::" };
2113 for my $m (keys %$stash) {
2114 next if ref $stash->{$m}; # use constant
2115 next if !defined *{$stash->{$m}}{CODE};
2116 my ($meth, $p) = $m =~ /^(.*?)(__S_\d\d\d.*)?__PEEK$/ or next;
2117 #$self->deb("\tfound override for $meth in $m") if DEBUG & DEBUG::autolexer;
2119 push @{$proto{$meth}}, $m if $p;
2123 @{$proto{$_}} = sort @{$proto{$_}};
2126 $proto{ALL} = [ keys %over ];
2131 sub _AUTOLEXgenDFA { my ($self, $realkey, $key, $retree) = @_;
2132 local $::AUTOLEXED{$realkey} = $fakepos;
2133 local %::usedmethods;
2135 my $lang = ref $self;
2137 $self->deb("AUTOLEXgen $key in $lang") if DEBUG & DEBUG::autolexer;
2138 my $ast = $retree->{$key};
2141 # Whenever possible, we want to share a lexer amongst as many grammars
2142 # as we can. So we try to float lexers up to superclasses.
2145 my $isa = \@{ $lang . "::ISA" };
2147 # We don't support multiple inheritance (can we?)
2149 $self->deb("\tcannot reuse $key; multiply inherited") if DEBUG & DEBUG::autolexer;
2153 my $super = $isa->[0];
2155 my $dic = $ast->{dic} //= do {
2156 my $i = 1; # skip _AUTOLEXpeek;
2157 my $pkg = 'CursorBase';
2158 $pkg = caller($i++) while $pkg eq 'CursorBase';
2159 #print STDERR "dic run: $pkg\n";
2160 $self->deb("\tdeclared in class $pkg") if DEBUG & DEBUG::autolexer;
2164 my $ar = ${ $lang . "::ALLROLES" } //= do {
2165 +{ map { $_->name, 1 } ($lang->meta, $lang->meta->calculate_all_roles) }
2168 # It doesn't make sense to float a lexer above Cursor, or (for 'has'
2169 # regexes), the class of definition.
2171 $self->deb("\tcannot reuse $key; at top") if DEBUG & DEBUG::autolexer;
2175 my $supercursor = $self->cursor_fresh($super);
2176 my $superlexer = eval {
2178 $supercursor->_AUTOLEXpeek($key, $retree)
2182 $self->deb("\tcannot reuse $key; failed ($@)") if DEBUG & DEBUG::autolexer;
2186 my $ml = _scan_regexes($lang, 'ALL');
2188 for my $meth (@$ml) {
2189 if ($superlexer->{USED_METHODS}{$meth}) {
2190 $self->deb("\tcannot reuse $key; $meth overriden/augmented")
2191 if DEBUG & DEBUG::autolexer;
2196 $self->deb("\treusing ($key, $realkey, $lang, $super).") if DEBUG & DEBUG::autolexer;
2200 my $dba = $ast->{dba};
2202 my $d = DEBUG & DEBUG::autolexer;
2203 print ::LOG "generating DFA lexer for $key -->\n" if $d;
2206 if ($key =~ /(.*):\*$/) {
2208 # any change to the method needs to invalidate us
2209 $::usedmethods{$proto} = 1;
2211 my $protopat = $1 . '__S_';
2212 my $protolen = length($protopat);
2219 my $class = pop @stack;
2220 push @stack, reverse @{ $class . "::ISA" };
2221 my @methods = @{ _scan_regexes($class, $proto) // [] };
2222 for my $method (@methods) {
2223 my $callname = $class . '::' . $method;
2224 $method = substr($method, 0, length($method)-6);
2225 my $peeklex = $self->$callname();
2226 die "$proto has no lexer!?" unless $peeklex->{NFA};
2228 push @pat, ::nfaltmprefate($proto, "${class}::$method",
2229 $j++, $peeklex->{NFA});
2233 $nfa = ::nfadisj(@pat);
2235 $nfa = $ast->nfa($self);
2240 die "dba unspecified" unless $dba;
2242 _dump_nfa($key, $nfa) if $d;
2243 print ::LOG "used methods: ", join(" ", sort keys %::usedmethods), "\n" if $d;
2245 my $dfa = CORE::bless [], 'CursorBase::dfa';
2246 push @$dfa, [ undef, { BITS => "\001", ID => 0 } ];
2248 { DBA => $dba, DFA => $dfa, NFA2DFA => { "\001" => $dfa->[0] },
2249 NFA => $nfa, S => $dfa->[0], USED_METHODS => \%::usedmethods };
2252 sub _AUTOLEXpeek { my $self = shift;
2256 # protoregexes are identified by name
2257 my $realkey = refaddr($retree->{$key}) // $key;
2259 $self->deb("AUTOLEXpeek $key") if DEBUG & DEBUG::autolexer;
2260 die "Null key" if $key eq '';
2261 if ($::AUTOLEXED{$realkey}) { # no left recursion allowed in lexer!
2262 die "Left recursion in $key" if $fakepos == $::AUTOLEXED{$realkey};
2263 $self->deb("Suppressing lexer recursion on $key") if DEBUG & DEBUG::autolexer;
2264 return { USED_METHODS => {}, NFA => [[{I=>1}, [[1]]]] }; # (but if we advanced just assume a :: here)
2266 $key = 'termish' if $key eq 'EXPR';
2267 return $::LEXERS{ref $self}->{$realkey} //= do {
2268 $self->_AUTOLEXgenDFA($realkey, $key, $retree);
2272 #############################################################
2273 # Parser service routines
2274 #############################################################
2279 @$self{keys %args} = values %args;
2285 my $O = $self->{O} or return ();
2287 for (my ($k,$v) = each %$O) {
2295 my $traitname = shift;
2299 $text = $param->[0]->Str;
2300 $text =~ s/^<(.*)>$/$1/ or
2301 $text =~ s/^\((.*)\)$/$1/;
2303 if ($traitname eq 'export') {
2304 if (defined $text) {
2310 $self->set_export($text);
2313 elsif (defined $text) {
2324 my $textpkg = $text . '::';
2325 my $name = $::DECLARAND->{name};
2326 my $xpad = $STD::ALL->{ (delete $::DECLARAND->{xpad})->[0] };
2327 $::DECLARAND->{export} = $text;
2328 my $sid = $::CURPAD->idref;
2329 my $x = $xpad->{'EXPORT::'} //= Stash::->new( 'PARENT::' => $sid, '!id' => [$sid->[0] . '::EXPORT'] );
2330 $x->{$textpkg} //= Stash::->new( 'PARENT::' => $x->idref, '!id' => [$sid->[0] . '::EXPORT::' . $text] );
2331 $x->{$textpkg}->{$name} = $::DECLARAND;
2332 $x->{$textpkg}->{'&'.$name} = $::DECLARAND
2333 if $name =~ /^\w/ and $::IN_DECL ne 'constant';
2339 my $WHAT = ref($self)||$self;
2342 my $NEWWHAT = $WHAT . '::';
2344 for my $mixin (@mixins) {
2345 my $ext = ref($mixin) || $mixin;
2347 $ext =~ s/(\w)\w*::/$1/g; # just looking for a "cache" key, really
2348 $NEWWHAT .= '_X_' . $ext;
2350 $self->deb("mixin $NEWWHAT from $WHAT @newmix") if DEBUG & DEBUG::mixins;
2352 if (not exists &{$NEWWHAT.'::meta'}) { # never composed this one yet?
2353 # fake up mixin with MI, being sure to put "roles" in front
2354 my $eval = "package $NEWWHAT; use Moose ':all' => { -prefix => 'moose_' }; moose_extends('$WHAT'); moose_with(" . join(',', map {"'$_'"} @newmix) . ");our \$CATEGORY = '.';\n";
2355 $self->deb($eval) if DEBUG & DEBUG::mixins;
2359 return $self->cursor_fresh($NEWWHAT);
2364 my $class = ref $self;
2368 $self->deb("Calling $class" . '::multitweak') if DEBUG & DEBUG::mixins;
2369 &{$class . '::multitweak'}($self,@_);
2371 return $retval if $retval;
2372 die $@ unless $@ =~ /^NOMATCH|^Undefined subroutine/;
2373 last unless $class =~ s/(.*)::.*/$1/;
2377 sub clean_id { my $self = shift;
2378 my ($id,$name) = @_;
2379 my $file = $::FILE->{name};
2382 $id =~ s/^MY:file<CORE.setting>.*?::/CORE::/;
2383 $id =~ s/^MY:file<\w+.setting>.*?::/SETTING::/;
2384 $id =~ s/^MY:file<\Q$file\E>$/UNIT/;
2385 $id =~ s/:pos\(\d+\)//;
2390 # remove consistent leading whitespace (mutates text nibbles in place)
2392 sub trim_heredoc { my $doc = shift;
2393 my ($stopper) = $doc->stopper or
2394 $doc->panic("Couldn't find delimiter for heredoc\n");
2395 my $ws = $stopper->{ws}->Str;
2396 return $stopper if $ws eq '';
2399 $wsequiv =~ s{^(\t+)}[' ' x (length($1) * ($::TABSTOP // 8))]xe;
2401 # We can't use ^^ after escapes, since the escape may be mid-line
2402 # and we'd get false positives. Use a fake newline instead.
2403 $doc->{nibbles}[0] =~ s/^/\n/;
2405 for (@{$doc->{nibbles}}) {
2406 next if ref $_; # next unless $_ =~ Str;
2408 # prefer exact match over any ws
2409 s{(?<=\n)(\Q$ws\E|[ \t]+)}{
2411 if ($white eq $ws) {
2415 $white =~ s[^ (\t+) ][ ' ' x (length($1) * ($::TABSTOP // 8)) ]xe;
2416 if ($white =~ s/^\Q$wsequiv\E//) {
2425 $doc->{nibbles}[0] =~ s/^\n//; # undo fake newline
2429 sub add_categorical { my $lang = shift;
2432 $name =~ s/:<<(.*)>>$/:«$1»/;
2433 my $WHAT = ref $lang;
2435 # :() is a signature modifier, not an operator
2436 if ($name =~ /^\w+:\(/) {
2437 # XXX canonicalize sig here eventually
2438 $lang->add_my_name($name);
2442 if ($name =~ s/^(\w+):(?=[«<{[])/$1:sym/) {
2444 my ($sym) = $name =~ /:sym(.*)/;
2445 $sym =~ s/^<\s*(.*\S)\s*>$/<$1>/g;
2446 $sym =~ s/^\[\s*(.*\S)\s*\]$/$1/g;
2447 if ( $sym =~ s/\\x\[(.*)\]/\\x{$1}/g) {
2448 $sym = '«' . eval($sym) . '»';
2450 elsif ($sym =~ s/\\c\[(.*)\]/\\N{$1}/g ) {
2451 $sym = '«' . eval("use charnames ':full'; $sym") . '»';
2454 # unfortunately p5 doesn't understand q«...»
2455 if ($sym =~ s/^«\s*(.*\S)\s*»$/$1/) {
2457 for my $try (qw( ' / ! : ; | + - = )) {
2458 $ok = $try, last if index($sym,$try) < 0;
2460 $sym = $ok . $sym . $ok;
2463 my $canon = substr($sym,1,length($sym)-2);
2464 $canon =~ s/([<>])/\\$1/g;
2465 my $canonname = $cat . ':<' . $canon . '>';
2466 $lang->add_my_name($canonname);
2469 $sym = '[qw' . $sym . ']';
2475 my $rule = "token $name { <sym> }";
2477 # produce p5 method name
2479 $mangle =~ s/^(\w*):(sym)?//;
2482 if ($mangle =~ s/^<(.*)>$/$1/ or
2483 $mangle =~ s/^«(.*)»$/$1/) {
2484 $mangle =~ s/\\(.)/$1/g;
2485 @list = $mangle =~ /(\S+)/g;
2487 elsif ($mangle =~ s/^\[(.*)\]$/$1/ or
2488 $mangle =~ s/^\{(.*)\}$/$1/) {
2489 $mangle =~ s/\\x\[(.*)\]/\\x{$1}/g;
2490 @list = eval $mangle;
2492 elsif ($mangle =~ m/^\(\"(.*)\"\)$/) {
2498 $mangle = ::mangle(@list);
2499 $mangle = $category . '__S_' . sprintf("%03d",$GEN++) . $mangle;
2501 # XXX assuming no equiv specified, but to do that right,
2502 # this should be delayed till the block start is seen
2504 if ($name =~ /^infix:/) {
2505 $coercion = 'additive';
2507 elsif ($name =~ /^prefix:/) {
2508 if ($sym =~ /^.\W/) {
2509 $coercion = 'symbolic_unary';
2512 $coercion = 'named_unary';
2515 elsif ($name =~ /^postfix:/) {
2516 $coercion = 'methodcall';
2518 elsif ($name =~ /^circumfix:/) {
2521 elsif ($name =~ /^postcircumfix:/) {
2522 $coercion = 'methodcall';
2524 elsif ($name =~ /^term:/) {
2528 state $genpkg = 'ANON000';
2534 use Moose ':all' => { -prefix => 'moose_' };
2535 moose_extends('$WHAT');
2540 '$mangle' => bless({
2541 'dba' => '$category expression',
2555 our \$CATEGORY = '$category';
2557 sub ${mangle}__PEEK { \$_[0]->_AUTOLEXpeek('$mangle',\$retree) }
2560 local \$CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
2562 my \$sym = \$args{sym} // $sym;
2564 my \$xact = ['RULE $mangle', 0, \$::XACT];
2565 local \$::XACT = \$xact;
2567 my \$S = \$self->{_pos};
2568 my \$C = \$self->cursor_xact("RULE $mangle \$S");
2569 # my \$xact = \$C->xact;
2571 \$C->{'sym'} = \$sym;
2573 \$self->_MATCHIFY(\$S, '$mangle',
2575 if (my (\$C) = (\$C->_SYM(\$sym, 0))) {
2576 \$C->_SUBSUMEr(['O'], sub {
2578 \$C->O(%STD::$coercion)
2599 my $starter = $list[0];
2600 my $stopper = $list[1];
2604 use Moose ':all' => { -prefix => 'moose_' };
2605 moose_extends('$WHAT');
2610 '$mangle' => bless({
2617 'dba' => '$category expression',
2625 'dba' => '$category expression',
2634 'dba' => '$category expression',
2643 'dba' => '$category expression',
2646 'name' => 'semilist',
2656 'dba' => '$category expression',
2664 'dba' => '$category expression',
2673 'name' => 'FAILGOAL',
2682 'rest' => '(|%term)',
2689 our \$CATEGORY = '$category';
2691 sub ${mangle}__PEEK { \$_[0]->_AUTOLEXpeek('$mangle',\$retree) }
2693 no warnings 'recursion';
2695 local \$::CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
2697 local \$::sym = \$args{sym} // $sym;
2698 return () if \$::GOAL eq $starter;
2700 my \$C = \$self->cursor_xact("RULE $mangle");
2701 my \$xact = \$C->xact;
2702 my \$S = \$C->{'_pos'};
2703 \$C->{'sym'} = ref \$sym ? join(' ', \@\$sym) : \$sym;
2705 \$self->_MATCHIFYr(\$S, "$mangle",
2707 if (my (\$C) = (\$C->_EXACT($starter))) {
2709 if (my (\$C) = (((local \$::GOAL = $stopper , my \$goalpos = \$C), \$C)[-1])) {
2711 if (my (\$C) = (\$C->_SUBSUMEr(['semilist'], sub {
2716 if (my (\$C) = (\$C->_BRACKETr(sub {
2719 my \$C = \$C->cursor_xact('ALT ||');
2720 my \$xact = \$C->xact;
2723 push \@gather, \$C->_EXACT($stopper)
2727 push \@gather, \$C->FAILGOAL($stopper , '$category expression',\$goalpos)};
2731 \$C->_SUBSUMEr(['O'], sub {
2733 \$C->O(%STD::$coercion)
2761 $lang->deb("derive $genpkg from $WHAT adding $mangle") if DEBUG & DEBUG::mixins;
2762 eval $e or die "Can't create $name: $@\n";
2763 $::LANG{'MAIN'} = $lang->cursor_fresh($genpkg);
2764 my $oldlexer = $::LEXERS{$WHAT};
2765 my $newlexer = $::LEXERS{$genpkg} //= {};
2766 print ::LOG "=====================================\nADD $rule => $mangle\n" if DEBUG & DEBUG::mixins;;
2767 for my $name (sort keys %{$oldlexer}) {
2768 print ::LOG " $name:\n" if DEBUG & DEBUG::mixins;
2770 for my $pat (@{$oldlexer->{$name}->{PATS}}) {
2771 if ($pat =~ / $category /) {
2772 print ::LOG "\t$pat\n" if DEBUG & DEBUG::mixins;
2777 # no need to regen a sublexer that will turn out the same
2778 $newlexer->{$name} = $oldlexer->{$name} if $same;
2784 sub add_enum { my $self = shift;
2787 return unless $type;
2788 return unless $expr;
2789 my $typename = $type->Str;
2790 local $::IN_DECL = 'constant';
2791 # XXX complete kludge, really need to eval EXPR
2792 $expr =~ s/:(\w+)<\S+>/$1/g; # handle :name<string>
2793 for ($expr =~ m/([a-zA-Z_]\w*)/g) {
2794 $self->add_name($typename . "::$_");
2795 $self->add_name($_);
2800 sub do_use { my $self = shift;
2805 $self->do_need($module);
2806 $self->do_import($module,$args);
2810 sub do_need { my $self = shift;
2812 my $module = $m->Str;
2813 my $modfile = $module;
2816 my $std = -x 'std' ? './std' : 'std';
2817 if (not @::PERL6LIB) {
2818 if ($ENV{PERL6LIB}) {
2819 @::PERL6LIB = split ':', $ENV{PERL6LIB}
2822 @::PERL6LIB = qw( ./lib . );
2825 $modfile =~ s/::/\//g;
2827 for my $d (@::PERL6LIB) {
2828 if (-f "$d/$modfile.pm6") {
2833 elsif (-f "$d/$modfile.pm") {
2836 open PM, "$d/$modfile.pm" or next;
2839 next if $pm =~ /^\s*package\s+\w+\s*;/m; # ignore p5 code
2846 my $syml = $::TMP_PREFIX . 'syml';
2847 mkdir $syml unless -d $syml;
2850 $ext = '.pm6' unless -f "$syml/$modfile$ext.syml";
2851 if (-f "$syml/$modfile$ext.syml") {
2852 $topsym = LoadFile("$syml/$modfile$ext.syml");
2853 $self->worry("Can't locate module $module, only its symbol table file");
2856 $self->worry("Can't locate module $module");
2859 elsif (-f "$syml/$modfile$ext.syml" and -M "$lib/$modfile$ext" > -M "$syml/$modfile$ext.syml") {
2860 $topsym = LoadFile("$syml/$modfile$ext.syml");
2862 elsif (-f "$lib/$modfile$ext") {
2863 # say "$std $lib/$module$ext";
2864 system "$std $lib/$module$ext" and die "Can't compile $lib/$module$ext";
2865 $topsym = LoadFile("$syml/$modfile$ext.syml");
2868 $self->worry("Module $module disappeared during load");
2870 $self->add_my_name($module);
2871 $::DECLARAND->{really} = $topsym;
2875 sub do_import { my $self = shift;
2879 my $module = $m->Str;
2880 if ($module =~ /(class|module|role|package)\s+(\S+)/) {
2884 my $pkg = $self->find_stash($module);
2885 if ($pkg->{really}) {
2886 $pkg = $pkg->{really}->{UNIT};
2889 $pkg = $self->find_stash($module . '::');
2892 my $text = $args->Str;
2893 return $self unless $text;
2894 while ($text =~ s/^\s*:?(OUR|MY|STATE|HAS|AUGMENT|SUPERSEDE)?<(.*?)>,?//) {
2895 my $scope = lc($1 // 'my');
2897 local $::SCOPE = $scope;
2898 @imports = split ' ', $imports;
2903 eval { @tagimports = keys %{ $pkg->{'EXPORT::'}->{$_} }; };
2904 $self->do_import_aliases($pkg, @tagimports);
2906 elsif ($pkg->{$_}{export}) {
2907 $self->add_my_name($_, $pkg->{$_});
2909 elsif ($pkg->{'&'.$_}{export}) {
2911 $self->add_my_name($_, $pkg->{$_});
2913 elsif ($pkg->{$_}) {
2914 $self->worry("Can't import $_ because it's not exported by $module");
2919 $self->add_my_name($_);
2925 return $self unless $pkg;
2926 eval { @imports = keys %{ $pkg->{'EXPORT::'}->{'DEFAULT::'} }; };
2927 local $::SCOPE = 'my';
2928 $self->do_import_aliases($pkg, @imports);
2934 sub do_import_aliases {
2937 # say "attempting to import @_";
2940 next if /^PARENT::/;
2942 $self->add_my_name($_, $pkg->{$_});
2947 sub canonicalize_name { my $self = shift;
2949 $name =~ s/^([\$\@\%\&])(\^|:(?!:))/$1/;
2950 $name =~ s/\b:[UD_]$//;
2951 return $name unless $name =~ /::/;
2952 $self->panic("Can't canonicalize a run-time name at compile time: $name") if $name =~ /::\(/;
2953 $name =~ s/^([\$\@%&][!*=?:^.]?)(.*::)(.*)$/$2<$1$3>/;
2955 if ($name =~ s/::<(.*)>$//) {
2958 my @components = split(/(?<=::)/, $name, -1);
2959 shift(@components) while @components and $components[0] eq '';
2960 if (defined $vname) {
2961 $components[-1] .= '::' if @components and $components[-1] !~ /::$/;
2962 push(@components, $vname) if defined $vname;
2967 sub lookup_dynvar { my $self = shift;
2970 if ($name =~ s/^\$\?/::/) {
2971 return $$name if defined $$name;
2973 elsif ($name =~ s/^\@\?/::/) {
2974 return \@$name if defined *$name{ARRAY};
2976 elsif ($name =~ s/^\%\?/::/) {
2977 return \%$name if defined *$name{HASH};
2982 sub mark_sinks { my $self = shift;
2983 my $statements = shift;
2984 return $self unless @$statements;
2985 my @s = @$statements;
2986 my $final = pop(@s);
2989 $self->worry("Useless use of " . $s->Str . " in sink context");
2991 $s->{_pure} = 1; # nothing is pure :)
2997 sub is_pure { my $self = shift;
2998 return 1 if $self->{_pure};
3003 sub check_old_cclass { my $self = shift;
3004 my $innards = shift;
3006 my $prev = substr($::ORIG,$self->{_pos}-length($innards)-4,2);
3007 return $self if $prev =~ /=\s*$/; # don't complain on $var = [\S] capture
3020 $neg = '-' if $i =~ s/^\^//;
3024 if ($i =~ s/^-(.)/$1/) {
3025 $singleok = $doubleok = 0;
3026 $cclass .= $last ? '..' : '\\-';
3029 elsif ($i =~ /^\|./ and $cclass ne '') {
3030 return $self; # probable alternation
3032 elsif ($i =~ s/^\|//) {
3034 $singleok = $doubleok = 0;
3037 elsif ($i =~ /^[*+?]/ and $cclass ne '') {
3038 return $self; # probable quantifier
3040 elsif ($i =~ s/^\\?'//) {
3042 $single .= '\\' . $last;
3046 elsif ($i =~ s/^\\?"//) {
3049 $double .= '\\' . $last;
3052 elsif ($i =~ s/^(\\[btnrf0])//) {
3053 $last = eval '"' . $1 . '"';
3058 elsif ($i =~ s/(\\x\w\w)//) {
3059 $last = eval '"' . $1 . '"';
3064 elsif ($i =~ s/(\\0[0-7]{1,3})//) {
3065 $last = eval '"' . $1 . '"';
3067 $double .= "\\o" . substr($1,1);
3068 $cclass .= "\\o" . substr($1,1);
3070 elsif ($i =~ s/^(\\[sSwWdD])//) {
3071 $singleok = $doubleok = 0;
3075 elsif ($i =~ s/^(\\?\t)//) {
3081 elsif ($i =~ s/^(\\?\x20)//) {
3087 elsif ($i =~ s/^\.//) {
3089 $singleok = $doubleok = 0;
3092 elsif ($i =~ s/^\\(.)//) {
3095 $double .= '\\' . $last;
3096 $cclass .= '\\' . $last;
3098 elsif ($i =~ s/^(.)//s) {
3108 if ($last ne '' and $seen{$last}++) {
3109 return $self; # dup likely indicates not a character class
3113 my $common = "[$innards] appears to be an old-school character class;";
3115 # XXX not Unicodey yet
3117 return $self->worry("$common non-digits should be matched with \\D instead") if $cclass eq '\\d';
3118 return $self->worry("$common non-newlines should be matched with \\N instead") if $cclass eq '\\n';
3120 return $self->worry("$common non-(horizontal whitespace) should be matched with \\H instead") if $single =~ /\A[ \t\b\r]*\z/;
3121 return $self->worry("$common non-(vertical whitespace) should be matched with \\V instead") if $single =~ /\A[\n\f]*\z/;
3122 return $self->worry("$common non-whitespace should be matched with \\S instead") if $single =~ /\A[ \t\b\r\n\f]*\z/;
3123 return $self->worry("$common please use <-[$cclass]> if you mean a character class");
3126 return $self->worry("$common please use <-[$cclass]> if you mean a character class");
3130 return $self->worry("$common digits should be matched with \\d instead") if $cclass eq '\\d';
3132 return $self->worry("$common horizontal whitespace should be matched with \\h instead") if $single =~ /\A[ \t\b\r]*\z/;
3133 return $self->worry("$common vertical whitespace should be matched with \\v instead") if $single =~ /\A[\n\f]*\z/;
3134 return $self->worry("$common whitespace should be matched with \\s instead") if $single =~ /\A[ \t\b\r\n\f]*\z/;
3136 if ($singleok and $single eq $double) {
3137 return $self->worry("$common please use <[$cclass]> if you\n mean a character class, or quote it like '$single' to match\n string as a unit");
3140 return $self->worry("$common please use <[$cclass]> if you\n mean a character class, or quote it like \"$double\" to match\n string as a unit");
3144 return $self->worry("$common please use <${neg}[$cclass]> if you mean a character class");
3147 return $self->worry("$common please use <${neg}[$cclass]> if you\n mean a character class, or put whitespace inside like [ $innards ] to disable\n this warning");
3152 ## vim: expandtab sw=4