src/perl6/dfa/CursorBase.pmc

   1 #!perl
   2
   3 # CursorBase.pmc
   4 #
   5 # Copyright 2008-2010, Larry Wall
   6 #
   7 # You may copy this software under the terms of the Artistic License,
   8 #     version 2.0 or later.
   9
  10 $SIG{INT} = sub { print STDERR Carp::longmess("Oops"); exit(1); };
  11
  12 use strict;
  13 use warnings;
  14 no warnings 'recursion';
  15 use utf8;
  16 use NAME;
  17 use Stash;
  18 use RE_ast;
  19 #use Carp::Always;
  20
  21 my $TRIE = 1;
  22 my $STORABLE = 1;
  23
  24 use feature 'say', 'state';
  25
  26 require 'mangle.pl';
  27
  28 our $CTX = '';
  29 BEGIN {
  30     $::DEBUG //= 0 + ($ENV{STD5DEBUG} // 0);
  31 }
  32 our $DEBUG;
  33 use constant DEBUG => $::DEBUG;
  34 our %LEXERS;       # per language, the cache of lexers, keyed by rule name
  35 our %FATECACHE; # fates we've already turned into linked lists
  36 my %lexer_cache = ();
  37
  38 our %DFALEXERS = ();  # per language (class name), then keyed again by rule
  39
  40 sub ::fatestr { my $f = shift;
  41     my $text = '';
  42     while ($f) {
  43         $text .= $f->[1] . " " . $f->[2];
  44         $text .= ' ' if $f = $f->[0];
  45     }
  46     $text;
  47 }
  48
  49 use DEBUG;
  50
  51 sub ::deb {
  52     print ::LOG @_, "\n";
  53 }
  54
  55 package CursorBase;
  56
  57 use Carp;
  58 use File::Copy;
  59 use YAML::XS;
  60 use Storable;
  61 use Encode;
  62 use Scalar::Util 'refaddr';
  63
  64 use Term::ANSIColor;
  65 our $BLUE = color 'blue';
  66 our $GREEN = color 'green';
  67 our $CYAN = color 'cyan';
  68 our $MAGENTA = color 'magenta';
  69 our $YELLOW = color 'yellow';
  70 our $RED = color 'red';
  71 our $CLEAR = color 'clear';
  72
  73 use LazyMap qw(lazymap eager);
  74 use constant DEBUG => $::DEBUG;
  75
  76 BEGIN {
  77     require Moose;
  78     # this prevents us from inheriting from Moose::Object, which saves a
  79     # good 20 seconds on DESTROY/DEMOLISHALL
  80     Moose::Meta::Class->create('CursorBase');
  81 }
  82
  83 $::PERL6HERE = $ENV{PERL6HERE} // '⏏';
  84 Encode::_utf8_on($::PERL6HERE);
  85
  86 binmode(STDIN, ":utf8");
  87 binmode(STDERR, ":utf8");
  88 binmode(STDOUT, ":utf8");
  89 BEGIN {
  90     if ($^P || !DEBUG) {
  91         open(::LOG, ">&1") or die "Can't create $0.log: $!";
  92     }
  93     else {
  94         open(::LOG, ">$0.log") or die "Can't create $0.log: $!";
  95     }
  96     binmode(::LOG, ":utf8");
  97 }
  98
  99 #############################################################
 100 # Cursor Accessors
 101 #############################################################
 102
 103 sub _PARAMS {}  # overridden in parametric role packages
 104
 105 sub from :lvalue { $_[0]->{_from} //= $_[0]->{_pos} }
 106 sub to { $_[0]->{_pos} }
 107 sub pos :lvalue { $_[0]->{_pos} }
 108 sub chars { $_[0]->{_pos} - ($_[0]->{_from} // $_[0]->{_pos}) }
 109 sub Str { no warnings; exists $_[0]->{_from} && defined $_[0]->{_pos} ? substr($::ORIG, $_[0]->{_from}, $_[0]->{_pos} - $_[0]->{_from})//'' : '' }
 110 sub xact { $_[0]->{_xact} // die "internal error: cursor has no xact!!!" }
 111 sub orig { \$::ORIG }
 112 sub WHAT { ref $_[0] || $_[0] }
 113
 114 sub item { $_[0] }
 115 sub caps { $_[0] && $_[0]->{'~CAPS'} ? @{$_[0]->{'~CAPS'}} : () }
 116 sub chunks { die "unimpl" }
 117 sub ast { exists $_[0]->{'_ast'} ? $_[0]->{'_ast'} : $_[0]->Str }
 118 sub make { $_[0]->{'_ast'} = $_[1]; $_[0] }
 119
 120 sub label_id {
 121     bless { 'file' => $::FILE->{name}, 'pos' => $_[0]->{_pos} }, 'LABEL';
 122 }
 123
 124 sub list { my $self = shift;
 125     my @result;
 126     # can't just do this in numerical order because some might be missing
 127     # and we don't know the max
 128     for my $k (keys %$self) {
 129         $result[$k] = $self->{$k} if $k =~ /^\d/;
 130     }
 131     \@result;
 132 }
 133
 134 sub hash { my $self = shift;
 135     my %result;
 136     for my $k (keys %$self) {
 137         $result{$k} = $self->{$k} if $k !~ /^[_\d~]/;
 138     }
 139     \%result;
 140 }
 141
 142 sub deb { my $self = shift;
 143     my $pos = ref $self && defined $self->{_pos} ? $self->{_pos} : "?";
 144     print ::LOG $pos,'/',$self->lineof($pos), "\t", $CTX, ' ', @_, "\n";
 145 }
 146
 147 sub clean {
 148     my $self = shift;
 149     delete $self->{_fate};
 150     delete $self->{_pos};       # EXPR blows up without this for some reason
 151     delete $self->{_reduced};
 152     for my $k (values %$self) {
 153         next unless ref $k;
 154         if (ref $k eq 'ARRAY') {
 155             for my $k2 (@$k) {
 156                 eval {
 157                     $k2->clean if ref $k2;
 158                 }
 159             }
 160         }
 161         else {
 162             eval {
 163                 $k->clean;
 164             }
 165         }
 166     }
 167     $self;
 168 }
 169
 170 sub dump {
 171     my $self = shift;
 172     my %copy = %$self;
 173     delete $copy{_reduced};
 174     delete $copy{_fate};
 175     my $text = STD::Dump(\%copy);
 176     $text;
 177 }
 178
 179 #############################################################
 180 # Setup/Teardown
 181 #############################################################
 182
 183 sub new {
 184     my $class = shift;
 185 #    $::ORIG = shift;
 186     { no warnings; @::ORIG = unpack("U*", $::ORIG); }
 187     $::MEMOS[@::ORIG] = undef;  # memos kept by position
 188     my %args = ('_pos' => 0, '_from' => 0);
 189     while (@_) {
 190         my $name = shift;
 191         $args{'_' . $name} = shift;
 192     }
 193     my $self = bless \%args, ref $class || $class;
 194     $self->{_xact} = ['MATCH',0,0];
 195     $self;
 196 }
 197
 198 sub parse {
 199     my $class = shift;
 200     my $text = shift;
 201     local $::FILE = { name => '(eval)' };
 202     $class->initparse($text,@_);
 203 }
 204
 205 sub parsefile {
 206     my $class = shift;
 207     my $file = shift;
 208     local $::FILE = { name => $file };
 209     my %args = @_;
 210     my $tmp_prefix = $args{tmp_prefix} // $ENV{STD5PREFIX} // '';
 211     local $::TMP_PREFIX = $tmp_prefix;
 212     $file =~ s/::/\//g;
 213     open(FILE, '<:utf8', $file) or die "Can't open $file: $!\n";
 214     my $text;
 215     {
 216         local $/;
 217         $text = <FILE>;
 218         close FILE;
 219     }
 220
 221     my $result;
 222     $result = $class->initparse($text,@_);
 223
 224     if ($::YOU_WERE_HERE) {
 225         $result->you_were_here;
 226     }
 227     elsif ($file =~ /\.pm6?$/) {
 228         $result->you_were_here;
 229     }
 230     $result;
 231 }
 232
 233 ## method initparse ($text, :$rule = 'TOP', :$tmp_prefix = '', :$setting = 'CORE', :$actions = '')
 234 sub initparse {
 235     my $self = shift;
 236     my $text = shift;
 237     my %args = @_;
 238     my $rule = $args{rule} // 'TOP';
 239     my $tmp_prefix = $args{tmp_prefix} // $ENV{STD5PREFIX} // '';
 240     my $setting = $args{setting} // 'CORE';
 241     my $actions = $args{actions} // '';
 242
 243     local $::TMP_PREFIX = $tmp_prefix;
 244     local $::SETTINGNAME = $setting;
 245     local $::ACTIONS = $actions;
 246     local @::MEMOS = @::MEMOS;
 247
 248     local @::ACTIVE = ();
 249
 250     # various bits of info useful for error messages
 251     local $::HIGHWATER = 0;
 252     local $::HIGHMESS = '';
 253     local $::HIGHEXPECT = {};
 254     local $::LASTSTATE;
 255     local $::LAST_NIBBLE = bless { firstline => 0, lastline => 0 }, 'Cursor';
 256     local $::LAST_NIBBLE_MULTILINE = bless { firstline => 0, lastline => 0 }, 'Cursor';
 257     local $::GOAL = "(eof)";
 258     $text .= "\n" unless substr($text,-1,1) eq "\n";
 259     $::ORIG = $text;           # original string
 260
 261     my $result = $self->new()->$rule();
 262     delete $result->{_xact};
 263
 264     # XXX here attach stuff that will enable :cont
 265
 266     $result;
 267 }
 268
 269 sub load_pad {
 270     my $self = shift;
 271     my $setting = shift;
 272     my $syml = $::TMP_PREFIX . 'syml';
 273     my $file = "$syml/$setting.syml";
 274     if (-e $file) {
 275         bless($self->load_yaml_pad($setting),'Stash');
 276     }
 277     else {
 278         bless($self->load_perl_pad($setting),'Stash');
 279     }
 280 }
 281
 282 sub load_perl_pad {
 283     my $self = shift;
 284     my $setting = shift;
 285     state %PADS;
 286     return $PADS{$setting} if $PADS{$setting};
 287     my $file = "$setting.pad";
 288     my $syml = $::TMP_PREFIX . 'syml';
 289     my $store = "$syml/$setting.pad.store";
 290     mkdir $syml unless -d $syml;
 291     if (-f $store and -M $file and -M $file > -M $store) {
 292         $PADS{$setting} = retrieve($store);
 293     }
 294     else {
 295         $PADS{$setting} = require $file;
 296         store($PADS{$setting}, $store);
 297     }
 298     $PADS{$setting};
 299 }
 300
 301 sub LoadFile {
 302     my $file = shift;
 303     open my $fh, $file or die "Can't open $file: $!";
 304     my $text = do { local $/; <$fh>; };
 305     close $fh;
 306     Load($text);
 307 }
 308
 309 sub load_yaml_pad {
 310     my $self = shift;
 311     my $setting = shift;
 312     state %PADS;
 313     return $PADS{$setting} if $PADS{$setting};
 314     my $syml = $::TMP_PREFIX . 'syml';
 315     my $file = "$syml/$setting.syml";
 316     my $store = "$syml/$setting.syml.store";
 317     mkdir $syml unless -d $syml;
 318     if (-f $store and -M $file and -M $file > -M $store) {
 319         $PADS{$setting} = retrieve($store);
 320     }
 321     else {
 322         $PADS{$setting} = LoadFile($file);
 323         store($PADS{$setting}, $store);
 324     }
 325     # say join ' ', sort keys %{ $PADS{$setting} };
 326     $PADS{$setting};
 327 }
 328
 329 sub you_are_here {
 330     my $self = shift;
 331     $::YOU_WERE_HERE = $::CURPAD;
 332     $self;
 333 }
 334
 335 sub you_were_here {
 336     my $self = shift;
 337     my $file = $::FILE->{name};
 338     my $all;
 339     $file =~ s/(\.setting)?$/.syml/;
 340     $file =~ s!.*/!!;
 341     $file =~ s/::/\//g;
 342     $file = $::TMP_PREFIX . "syml/" . $file;
 343
 344     # setting?
 345     if ($::YOU_WERE_HERE) {
 346         $all = $STD::ALL;
 347         $all->{SETTING} = $::YOU_WERE_HERE;
 348     }
 349     else {
 350         eval { $::UNIT->{'$?SETTING_ID'} = $STD::ALL->{SETTING}->id };
 351         warn $@ if $@;
 352         eval { $::UNIT->{'$?CORE_ID'} = $STD::ALL->{CORE}->id };
 353         warn $@ if $@;
 354
 355         $all = {};
 356         for my $key (keys %{$STD::ALL}) {
 357             next if $key =~ /^MY:file<\w+\.setting>/ or $key eq 'CORE' or $key eq 'SETTING';
 358             $all->{$key} = $STD::ALL->{$key};
 359         }
 360     }
 361
 362     if ($file =~ /\//) {
 363         my @parts = split('/',$file);
 364         my $newfile = shift @parts;
 365         while (@parts) {
 366             mkdir $newfile unless -d $newfile;
 367             $newfile .= '/' . shift @parts;
 368         }
 369     }
 370     open(SETTING, ">$file") or die "Can't open new setting file $file: $!";
 371     print SETTING Dump($all);
 372     close SETTING;
 373     $self;
 374 }
 375
 376 sub delete {
 377     my $self = shift;
 378     delete $self->{@_};
 379 }
 380
 381 { package Match;
 382     sub new { my $self = shift;
 383         my %args = @_;
 384         bless \%args, $self;
 385     }
 386
 387     sub from { my $self = shift;
 388         $self->{_f};
 389     }
 390
 391     sub to { my $self = shift;
 392         $self->{_t};
 393     }
 394 }
 395
 396 #############################################################
 397 # Cursor transformations
 398 #############################################################
 399
 400 sub cursor_xact { my $self = shift;
 401     my $name = shift;
 402     if (DEBUG & DEBUG::cursors) {
 403         my $pedigree = '';
 404         for (my $x = $self->{_xact}; $x; $x = $x->[-1]) {
 405             my $n = $x->[0];
 406             $n =~ s/^RULE // or
 407             $n =~ s/^ALT *//;
 408             $pedigree .= ($x->[-2] ? " - " : " + ") . $n;
 409         }
 410         $self->deb("cursor_xact $name$pedigree");
 411     }
 412     # doing this in place is slightly dangerous, but seems to work
 413     $self->{_xact} = [$name,0,$self->{_xact}];
 414     $self;
 415 }
 416
 417 sub cursor_fresh { my $self = shift;
 418     my %r;
 419     my $lang = @_ && $_[0] ? shift() : ref $self;
 420     $self->deb("cursor_fresh lang $lang") if DEBUG & DEBUG::cursors;
 421     @r{'_pos','_fate','_xact'} = @$self{'_pos','_fate','_xact'};
 422     $r{_herelang} = $self->{_herelang} if $self->{_herelang};
 423     bless \%r, ref $lang || $lang;
 424 }
 425
 426 sub cursor_herelang { my $self = shift;
 427     $self->deb("cursor_herelang") if DEBUG & DEBUG::cursors;
 428     my %r = %$self;
 429     $r{_herelang} = $self;
 430     bless \%r, 'STD::Q';
 431 }
 432
 433 sub prepbind {
 434     my $self = shift;
 435     delete $self->{_fate};
 436     delete $_->{_xact} for @_;
 437     $self;
 438 }
 439
 440 sub cursor_bind { my $self = shift;     # this is parent's match cursor
 441     my $bindings = shift;
 442     my $submatch = shift;               # this is the submatch's cursor
 443     $self->prepbind($submatch);
 444
 445     $self->deb("cursor_bind @$bindings") if DEBUG & DEBUG::cursors;
 446     my @caps;
 447     @caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'};  # must copy elems
 448     my %r = %$self;
 449     if ($bindings) {
 450         for my $binding (@$bindings) {
 451             if (ref $r{$binding} eq 'ARRAY') {
 452                 push(@{$r{$binding}}, $submatch);
 453             }
 454             else {
 455                 $r{$binding} = $submatch;
 456             }
 457             next if $binding eq 'PRE';
 458             next if $binding eq 'POST';
 459             push @caps, $binding, $submatch;
 460         }
 461         $r{'~CAPS'} = \@caps;
 462     }
 463     $submatch->{_from} = $r{_from} = $r{_pos};
 464     $r{_pos} = $submatch->{_pos};
 465     $r{_xact} = $self->{_xact};
 466     bless \%r, ref $self;               # return new match cursor for parent
 467 }
 468
 469 sub cursor_fate { my $self = shift;
 470     my $pkg = shift;
 471     my $name = shift;
 472     my $retree = shift;
 473     # $_[0] is now ref to a $trystate;
 474
 475     $self->deb("cursor_fate $pkg $name") if DEBUG & DEBUG::cursors;
 476
 477     my $lexer = $::LEXERS{ref $self}->{$name} // do {
 478         local %::AUTOLEXED;
 479         $self->_AUTOLEXpeek($name,$retree);
 480     };
 481     if ($self->{_pos} >= $::HIGHWATER) {
 482         if ($self->{_pos} > $::HIGHWATER) {
 483             %$::HIGHEXPECT = ();
 484             $::HIGHMESS = '';
 485         }
 486         $::HIGHEXPECT->{$lexer->{DBA}}++;
 487         $::HIGHWATER = $self->{_pos};
 488     }
 489
 490     my $P = $self->{_pos};
 491     if ($P > @::ORIG) {
 492         return sub {};
 493     }
 494
 495     $self->cursor_fate_dfa($pkg, $name, $lexer, $P);
 496 }
 497
 498 sub cursor_fate_dfa {
 499     my ($self, $pkg, $name, $lexer, $P) = @_;
 500
 501     my $state = $lexer->{S};
 502     my $p = $P;
 503     my @rfates;
 504
 505     print ::LOG "=" x 10,"\n$p DFA for ${pkg}::$name in ", ref $self, "\n" if DEBUG & DEBUG::autolexer;
 506     CH: {
 507         push @rfates, @{ $state->[0] // _jit_dfa_node($lexer, $state) };
 508         if (DEBUG & DEBUG::autolexer) {
 509             for (@{ $state->[0] }) {
 510                 my @b;
 511                 for (my $f = $_; $f; $f = $f->[0]) {
 512                     push @b, @{$f}[1,2];
 513                 }
 514                 print ::LOG "    [adding fate @b]\n";
 515             }
 516         }
 517         last if $p == @::ORIG;
 518         my $chi = $::ORIG[$p++];
 519         print ::LOG "--- ", pack("U", $chi), "\n" if DEBUG & DEBUG::autolexer;
 520         if ($state->[1]{$chi}) {
 521             $state = $state->[1]{$chi};
 522             print ::LOG "specific -> ", $state->[1]{ID}, "\n"
 523                 if DEBUG & DEBUG::autolexer;
 524             redo;
 525         }
 526
 527         my $dt = $state->[2];
 528         while (defined $dt) {
 529             if (ref $dt eq 'ARRAY') {
 530                 if (DEBUG & DEBUG::autolexer) {
 531                     print ::LOG $dt->[2][-1],
 532                         (vec($dt->[2][$chi >> 10], $chi & 1023, 1) ?
 533                             "? yes\n" : "? no\n");
 534                 }
 535                 $dt = $dt->[vec($dt->[2][$chi >> 10], $chi & 1023, 1)];
 536             } else {
 537                 print ::LOG " -> ", $$dt->[1]{ID}, "\n" if DEBUG & DEBUG::autolexer;
 538                 $state = $$dt;
 539                 redo CH;
 540             }
 541         }
 542     }
 543
 544     sub { @rfates ? pop(@rfates) : () };
 545 }
 546
 547 sub cursor_fate_re {
 548     my ($self, $pkg, $name, $lexer, $P) = @_;
 549     # A rudimentary trie walker.
 550
 551     if (my $state = $lexer->{T}) {
 552         my @candidates;
 553         my $p = $P;
 554         my $ch = $::ORIG[$p]//32;
 555         my $next;
 556         print ::LOG "=" x 10,"\n$p TRIE for ${pkg}::$name in ", ref $self, "\n",
 557                 $p," ", pack("U",$ch), "\n" if DEBUG & DEBUG::autolexer;
 558         STATE:
 559         for (;;) {
 560             if ($state->{'~~'}) {
 561                 our %RXCACHE;
 562                 my @x = @{$state->{'~~'}};
 563                 while (my ($final,$fnum) = splice(@x,0,2)) {
 564                     my $pend = $p;
 565                     if ($final) {
 566                         print ::LOG $p,"     probing $fnum $final\n" if DEBUG & DEBUG::autolexer;
 567                         pos($::ORIG) = $p;
 568                         next unless &{$RXCACHE{$final} //= eval "sub { \$::ORIG =~ /\\G$final/xsgc }"};
 569                         $pend = pos($::ORIG);
 570                     }
 571                     push(@{$candidates[$pend - $P][$p - $P]}, $fnum);
 572                     print ::LOG $pend," FNUM $fnum @",$pend - $P,"\n" if DEBUG & DEBUG::autolexer;
 573                 }
 574             }
 575             { no warnings; last STATE unless $next = $state->{chr $ch}; };
 576             if (DEBUG & DEBUG::autolexer) {
 577                 print ::LOG substr($::ORIG, $P, $p - $P), "\n";
 578                 print ::LOG $p," ", pack("U",$ch), "\n";
 579             }
 580             $ch = $::ORIG[++$p];
 581             $state = $next;
 582         }
 583
 584         my $fates = $lexer->{FATES};
 585
 586         # Return longest, most-specific candidate or list of tied candidates.
 587         # (If the latter, candidate list itself follows original rule order).
 588         # This is essentially a lazy list of LTM candidates, batched by ties.
 589         # Subsequent calls return next-most specific, then next-most longest.
 590         return sub {
 591                     while (@candidates) {
 592                         my $long = $candidates[-1];
 593                         if (defined $long) {
 594                             while (@$long) {
 595                                 my $specific = pop @$long // next;
 596                                 if (DEBUG & DEBUG::autolexer) {
 597                                     say ::LOG "relex sez ", join ' ', @$specific;
 598                                 }
 599                                 return @$fates[@$specific];
 600                             }
 601                         }
 602                         pop @candidates;
 603                     }
 604                     ();
 605                 };
 606
 607     }
 608     print ::LOG "FAILED trie at $P\n" if DEBUG & DEBUG::autolexer;
 609     die "TRIE failed";
 610 }
 611
 612 sub cursor_all { my $self = shift;
 613     my $fpos = shift;
 614     my $tpos = shift;
 615
 616     $self->deb("cursor_all from $fpos to $tpos") if DEBUG & DEBUG::cursors;
 617     my %r = %$self;
 618     @r{'_from','_pos'} = ($fpos,$tpos);
 619
 620     bless \%r, ref $self;
 621 }
 622
 623 sub makestr { my $self = shift;
 624     $self->deb("maketext @_") if DEBUG & DEBUG::cursors;
 625     my %r = @_;
 626
 627     bless \%r, "Str";
 628 }
 629
 630 sub cursor_tweak { my $self = shift;
 631     my $tpos = shift;
 632
 633     if (DEBUG & DEBUG::cursors) {
 634         my $peek = substr($::ORIG,$tpos,20);
 635         $peek =~ s/\n/\\n/g;
 636         $peek =~ s/\t/\\t/g;
 637         $self->deb("cursor to $tpos --------->$GREEN$peek$CLEAR");
 638     }
 639     $self->{_pos} = $tpos;
 640     return () if $tpos > @::ORIG;
 641
 642     $self;
 643 }
 644
 645 sub cursor_incr { my $self = shift;
 646     my $tpos = $self->{_pos} + 1;
 647
 648     $self->panic("Unexpected EOF") if $tpos > length($::ORIG);
 649     if (DEBUG & DEBUG::cursors) {
 650         my $peek = substr($::ORIG,$tpos,20);
 651         $peek =~ s/\n/\\n/g;
 652         $peek =~ s/\t/\\t/g;
 653         $self->deb("cursor to $tpos --------->$GREEN$peek$CLEAR");
 654     }
 655     $self->{_pos} = $tpos;
 656     return () if $tpos > @::ORIG;
 657
 658     $self;
 659 }
 660
 661 sub cursor { my $self = shift;
 662     my $tpos = shift;
 663
 664     $self->panic("Unexpected EOF") if $tpos > length($::ORIG);
 665     if (DEBUG & DEBUG::cursors) {
 666         my $peek = substr($::ORIG,$tpos,20);
 667         $peek =~ s/\n/\\n/g;
 668         $peek =~ s/\t/\\t/g;
 669         $self->deb("cursor to $tpos --------->$GREEN$peek$CLEAR");
 670     }
 671     my %r = %$self;
 672 #    $r{_from} = $self->{_pos} // 0;
 673     $r{_pos} = $tpos;
 674
 675     bless \%r, ref $self;
 676 }
 677
 678 sub cursor_force { my $self = shift;
 679     my $tpos = shift;
 680
 681     $self->panic("Unexpected EOF") if $tpos > length($::ORIG);
 682     if (DEBUG & DEBUG::cursors) {
 683         my $peek = substr($::ORIG,$tpos,20);
 684         $peek =~ s/\n/\\n/g;
 685         $peek =~ s/\t/\\t/g;
 686         $self->deb("cursor to $tpos --------->$GREEN$peek$CLEAR");
 687     }
 688     my %r = %$self;
 689 #    $r{_from} = $self->{_pos} // 0;
 690     $r{_pos} = $::HIGHWATER = $tpos;
 691
 692     bless \%r, ref $self;
 693 }
 694
 695 sub cursor_rev { my $self = shift;
 696     my $fpos = shift;
 697
 698     if (DEBUG & DEBUG::cursors) {
 699         my $peek = substr($::ORIG,$fpos,20);
 700         $peek =~ s/\n/\\n/g;
 701         $peek =~ s/\t/\\t/g;
 702         $self->deb("cursor_ref to $fpos --------->$GREEN$peek$CLEAR");
 703     }
 704     my %r = %$self;
 705     $r{_pos} = $fpos;
 706
 707     bless \%r, ref $self;
 708 }
 709
 710 #############################################################
 711 # Regex service routines
 712 #############################################################
 713
 714 sub callm { my $self = shift;
 715     my $arg = shift;
 716     my $class = ref($self) || $self;
 717
 718     my $lvl = 0;
 719     my $extralvl = 0;
 720     my @subs;
 721     if (DEBUG & DEBUG::callm_show_subnames) {
 722         while (my @c = caller($lvl)) {
 723             $lvl++;
 724             my $s = $c[3];
 725             if ($s =~ /::_/) {
 726                 next;
 727             }
 728             elsif ($s =~ /^Cursor(?:Base)?::/) {
 729                 next;
 730             }
 731             elsif ($s =~ /^LazyMap::/) {
 732                 next;
 733             }
 734             elsif ($s =~ /^\(eval\)/) {
 735                 next;
 736             }
 737             else {
 738                 $extralvl = $lvl unless $extralvl;
 739                 $s =~ s/.*:://;
 740                 push @subs, $s;
 741             }
 742         }
 743     }
 744     else {
 745         while (my @c = caller($lvl)) { $lvl++; }
 746     }
 747     my ($package, $file, $line, $subname, $hasargs) = caller(1);
 748     my $name = $subname;
 749     if (defined $arg) {
 750         $name .= " " . $arg;
 751     }
 752     my $pos = '?';
 753     $self->deb($name, " [", $file, ":", $line, "] $class") if DEBUG & DEBUG::trace_call;
 754     if (DEBUG & DEBUG::callm_show_subnames) {
 755         $RED . join(' ', reverse @subs) . $CLEAR . ':' x $extralvl;
 756     }
 757     else {
 758         ':' x $lvl;
 759     }
 760 }
 761
 762 sub retm {
 763     return $_[0] unless DEBUG & DEBUG::trace_call;
 764     my $self = shift;
 765     warn "Returning non-Cursor: $self\n" unless exists $self->{_pos};
 766     my ($package, $file, $line, $subname, $hasargs) = caller(1);
 767     $self->deb($subname, " returning @{[$self->{_pos}]}");
 768     $self;
 769 }
 770
 771 sub _MATCHIFY { my $self = shift;
 772     my $S = shift;
 773     my $name = shift;
 774     return () unless @_;
 775     my $xact = $self->{_xact};
 776     my @result = lazymap( sub { my $x = shift; $x->{_xact} = $xact; $x->_REDUCE($S, $name)->retm() }, @_);
 777     if (wantarray) {
 778         @result;
 779     }
 780     else {
 781         $result[0];
 782     }
 783 }
 784
 785 sub _MATCHIFYr { my $self = shift;
 786     my $S = shift;
 787     my $name = shift;
 788     return () unless @_;
 789     my $var = shift;
 790 #    $var->{_from} = $self->{_from};
 791     my $xact = $self->{_xact};
 792     $var->{_xact} = $xact;
 793     $var->_REDUCE($S, $name)->retm();
 794 }
 795
 796 sub _SCANf { my $self = shift;
 797
 798     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
 799     my $eos = @::ORIG;
 800
 801     my $pos = $self->{_pos};
 802     my $C = $self->cursor_xact("SCANf $pos");
 803     my $xact = $C->xact;
 804
 805     lazymap( sub { $self->cursor($_[0])->retm() }, LazyRange->new($xact, $pos,$eos) );
 806 }
 807
 808 sub _SCANg { my $self = shift;
 809
 810     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
 811     my $pos = $self->{_pos};
 812     my $eos = @::ORIG;
 813     my $C = $self->cursor_xact("SCANg $pos");
 814     my $xact = $C->xact;
 815
 816     lazymap( sub { $C->cursor($_[0])->retm() }, LazyRangeRev->new($xact, $eos,$pos) );
 817 }
 818
 819 sub _STARf { my $self = shift;
 820     my $block = shift;
 821     no warnings 'recursion';
 822
 823     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
 824
 825     my $pos = $self->{_pos};
 826     my $C = $self->cursor_xact("SCANf $pos");
 827     my $xact = $C->xact;
 828
 829     lazymap(sub { $_[0]->retm() },
 830         $C->cursor($pos),
 831         LazyMap->new(sub { $C->_PLUSf($_[0]) }, $block));
 832 }
 833
 834 sub _STARg { my $self = shift;
 835     my $block = shift;
 836     no warnings 'recursion';
 837
 838     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
 839
 840     my $pos = $self->{_pos};
 841     my $C = $self->cursor_xact("STARg $pos");
 842 #    my $xact = $C->xact;
 843
 844     lazymap(sub { $_[0]->retm() }, reverse
 845         eager(
 846             $C->cursor($self->{_pos}),
 847             $C->_PLUSf($block))
 848         );
 849 }
 850
 851 sub _STARr { my $self = shift;
 852     my $block = shift;
 853     no warnings 'recursion';
 854
 855     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
 856     my $pos = $self->{_pos};
 857     my $prev = $self->cursor_xact("STARr $pos");
 858 #    my $xact = $prev->xact;
 859
 860     my $prev_pos = $prev->{_pos} // 0;
 861     my @all;
 862     my $eos = @::ORIG;
 863
 864     for (;;) {
 865       last if $prev->{_pos} == $eos;
 866         my @matches = $block->($prev);  # XXX shouldn't read whole list
 867 #            say @matches.perl;
 868       last unless @matches;
 869         my $first = $matches[0];  # no backtracking into block on ratchet
 870         last if $first->{_pos} == $prev_pos;
 871         $prev_pos = $first->{_pos};
 872         push @all, $first;
 873         $prev = $first;
 874     }
 875     $self->cursor($prev_pos)->retm();
 876 }
 877
 878 sub _PLUSf { my $self = shift;
 879     my $block = shift;
 880     no warnings 'recursion';
 881
 882     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
 883
 884     my $pos = $self->{_pos};
 885     my $x = $self->cursor_xact("PLUSf $pos");
 886     my $xact = $x->xact;
 887
 888     # don't go beyond end of string
 889     return () if $self->{_pos} == @::ORIG;
 890
 891     lazymap(
 892         sub {
 893             my $x = $_[0];
 894             lazymap(
 895                 sub {
 896                     $self->cursor($_[0]->{_pos})->retm()
 897                 }, $x, LazyMap->new(sub { $x->_PLUSf($_[0]) }, $block)
 898             );
 899         }, $block->($self)
 900     );
 901 }
 902
 903 sub _PLUSg { my $self = shift;
 904     my $block = shift;
 905     no warnings 'recursion';
 906
 907     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
 908
 909     my $pos = $self->{_pos};
 910     my $C = $self->cursor_xact("PLUSg $pos");
 911 #    my $xact = $C->xact;
 912
 913     reverse eager($C->_PLUSf($block, @_));
 914 }
 915
 916 sub _PLUSr { my $self = shift;
 917     my $block = shift;
 918     no warnings 'recursion';
 919
 920     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
 921     my @all;
 922     my $eos = @::ORIG;
 923
 924     my $pos = $self->{_pos};
 925     my $to = $self->cursor_xact("PLUSr $pos");
 926 #    my $xact = $to->xact;
 927
 928     for (;;) {
 929       last if $to->{_pos} == $eos;
 930         my @matches = $block->($to);  # XXX shouldn't read whole list
 931       last unless @matches;
 932         my $first = $matches[0];  # no backtracking into block on ratchet
 933         #$first->deb($matches->perl) if DEBUG;
 934         push @all, $first;
 935         $to = $first;
 936     }
 937     return () unless @all;
 938     $self->cursor($to->{_pos})->retm();
 939 }
 940
 941 sub _REPSEPf { my $self = shift;
 942     my $sep = shift;
 943     my $block = shift;
 944     no warnings 'recursion';
 945
 946     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
 947
 948     my @result;
 949     # don't go beyond end of string
 950     return () if $self->{_pos} == @::ORIG;
 951
 952     my $pos = $self->{_pos};
 953     my $C = $self->cursor_xact("REPSEPf $pos");
 954 #    my $xact = $C->xact;
 955
 956     do {
 957         for my $x ($block->($C)) {
 958             for my $s ($sep->($x)) {
 959                 push @result, lazymap(sub { $C->cursor($_[0]->{_pos}) }, $x, $s->_REPSEPf($sep,$block));
 960             }
 961         }
 962     };
 963     lazymap(sub { $_[0]->retm() }, @result);
 964 }
 965
 966 sub _REPSEPg { my $self = shift;
 967     my $sep = shift;
 968     my $block = shift;
 969     no warnings 'recursion';
 970
 971     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
 972
 973     my $pos = $self->{_pos};
 974     my $C = $self->cursor_xact("REPSEPg $pos");
 975     # my $xact = $C->xact;
 976
 977     reverse eager($C->_REPSEPf($sep, $block, @_));
 978 }
 979
 980 sub _REPSEPr { my $self = shift;
 981     my $sep = shift;
 982     my $block = shift;
 983     no warnings 'recursion';
 984
 985     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
 986     my @all;
 987     my $eos = @::ORIG;
 988
 989     my $pos = $self->{_pos};
 990     my $to = $self->cursor_xact("REPSEPr $pos");
 991 #    my $xact = $C->xact;
 992
 993     for (;;) {
 994       last if $to->{_pos} == $eos;
 995         my @matches = $block->($to);  # XXX shouldn't read whole list
 996       last unless @matches;
 997         my $first = $matches[0];  # no backtracking into block on ratchet
 998         #$first->deb($matches->perl) if DEBUG;
 999         push @all, $first;
1000         my @seps = $sep->($first);
1001       last unless @seps;
1002         my $sep = $seps[0];
1003         $to = $sep;
1004     }
1005     return () unless @all;
1006     $self->cursor($all[-1]->{_pos})->retm;
1007 }
1008
1009 sub _OPTr { my $self = shift;
1010     my $block = shift;
1011     no warnings 'recursion';
1012
1013     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1014
1015     my $pos = $self->{_pos};
1016     my $C = $self->cursor_xact("OPTr $pos");
1017     my $xact = $C->xact;
1018
1019     my $x = ($block->($C))[0];
1020     my $r = $x // $C->cursor_tweak($pos);
1021     $r->{_xact} = $self->{_xact};
1022     $r->retm();
1023 }
1024
1025 sub _OPTg { my $self = shift;
1026     my $block = shift;
1027     no warnings 'recursion';
1028
1029     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1030
1031     my $pos = $self->{_pos};
1032     my $C = $self->cursor_xact("OPTg $pos");
1033 #    my $xact = $C->xact;
1034
1035     my @x = $block->($C);
1036
1037     lazymap(sub { $_[0]->retm() },
1038         $block->($C),
1039         $self->cursor($pos));
1040 }
1041
1042 sub _OPTf { my $self = shift;
1043     my $block = shift;
1044     no warnings 'recursion';
1045
1046     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1047
1048     my $pos = $self->{_pos};
1049     my $C = $self->cursor_xact("OPTf $pos");
1050 #    my $xact = $C->xact;
1051
1052     lazymap(sub { $_[0]->retm() },
1053         $C->cursor($C->{_pos}),
1054         $block->($self));
1055 }
1056
1057 sub _BRACKET { my $self = shift;
1058     my $block = shift;
1059     no warnings 'recursion';
1060
1061     my $oldlang = ref($self);
1062     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1063     lazymap(sub { bless($_[0],$oldlang)->retm() },
1064         $block->($self));
1065 }
1066
1067 sub _BRACKETr { my $self = shift;
1068     my $block = shift;
1069     no warnings 'recursion';
1070
1071     my $oldlang = ref($self);
1072     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1073     my ($val) = $block->($self) or return ();
1074     bless($val,$oldlang)->retm();
1075 }
1076
1077 sub _PAREN { my $self = shift;
1078     my $block = shift;
1079     no warnings 'recursion';
1080
1081     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1082     lazymap(sub { $_[0]->retm() },
1083         $block->($self));
1084 }
1085
1086 sub _NOTBEFORE { my $self = shift;
1087     my $block = shift;
1088     no warnings 'recursion';
1089
1090     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1091     local $::HIGHEXPECT = {};   # don't count lookahead as expectation
1092     local $::HIGHWATER = $::HIGHWATER;
1093     my @caps;
1094     @caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'};  # must copy elems
1095     my @all = $block->($self);
1096     return () if @all;
1097     $self->{'~CAPS'} = \@caps;
1098     return $self->cursor($self->{_pos})->retm();
1099 }
1100
1101 sub _NOTCHAR { my $self = shift;
1102     my $block = shift;
1103     no warnings 'recursion';
1104
1105     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1106     my @all = $block->($self);
1107     return () if @all;
1108     return $self->cursor($self->{_pos}+1)->retm();
1109 }
1110
1111 sub before { my $self = shift;
1112     my $block = shift;
1113     no warnings 'recursion';
1114
1115     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1116     local $::HIGHEXPECT = {};   # don't count lookahead as expectation
1117     local $::HIGHWATER = $::HIGHWATER;
1118     my @caps;
1119     @caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'};  # must copy elems
1120     my @all = $block->($self);
1121     if (@all and $all[0]) {
1122         $all[0]->{'~CAPS'} = \@caps;
1123         if ($self->{_ast}) {
1124             $all[0]->{'_ast'} = $self->{_ast};
1125         }
1126         else {
1127             delete $all[0]->{'_ast'};
1128         }
1129         return $all[0]->cursor_all(($self->{_pos}) x 2)->retm();
1130     }
1131     return ();
1132 }
1133
1134 sub suppose { my $self = shift;
1135     my $block = shift;
1136     no warnings 'recursion';
1137
1138     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1139     local $::FATALS = 0;
1140     local @::WORRIES;
1141     local %::WORRIES;
1142     local $::HIGHWATER = -1;
1143     local $::HIGHMESS;
1144     local $::HIGHEXPECT = {};
1145     local $::IN_SUPPOSE = 1;
1146     my @all;
1147     eval {
1148         @all = $block->($self);
1149     };
1150     lazymap( sub { $_[0]->retm() }, @all );
1151 }
1152
1153 sub after { my $self = shift;
1154     my $block = shift;
1155     no warnings 'recursion';
1156
1157     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1158     local $::HIGHEXPECT = {};   # don't count lookbehind as expectation
1159     my $end = $self->cursor($self->{_pos});
1160     my @caps;
1161     @caps = @{$self->{'~CAPS'}} if $self->{'~CAPS'};  # must copy elems
1162     my @all = $block->($end);          # Make sure $_->{_from} == $_->{_pos}
1163     if (@all and $all[0]) {
1164         $all[0]->{'~CAPS'} = \@caps;
1165         if ($self->{_ast}) {
1166             $all[0]->{'_ast'} = $self->{_ast};
1167         }
1168         else {
1169             delete $all[0]->{'_ast'};
1170         }
1171         return $all[0]->cursor_all(($self->{_pos}) x 2)->retm();
1172     }
1173     return ();
1174 }
1175
1176 sub null { my $self = shift;
1177     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1178     return $self->cursor($self->{_pos})->retm();
1179 }
1180
1181 sub ws__PEEK { ''; }
1182 sub ws {
1183     my $self = shift;
1184
1185     local $CTX = $self->callm() if DEBUG & DEBUG::trace_call;
1186     my @stub = return $self if exists $::MEMOS[$self->{_pos}]{ws};
1187
1188     my $S = $self->{_pos};
1189     my $C = $self->cursor_xact("RULE ws $S");
1190 #    my $xact = $C->xact;
1191
1192     $::MEMOS[$S]{ws} = undef;   # exists means we know, undef means no ws  before here
1193
1194     $self->_MATCHIFY($S, 'ws',
1195         $C->_BRACKET( sub { my $C=shift;
1196             do { my @gather;
1197                     push @gather, (map { my $C=$_;
1198                         (map { my $C=$_;
1199                             (map { my $C=$_;
1200                                 $C->_NOTBEFORE( sub { my $C=shift;
1201                                     $C
1202                                 })
1203                             } $C->_COMMITRULE())
1204                         } $C->before(sub { my $C=shift;
1205                             $C->_ALNUM()
1206                         }))
1207                     } $C->before( sub { my $C=shift;
1208                         $C->after(sub { my $C=shift;
1209                             $C->_ALNUM_rev()
1210                         })
1211                     }))
1212                     or
1213                     push @gather, (map { my $C=$_;
1214                         (map { my $C=$_;
1215                             scalar(do { $::MEMOS[$C->{_pos}]{ws} = $S unless $C->{_pos} == $S }, $C)
1216                         } $C->_STARr(sub { my $C=shift;
1217                             $C->_SPACE()
1218                         }))
1219                     } $C);
1220               @gather;
1221             }
1222         })
1223     );
1224 }
1225
1226 sub _ASSERT { my $self = shift;
1227     my $block = shift;
1228     no warnings 'recursion';
1229
1230     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1231     my @all = $block->($self);
1232     if ((@all and $all[0]->{_bool})) {
1233         return $self->cursor($self->{_pos})->retm();
1234     }
1235     return ();
1236 }
1237
1238 sub _BINDVAR { my $self = shift;
1239     my $var = shift;
1240     my $block = shift;
1241     no warnings 'recursion';
1242
1243     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1244     lazymap(sub { $$var = $_[0]; $_[0]->retm() },
1245         $block->($self));
1246 }
1247
1248 sub _SUBSUME { my $self = shift;
1249     my $names = shift;
1250     my $block = shift;
1251     no warnings 'recursion';
1252     no warnings 'recursion';
1253
1254     local $CTX = $self->callm($names ? "@$names" : "") if DEBUG & DEBUG::trace_call;
1255     lazymap(sub { $self->cursor_bind($names, $_[0])->retm() },
1256         $block->($self->cursor_fresh()));
1257 }
1258
1259 sub _SUBSUMEr { my $self = shift;
1260     my $names = shift;
1261     my $block = shift;
1262     no warnings 'recursion';
1263     no warnings 'recursion';
1264
1265     local $CTX = $self->callm($names ? "@$names" : "") if DEBUG & DEBUG::trace_call;
1266     my ($var) = $block->($self->cursor_fresh()) or return ();
1267     $self->cursor_bind($names, $var)->retm();
1268 }
1269
1270 sub _EXACT_rev { my $self = shift;
1271     my $s = shift() // '';
1272     my @ints = unpack("U*", $s);
1273
1274     local $CTX = $self->callm($s) if DEBUG & DEBUG::trace_call;
1275     my $P = $self->{_pos} // 0;
1276     while (@ints) {
1277         return () unless ($::ORIG[--$P]//-1) == pop @ints;
1278     }
1279     return $self->cursor($P)->retm();
1280 }
1281
1282 sub _EXACT { my $self = shift;
1283     my $s = shift() // '';
1284     my @ints = unpack("U*", $s);
1285
1286     local $CTX = $self->callm($s) if DEBUG & DEBUG::trace_call;
1287     my $P = $self->{_pos} // 0;
1288     while (@ints) {
1289         return () unless ($::ORIG[$P++]//-1) == shift @ints;
1290     }
1291     return $self->cursor($P)->retm();
1292 #    if (substr($::ORIG, $P, $len) eq $s) {
1293 #        $self->deb("EXACT $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1294 #        my $r = $self->cursor($P+$len);
1295 #        $r->retm();
1296 #    }
1297 #    else {
1298 #        $self->deb("EXACT $s didn't match @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1299 #        return ();
1300 #    }
1301 }
1302
1303 sub _PATTERN { my $self = shift;
1304     my $qr = shift;
1305
1306     local $CTX = $self->callm($qr) if DEBUG & DEBUG::trace_call;
1307     my $P = $self->{_pos} // 0;
1308     pos($::ORIG) = $P;
1309     if ($::ORIG =~ /$qr/gc) {
1310         my $len = pos($::ORIG) - $P;
1311         $self->deb("PATTERN $qr matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1312         my $r = $self->cursor($P+$len);
1313         $r->retm();
1314     }
1315     else {
1316         $self->deb("PATTERN $qr didn't match at $P") if DEBUG & DEBUG::matchers;
1317         return ();
1318     }
1319 }
1320
1321 sub _BACKREFn { my $self = shift;
1322     my $n = shift;
1323
1324     local $CTX = $self->callm($n) if DEBUG & DEBUG::trace_call;
1325     my $P = $self->{_pos} // 0;
1326     my $s = $self->{$n}->Str;
1327     my $len = length($s);
1328     if (substr($::ORIG, $P, $len) eq $s) {
1329         $self->deb("EXACT $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1330         my $r = $self->cursor($P+$len);
1331         $r->retm();
1332     }
1333     else {
1334         $self->deb("EXACT $s didn't match @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1335         return ();
1336     }
1337 }
1338
1339 sub _SYM { my $self = shift;
1340     my $s = shift;
1341     my $i = shift;
1342
1343     $s = $s->[0] if ref $s eq 'ARRAY';
1344
1345     local $CTX = $self->callm($s) if DEBUG & DEBUG::trace_call;
1346     my $P = $self->{_pos} // 0;
1347     my $len = length($s);
1348     if ($i
1349         ? lc substr($::ORIG, $P, $len) eq lc $s
1350         : substr($::ORIG, $P, $len) eq $s
1351     ) {
1352         $self->deb("SYM $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1353         my $r = $self->cursor($P+$len);
1354         $r->{sym} = $s;
1355         $r->retm();
1356     }
1357     else {
1358         $self->deb("SYM $s didn't match @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1359         return ();
1360     }
1361 }
1362
1363 #sub _EXACT_rev { my $self = shift;
1364 #    my $s = shift;
1365 #
1366 #    local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1367 #    my $len = length($s);
1368 #    my $from = $self->{_pos} - $len;
1369 #    if ($from >= 0 and substr($::ORIG, $from, $len) eq $s) {
1370 #        my $r = $self->cursor_rev($from);
1371 #        $r->retm();
1372 #    }
1373 #    else {
1374 ##        say "EXACT_rev $s didn't match @{[substr($!orig,$from,$len)]} at $from $len";
1375 #        return ();
1376 #    }
1377 #}
1378
1379 sub _ARRAY { my $self = shift;
1380     local $CTX = $self->callm(0+@_) if DEBUG & DEBUG::trace_call;
1381     my $P = $self->{_pos} // 0;
1382     my @array = sort { length($b) <=> length($a) } @_;  # XXX suboptimal
1383     my @result = ();
1384     for my $s (@array) {
1385         my $len = length($s);
1386         if (substr($::ORIG, $P, $len) eq $s) {
1387             $self->deb("ARRAY elem $s matched @{[substr($::ORIG,$P,$len)]} at $P $len") if DEBUG & DEBUG::matchers;
1388             my $r = $self->cursor($P+$len);
1389             push @result, $r->retm('');
1390         }
1391     }
1392     return @result;
1393 }
1394
1395 sub _ARRAY_rev { my $self = shift;
1396     local $CTX = $self->callm(0+@_) if DEBUG & DEBUG::trace_call;
1397     my @array = sort { length($b) <=> length($a) } @_;  # XXX suboptimal
1398     my @result = ();
1399     for my $s (@array) {
1400         my $len = length($s);
1401         my $from = $self->{_pos} = $len;
1402         if (substr($::ORIG, $from, $len) eq $s) {
1403             $self->deb("ARRAY_rev elem $s matched @{[substr($::ORIG,$from,$len)]} at $from $len") if DEBUG & DEBUG::matchers;
1404             my $r = $self->cursor_rev($from);
1405             push @result, $r->retm('');
1406         }
1407     }
1408     return @result;
1409 }
1410
1411 sub _DIGIT { my $self = shift;
1412     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1413     my $P = $self->{_pos};
1414     my $char = substr($::ORIG, $P, 1);
1415     if ($char =~ /^\d$/) {
1416         my $r = $self->cursor($P+1);
1417         return $r->retm();
1418     }
1419     else {
1420 #        say "DIGIT didn't match $char at $P";
1421         return ();
1422     }
1423 }
1424
1425 sub _DIGIT_rev { my $self = shift;
1426     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1427     my $from = $self->{_pos} - 1;
1428     if ($from < 0) {
1429 #        say "DIGIT_rev didn't match $char at $from";
1430         return ();
1431     }
1432     my $char = substr($::ORIG, $from, 1);
1433     if ($char =~ /^\d$/) {
1434         my $r = $self->cursor_rev($from);
1435         return $r->retm();
1436     }
1437     else {
1438 #        say "DIGIT_rev didn't match $char at $from";
1439         return ();
1440     }
1441 }
1442
1443 sub ww { my $self = shift;
1444     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1445     my $P = $self->{_pos};
1446     return () unless $P;
1447     my $chars = substr($::ORIG, $P-1, 2);
1448     if ($chars =~ /^\w\w$/) {
1449         my $r = $self->cursor($P);
1450         return $r->retm();
1451     }
1452     else {
1453 #        say "ww didn't match $chars at $P";
1454         return ();
1455     }
1456 }
1457
1458 sub _ALNUM { my $self = shift;
1459     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1460     my $P = $self->{_pos};
1461     my $char = substr($::ORIG, $P, 1);
1462     if ($char =~ /^\w$/) {
1463         my $r = $self->cursor($P+1);
1464         return $r->retm();
1465     }
1466     else {
1467 #        say "ALNUM didn't match $char at $P";
1468         return ();
1469     }
1470 }
1471
1472 sub _ALNUM_rev { my $self = shift;
1473     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1474     my $from = $self->{_pos} - 1;
1475     if ($from < 0) {
1476 #        say "ALNUM_rev didn't match $char at $from";
1477         return ();
1478     }
1479     my $char = substr($::ORIG, $from, 1);
1480     if ($char =~ /^\w$/) {
1481         my $r = $self->cursor_rev($from);
1482         return $r->retm();
1483     }
1484     else {
1485 #        say "ALNUM_rev didn't match $char at $from";
1486         return ();
1487     }
1488 }
1489
1490 my $alpha;
1491 BEGIN {
1492     $alpha = "";
1493     for my $ch (0..255) {
1494         my $char = chr($ch);
1495         vec($alpha,$ch,1) = 1 if $char =~ /\w/ and $char !~ /\d/;
1496     }
1497 }
1498 sub alpha { my $self = shift;
1499     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1500     my $P = $self->{_pos};
1501 #    my $char = substr($::ORIG, $P, 1);
1502     my $ch = $::ORIG[$P];
1503     if (vec($alpha,$ch,1) or ($ch > 255 and chr($ch) =~ /\pL/)) {
1504 #    if ($char =~ /^[_[:alpha:]\pL]$/) {
1505         my $r = $self->cursor($P+1);
1506         return $r->retm();
1507     }
1508     else {
1509 #        say "alpha didn't match $char at $P";
1510         return ();
1511     }
1512 }
1513
1514 sub alpha_rev { my $self = shift;
1515     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1516     my $from = $self->{_pos} - 1;
1517     if ($from < 0) {
1518         return ();
1519     }
1520     my $char = substr($::ORIG, $from, 1);
1521     if ($char =~ /^[_[:alpha:]\pL]$/) {
1522         my $r = $self->cursor_rev($from);
1523         return $r->retm();
1524     }
1525     else {
1526         return ();
1527     }
1528 }
1529
1530 sub _SPACE { my $self = shift;
1531     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1532     my $P = $self->{_pos};
1533     my $char = substr($::ORIG, $P, 1);
1534     if ($char =~ /^\s$/) {
1535         my $r = $self->cursor($P+1);
1536         return $r->retm();
1537     }
1538     else {
1539 #        say "SPACE didn't match $char at $P";
1540         return ();
1541     }
1542 }
1543
1544 sub _SPACE_rev { my $self = shift;
1545     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1546     my $from = $self->{_pos} - 1;
1547     if ($from < 0) {
1548 #        say "SPACE_rev didn't match $char at $from";
1549         return ();
1550     }
1551     my $char = substr($::ORIG, $from, 1);
1552     if ($char =~ /^\s$/) {
1553         my $r = $self->cursor_rev($from);
1554         return $r->retm();
1555     }
1556     else {
1557 #        say "SPACE_rev didn't match $char at $from";
1558         return ();
1559     }
1560 }
1561
1562 sub _HSPACE { 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 =~ /^[ \t\r]$/ or ($char =~ /^\s$/ and $char !~ /^[\n\f\0x0b\x{2028}\x{2029}]$/)) {
1567         my $r = $self->cursor($P+1);
1568         return $r->retm();
1569     }
1570     else {
1571 #        say "HSPACE didn't match $char at $P";
1572         return ();
1573     }
1574 }
1575
1576 sub _HSPACE_rev { my $self = shift;
1577     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1578     my $from = $self->{_pos} - 1;
1579     if ($from < 0) {
1580 #        say "HSPACE_rev didn't match $char at $from";
1581         return ();
1582     }
1583     my $char = substr($::ORIG, $from, 1);
1584     if ($char =~ /^[ \t\r]$/ or ($char =~ /^\s$/ and $char !~ /^[\n\f\0x0b\x{2028}\x{2029}]$/)) {
1585         my $r = $self->cursor_rev($from);
1586         return $r->retm();
1587     }
1588     else {
1589 #        say "HSPACE_rev didn't match $char at $from";
1590         return ();
1591     }
1592 }
1593
1594 sub _VSPACE { my $self = shift;
1595     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1596     my $P = $self->{_pos};
1597     my $char = substr($::ORIG, $P, 1);
1598     if ($char =~ /^[\n\f\x0b\x{2028}\x{2029}]$/) {
1599         my $r = $self->cursor($P+1);
1600         return $r->retm();
1601     }
1602     else {
1603 #        say "VSPACE didn't match $char at $P";
1604         return ();
1605     }
1606 }
1607
1608 sub _VSPACE_rev { my $self = shift;
1609     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1610     my $from = $self->{_pos} - 1;
1611     if ($from < 0) {
1612 #        say "VSPACE_rev didn't match $char at $from";
1613         return ();
1614     }
1615     my $char = substr($::ORIG, $from, 1);
1616     if ($char =~ /^[\n\f\x0b\x{2028}\x{2029}]$/) {
1617         my $r = $self->cursor_rev($from);
1618         return $r->retm();
1619     }
1620     else {
1621 #        say "VSPACE_rev didn't match $char at $from";
1622         return ();
1623     }
1624 }
1625
1626 sub _CCLASS { my $self = shift;
1627     my $cc = shift;
1628
1629     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1630     my $P = $self->{_pos};
1631     my $char = substr($::ORIG, $P, 1);
1632     if ($char =~ /$cc/) {
1633         my $r = $self->cursor($P+1);
1634         return $r->retm();
1635     }
1636     else {
1637 #        say "CCLASS didn't match $char at $P";
1638         return ();
1639     }
1640 }
1641
1642 sub _CCLASS_rev { my $self = shift;
1643     my $cc = shift;
1644
1645     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1646     my $from = $self->{_pos} - 1;
1647     if ($from < 0) {
1648 #        say "CCLASS didn't match $char at $from";
1649         return ();
1650     }
1651     my $char = substr($::ORIG, $from, 1);
1652     if ($char =~ /$cc/) {
1653         my $r = $self->cursor_rev($from);
1654         return $r->retm();
1655     }
1656     else {
1657 #        say "CCLASS didn't match $char at $from";
1658         return ();
1659     }
1660 }
1661
1662 sub _ANY { my $self = shift;
1663     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1664     my $P = $self->{_pos};
1665     if ($P < @::ORIG) {
1666         $self->cursor($P+1)->retm();
1667     }
1668     else {
1669 #        say "ANY didn't match anything at $P";
1670         return ();
1671     }
1672 }
1673
1674 sub _ANY_rev { my $self = shift;
1675     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1676     my $from = $self->{_pos} - 1;
1677     if ($from < 0) {
1678         return ();
1679     }
1680     return $self->cursor_rev($from)->retm();
1681 }
1682
1683 sub _BOS { my $self = shift;
1684     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1685     my $P = $self->{_pos};
1686     if ($P == 0) {
1687         $self->cursor($P)->retm();
1688     }
1689     else {
1690         return ();
1691     }
1692 }
1693 sub _BOS_rev { $_[0]->_BOS }
1694
1695 sub _BOL { my $self = shift;
1696     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1697     my $P = $self->{_pos};
1698     if ($P == 0 or substr($::ORIG, $P-1, 1) =~ /^[\n\f\x0b\x{2028}\x{2029}]$/) {
1699         $self->cursor($P)->retm();
1700     }
1701     else {
1702         return ();
1703     }
1704 }
1705 sub _BOL_rev { $_[0]->_BOL }
1706
1707 sub _EOS { my $self = shift;
1708     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1709     my $P = $self->{_pos};
1710     if ($P == @::ORIG) {
1711         $self->cursor($P)->retm();
1712     }
1713     else {
1714         return ();
1715     }
1716 }
1717 sub _EOS_rev { $_[0]->_EOS }
1718
1719 sub _EOL { my $self = shift;
1720     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1721     my $P = $self->{_pos};
1722     if ($P == @::ORIG or substr($::ORIG, $P, 1) =~ /^(?:\r\n|[\n\f\x0b\x{2028}\x{2029}])$/) {
1723         $self->cursor($P)->retm();
1724     }
1725     else {
1726         return ();
1727     }
1728 }
1729 sub _EOL_rev { $_[0]->_EOL }
1730
1731 sub _RIGHTWB { my $self = shift;
1732     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1733     my $P = $self->{_pos};
1734     pos($::ORIG) = $P - 1;
1735     if ($::ORIG =~ /\w\b/) {
1736         $self->cursor($P)->retm();
1737     }
1738     else {
1739         return ();
1740     }
1741 }
1742 sub _RIGHTWB_rev { $_[0]->_RIGHTWB }
1743
1744 sub _LEFTWB { my $self = shift;
1745     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1746     my $P = $self->{_pos};
1747     pos($::ORIG) = $P;
1748     if ($::ORIG =~ /\b(?=\w)/) {
1749         $self->cursor($P)->retm();
1750     }
1751     else {
1752         return ();
1753     }
1754 }
1755 sub _LEFTWB_rev { $_[0]->_LEFTWB }
1756
1757 sub _LEFTRESULT { my $self = shift;
1758     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1759     my $P = $self->{_pos};
1760     pos($::ORIG) = $P;
1761     if ($::ORIG =~ /\b(?=\w)/) {
1762         $self->cursor($P)->retm();
1763     }
1764     else {
1765         return ();
1766     }
1767 }
1768 sub _LEFTRESULT_rev { $_[0]->_LEFTWB }
1769
1770 sub _REDUCE { my $self = shift;
1771     my $S = shift;
1772     my $meth = shift;
1773     my $key = $meth;
1774     $key .= ' ' . $_[0] if @_;
1775
1776     $self->{_reduced} = $key;
1777     $self->{_from} = $S;
1778     if ($::ACTIONS) {
1779         eval { $::ACTIONS->$meth($self, @_) };
1780         warn $@ if $@ and not $@ =~ /locate/;
1781     }
1782     $self->deb("REDUCE $key from " . $S . " to " . $self->{_pos}) if DEBUG & DEBUG::matchers;
1783     $self;
1784 }
1785
1786 sub _COMMITBRANCH { my $self = shift;
1787     my $xact = $self->xact;
1788 #    $self->{LAST} = shift() if @_;
1789     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1790     my $P = $self->{_pos};
1791     while ($xact) {
1792         $xact->[-2] = 1;
1793         $self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
1794         return $self->cursor_xact("CB") if $xact->[0] =~ /^ALT/;
1795         $xact = $xact->[-1];
1796     }
1797     die "Not in an alternation, so can't commit to a branch";
1798 }
1799
1800 sub _COMMITLTM { my $self = shift;
1801     my $xact = $self->xact;
1802 #    $self->{LAST} = shift() if @_;
1803     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1804     my $P = $self->{_pos};
1805     while ($xact) {
1806         $xact->[-2] = 1;
1807         $self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
1808         return $self->cursor_xact("CL") if $xact->[0] =~ /^ALTLTM/;
1809         $xact = $xact->[-1];
1810     }
1811     die "Not in a longest token matcher, so can't commit to a longest token";
1812 }
1813
1814 sub _COMMITRULE { my $self = shift;
1815     my $xact = $self->xact;
1816 #    $self->{LAST} = shift() if @_;
1817     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1818     my $P = $self->{_pos};
1819     while ($xact) {
1820         $xact->[-2] = 1;
1821         $self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
1822         return $self->cursor_xact("CR") if $xact->[0] =~ /^RULE/;
1823         $xact = $xact->[-1];
1824     }
1825     die "Not in a rule, so can't commit to rule";
1826 }
1827
1828 sub commit { my $self = shift;
1829     my $xact = $self->xact;
1830 #    $self->{LAST} = shift() if @_;
1831     local $CTX = $self->callm if DEBUG & DEBUG::trace_call;
1832     my $P = $self->{_pos};
1833     while ($xact) {
1834         $xact->[-2] = 1;
1835         $self->deb("Commit $$xact[0] to $P") if DEBUG & DEBUG::matchers;
1836         return $self->cursor_xact("CM") if $xact->[0] =~ /^MATCH/;
1837         $xact = $xact->[-1];
1838     }
1839     die "Not in a match, so can't commit to match";
1840 }
1841
1842 sub fail { my $self = shift;
1843     my $m = shift;
1844     return ();
1845 }
1846
1847 sub bless { CORE::bless $_[1], $_[0]->WHAT }
1848
1849 #############################################################
1850 # JIT lexer generator
1851 #############################################################
1852
1853 ## NFA structure:
1854 ##   array of (NFA node) ->
1855 ##     0: non extensible (imperative) flag
1856 ##     0: array of fate (array of fate element)
1857 ##     array of (label) at odd index, new index at even
1858 ## DFA structure:
1859 ##   each DFA node is array:
1860 ##     0: array of object fates
1861 ##     1: hash of specific cases (char => DFAnode)
1862 ##        also carries some debug data
1863 ##    2n: reference to a uniprop hash
1864 ##  2n+1: DFAnode is that hash existed
1865 ## Labels: undef is epsilon link.
1866 ##   otherwise list - 1 positive, 0+ negative
1867 ##   each is: 1 character, else unicode prop in "Gc/L" form
1868 ## "DFA" lexer structure:
1869 ##   {DFA} -> array of refs to all DFA nodes
1870 ##   {DBA}, {FILE}, {NAME} same as "RE" lexer structure
1871 ##   {S} -> ref to DFA root
1872 ##   {NFA} -> NFA structure
1873 ## individual fates in the NFA end with a hook which can be 1 to stop adding
1874 ## fates on the end; it's not always possible to associate a unique fate with
1875 ## each NFA node, consider (a|b)*
1876 ## A NFA or DFA node is accepting if it has a nonempty list of fates
1877
1878 #cycle breaker
1879 {
1880     package CursorBase::dfa;
1881     sub DESTROY {
1882         my $self = shift;
1883         for (@$self) { @$_ = (); }
1884     }
1885 }
1886
1887 # Steal data from Perl5's Unicode maps
1888 my %unicode_map_cache;
1889 $unicode_map_cache{ALL} = [scalar("\377" x 128) x 1088, "ALL"] ;
1890 sub _get_unicode_map {
1891     my $propname = shift;
1892     $unicode_map_cache{$propname} //= do {
1893         my @top = (("") x 1088, $propname);
1894         for my $l (split("\n", (do "unicore/lib/$propname.pl"))) {
1895             my ($from, $to) = split("\t", $l);
1896             $from = hex $from;
1897             $to = hex $to || $from;
1898
1899             for (my $x = $from; $x <= $to; $x++) {
1900                 vec($top[$x >> 10], $x & 1023, 1) = 1;
1901             }
1902         }
1903         \@top;
1904     };
1905 }
1906
1907 # This is the fast path handling for JIT DFA lexer generation (although it gets
1908 # short-circuited if the DFALEXERS entry exists, later).  The lexer generation
1909 # process sometimes recurses to this, which is tracked using %::AUTOLEXED; if
1910 # the value is already set, we need to suppress recursion.
1911
1912 our $fakepos = 1;
1913
1914 #sub _AUTOLEXpeekDFA { my $self = shift;
1915 #    my $key = shift;
1916 #    my $retree = shift;
1917 #
1918 #    $self->deb("AUTOLEXpeekDFA $key") if DEBUG & DEBUG::autolexer;
1919 #    die "Null key" if $key eq '';
1920 #    if ($::AUTOLEXED{$key}) {   # no left recursion allowed in lexer!
1921 #        die "Left recursion in $key" if $fakepos == $::AUTOLEXED{$key};
1922 #        $self->deb("Suppressing lexer recursion on $key") if DEBUG & DEBUG::autolexer;
1923 #        # Return a faked "immediate imperative" lexer, to end the token
1924 #        # Note that this will only happen from inside RE_ast, so the other stuff
1925 #        # that CursorBase itself uses isn't needed
1926 #        return { NFA => [[1, [[1]]]] };
1927 #    }
1928 #    $key = 'termish' if $key eq 'EXPR';
1929 #    return $::DFALEXERS{ref $self}->{$key} //=
1930 #        $self->_AUTOLEXgenDFA($key, $retree);
1931 #}
1932
1933 sub _dump_nfa { my ($name, $nfa) = @_;
1934     print ::LOG "--- BEGIN NFA DUMP ($name) ---\n";
1935     for my $ix (0 .. @$nfa-1) {
1936         my @go;
1937         for (my $j = 2; $j < @{ $nfa->[$ix] }; $j += 2) {
1938             push @go, "[" . join("-",@{$nfa->[$ix][$j] // []}) . "] => " . $nfa->[$ix][$j+1];
1939         }
1940         my $h = sprintf "%4d: %-30s %s ", $ix, join(", ", @go),
1941             ($nfa->[$ix][0]{I} ? 'I' : ' ');
1942         my @fate = map { my @x = @$_;
1943                          my $y = pop @x;
1944                          push @x, "..." if $y;
1945                          join(" ", "-->", @x) } @{ $nfa->[$ix][1] };
1946         @fate = ('') if !@fate;
1947         for (@fate) {
1948             print ::LOG $h . $_ . "\n";
1949             $h = ' ' x length($h);
1950         }
1951     }
1952     print ::LOG "---- END NFA DUMP ----\n";
1953 }
1954
1955 sub _dtree_dump { my ($ord, $dt) = @_;
1956     print ::LOG ("    " x (2 + $ord));
1957     if (!defined $dt) {
1958         print ::LOG "END\n";
1959     } elsif (ref $dt ne 'ARRAY') {
1960         print ::LOG ($$dt)->[1]{ID}, "\n";
1961     } else {
1962         print ::LOG $dt->[2][-1], "?\n";
1963         _dtree_dump($ord+1, $dt->[1]);
1964         _dtree_dump($ord+1, $dt->[0]);
1965     }
1966 }
1967
1968 sub _dfa_dump_node { my ($dfan) = @_;
1969     my @go;
1970     my @gor = %{ $dfan->[1] };
1971     while (my ($a, $b) = splice @gor, 0, 2) {
1972         next if $a eq 'DESC';
1973         next if $a eq 'ID';
1974         push @go, "'" . ::qm(chr $a) . "' => " . $b->[1]{ID};
1975     }
1976     printf ::LOG "%-30s %-30s\n", $dfan->[1]{DESC} . ":", join(", ", @go);
1977     _dtree_dump(0, $dfan->[2]);
1978     for (@{ $dfan->[0] }) {
1979         my @arr;
1980         for (my $fate = $_; $fate; $fate = $fate->[0]) {
1981             push @arr, $fate->[1], $fate->[2];
1982         }
1983         print ::LOG "    --> ", join(" ", @arr), "\n";
1984     }
1985 }
1986
1987 sub _elem_matches { my ($char, $element) = @_;
1988     if (length($element) == 1) {
1989         return $char eq $element;
1990     } else {
1991         my $i = ord $char;
1992         return vec(_get_unicode_map($element)->[$i >> 10], $i & 1023, 1);
1993     }
1994 }
1995
1996 my %boolean_tables = map { $_, 1 } qw/AHex Alpha BidiC BidiM CE CI CWCF CWCM
1997     CWKCF CWL CWT CWU Cased CompEx DI Dash Dep Dia Ext GrBase GrExt Hex Hyphen
1998     IDC IDS IDSB IDST Ideo JoinC Lower Math NChar NFDQC OAlpha ODI OGrExt OIDC
1999     OIDS OLower OMath OUpper PatSyn PatWS QMark Radical SD STerm Space Term
2000     UIdeo Upper VS XIDC XIDS/;
2001 sub _elem_excludes { my ($up1, $up2) = @_;
2002     my ($t1, $v1) = split "/", $up1;
2003     my ($t2, $v2) = split "/", $up2;
2004
2005     return 0 if $t1 ne $t2;
2006     return 0 if $v1 eq $v2;
2007
2008     return 1 if $boolean_tables{$t1};
2009     return 1 if $t1 eq 'Gc' && (length($v1) == length($v2)
2010         || substr($v1, 0, 1) ne substr($v2, 0, 1));
2011
2012     return 0;
2013 }
2014
2015 sub _elem_implies { my ($up1, $up2) = @_;
2016     my ($t1, $v1) = split "/", $up1;
2017     my ($t2, $v2) = split "/", $up2;
2018
2019     return 0 if $t1 ne $t2;
2020     return 1 if $v1 eq $v2;
2021
2022     return 1 if $t1 eq 'Gc' && substr($v1, 0, 1) eq $v2;
2023
2024     return 0;
2025 }
2026
2027 sub _elem_dich { my ($up1, $up2) = @_;
2028     my ($t1, $v1) = split "/", $up1;
2029     my ($t2, $v2) = split "/", $up2;
2030
2031     return 0 if $t1 ne $t2;
2032     return 0 if $v1 eq $v2;
2033
2034     return 1 if $boolean_tables{$t1};
2035     return 0;
2036 }
2037
2038 #BEGIN {
2039 #    for my $x (\*_elem_implies, \*_elem_excludes, \*_elem_dich) {
2040 #        my $y = \&{$x};
2041 #        my $z = *$x{NAME};
2042 #        *$x = sub {
2043 #            my @args = @_;
2044 #            my $ret = $y->(@args);
2045 #            print STDERR "$z : @args => $ret\n";
2046 #        };
2047 #    }
2048 #}
2049
2050 sub _decision_tree { my ($thunk, @edges) = @_;
2051     my $branch;
2052
2053     TERM: for (my $i = 0; $i < @edges; $i += 2) {
2054         for my $c (@{ $edges[$i] }) {
2055             next if $c eq 'ALL';
2056             $branch = $c;
2057             last TERM;
2058         }
2059     }
2060
2061     if (defined $branch) {
2062         my @true;
2063         my @false;
2064
2065         for (my $i = 0; $i < @edges; $i += 2) {
2066             my ($p, @n) = @{ $edges[$i] };
2067
2068             if (!_elem_excludes($branch, $p) &&
2069                     !(grep { _elem_implies($branch, $_) } @n)) {
2070                 my $pp = _elem_implies($branch, $p) ? 'ALL' : $p;
2071                 my @nn = grep { !_elem_excludes($branch, $_) } @n;
2072                 push @true, [ $pp, @nn ], $edges[$i+1];
2073             }
2074
2075             if (!_elem_implies($p, $branch) &&
2076                     !(grep { _elem_dich($branch, $_) } @n)) {
2077                 my $pp = _elem_dich($branch, $p) ? 'ALL' : $p;
2078                 my @nn = grep { !_elem_implies($_, $branch) } @n;
2079                 push @false, [ $pp, @nn ], $edges[$i+1];
2080             }
2081         }
2082
2083         return [ _decision_tree($thunk, @false),
2084                  _decision_tree($thunk, @true),
2085                  _get_unicode_map($branch) ];
2086     } else {
2087         # all edges are labelled [ALL]
2088         my $bm = "";
2089         for (my $i = 1; $i < @edges; $i += 2) {
2090             vec($bm, $edges[$i], 1) = 1;
2091         }
2092         return ($bm ne '') ? (\ $thunk->($bm)) : undef;
2093     }
2094 }
2095
2096 sub _tangle_edges { my ($our_edges, $thunk) = @_;
2097     my %used_chars;
2098     my %used_cats;
2099
2100     for (my $i = 0; $i < @$our_edges; $i += 2) {
2101         next unless $our_edges->[$i];
2102         for (@{ $our_edges->[$i] }) {
2103             if (length($_) == 1) {
2104                 $used_chars{$_} = 1;
2105             } else {
2106                 $used_cats{$_} = 1;
2107             }
2108         }
2109     }
2110
2111     # First, all specifically mentioned characters are floated to the initial
2112     # case
2113     my %next_1;
2114     for my $ch (keys %used_chars) {
2115         my $bm = "";
2116         EDGE: for (my $i = 0; $i < @$our_edges; $i += 2) {
2117             next unless $our_edges->[$i];
2118             next unless _elem_matches($ch, $our_edges->[$i][0]);
2119             for (my $j = 1; $j < @{ $our_edges->[$i] }; $j++) {
2120                 next EDGE if _elem_matches($ch, $our_edges->[$i][$j]);
2121             }
2122             vec($bm, $our_edges->[$i+1], 1) = 1;
2123         }
2124         $next_1{ord $ch} = $thunk->($bm);
2125     }
2126
2127     # Now clean them out so the decision tree engine doesn't have to deal with
2128     # single characters
2129     $our_edges = [ @$our_edges ];
2130     for (my $i = 0; $i < @$our_edges; ) {
2131         if (!$our_edges->[$i] || length($our_edges->[$i][0]) == 1) {
2132             splice @$our_edges, $i, 2;
2133         } else {
2134             $our_edges->[$i] = [grep { length($_) > 1 } @{ $our_edges->[$i] }];
2135             $i += 2;
2136         }
2137     }
2138
2139     \%next_1, _decision_tree($thunk, @$our_edges);
2140 }
2141
2142 sub _jit_dfa_node { my ($lexer, $node) = @_;
2143     my $nfa2dfa = sub { my $nbm = shift;
2144         $lexer->{NFA2DFA}->{$nbm} //= do {
2145             my @node;
2146             $node[1] = { ID => scalar(@{ $lexer->{DFA} }), BITS => $nbm };
2147             push @{ $lexer->{DFA} }, \@node;
2148             \@node;
2149         }
2150     };
2151
2152     my $bf = $node->[1]{BITS};
2153     my $id = $node->[1]{ID};
2154     my $nfa = $lexer->{NFA};
2155
2156     my %black;
2157     my @nfixes = grep { vec($bf, $_, 1) } (0 .. length($bf)*8 - 1);
2158     my @grey = @nfixes;
2159     my @ouredges;
2160
2161     while (@grey) {
2162         my $nix = pop @grey;
2163         next if $black{$nix};
2164         $black{$nix} = 1;
2165         my $nfn = $nfa->[$nix];
2166
2167         push @{ $node->[0] }, @{ $nfn->[1] };
2168         for (my $i = 2; $i < @$nfn; $i += 2) {
2169             if (!$nfn->[$i]) {
2170                 push @grey, $nfn->[$i+1];
2171             } else {
2172                 push @ouredges, $nfn->[$i], $nfn->[$i+1];
2173             }
2174         }
2175     }
2176
2177     for my $fate (@{ $node->[0] }) {
2178         my @a = reverse @$fate;
2179         my $fo = undef;
2180         my $tb = "";
2181         for (my $i = 1; $i < @a; $i += 3) {
2182             $tb = $a[$i] . $tb;
2183             $fo = [ $fo, $a[$i+2], $a[$i+1] ];
2184         }
2185         $fo = [ $tb, $fo ];
2186         $fate = $fo;
2187     }
2188     @{ $node->[0] } = map { $_->[1] } sort { $b->[0] cmp $a->[0] } @{ $node->[0] };
2189
2190     pop @$node;
2191     push @$node, _tangle_edges(\@ouredges, $nfa2dfa);
2192     $node->[1]{DESC} = $id . "{" . join(",", @nfixes) . "}";
2193     $node->[1]{ID} = $id;
2194
2195     if (DEBUG & DEBUG::autolexer) {
2196         print ::LOG "JIT DFA node generation:\n";
2197         _dfa_dump_node($node);
2198     }
2199
2200     $node->[0];
2201 }
2202
2203 sub _AUTOLEXgenDFA { my ($self, $key, $retree) = @_;
2204     local $::AUTOLEXED{$key} = $fakepos;
2205
2206     my $ast = $retree->{$key};
2207     my $dba = $ast->{dba};
2208
2209     my $d = DEBUG & DEBUG::autolexer;
2210     print ::LOG "generating DFA lexer for $key -->\n" if $d;
2211     my $nfa;
2212
2213     if ($key =~ /(.*):\*$/) {
2214         my $proto = $1;
2215         $dba = $proto;
2216         my $protopat = $1 . '__S_';
2217         my $protolen = length($protopat);
2218         my @pat;
2219         my $j = 0;
2220         my @stack = ref $self;
2221
2222         while (@stack) {
2223             no strict 'refs';
2224             my $class = pop @stack;
2225             push @stack, reverse @{ $class . "::ISA" };
2226             my $stash = \%{ $class . "::" };
2227             my @methods = sort grep {
2228                     substr ($_, 0, $protolen) eq $protopat &&
2229                         substr($_, -6, 6) eq '__PEEK';
2230                 } keys %$stash;
2231             for my $method (@methods) {
2232                 my $callname = $class . '::' . $method;
2233                 $method = substr($method, 0, length($method)-6);
2234                 my $peeklex = $self->$callname();
2235                 die "$proto has no lexer!?" unless $peeklex->{NFA};
2236
2237                 push @pat, ::nfaltmprefate($proto, "${class}::$method",
2238                     $j++, $peeklex->{NFA});
2239             }
2240         }
2241
2242         $nfa = ::nfadisj(@pat);
2243     } elsif ($ast) {
2244         $nfa = $ast->nfa($self);
2245     } else {
2246         die "BAD KEY";
2247     }
2248
2249     die "dba unspecified" unless $dba;
2250
2251     _dump_nfa($key, $nfa) if $d;
2252
2253     my $dfa   = CORE::bless [], 'CursorBase::dfa';
2254     push @$dfa, [ undef, { BITS => "\001", ID => 0 } ];
2255
2256     { DBA => $dba, DFA => $dfa, NFA2DFA => { "\001" => $dfa->[0] },
2257         NFA => $nfa, S => $dfa->[0] };
2258 }
2259
2260 sub lexers { my $self = shift;
2261     my $lang = ref $self;
2262     $self->deb("LANG = $lang") if DEBUG & DEBUG::autolexer;
2263     $::LEXERS{$lang} //= {};
2264 }
2265
2266 sub _AUTOLEXpeek { my $self = shift;
2267     my $key = shift;
2268     my $retree = shift;
2269
2270     $self->deb("AUTOLEXpeek $key") if DEBUG & DEBUG::autolexer;
2271     die "Null key" if $key eq '';
2272     if ($::AUTOLEXED{$key}) {   # no left recursion allowed in lexer!
2273         die "Left recursion in $key" if $fakepos == $::AUTOLEXED{$key};
2274         $self->deb("Suppressing lexer recursion on $key") if DEBUG & DEBUG::autolexer;
2275         return { NFA => [[{I=>1}, [[1]]]] };  # (but if we advanced just assume a :: here)
2276     }
2277     $key = 'termish' if $key eq 'EXPR';
2278     return $::LEXERS{ref $self}->{$key} //= do {
2279         $self->_AUTOLEXgenDFA($key, $retree);
2280     };
2281 }
2282
2283
2284 sub _AUTOLEXgen { my $self = shift;
2285     my $key = shift;
2286     my $retree = shift;
2287
2288     my $lang = ref $self;
2289     if ($lang =~ /^ANON/) {
2290         no strict 'refs';
2291         my $super = join '+', @{ref($self) . '::ISA'};
2292         my $category = ${ref($self) . '::CATEGORY'} // '.';
2293         print ::LOG "AUTOLEXgen $key in $lang from $super without $category\n" if DEBUG & DEBUG::mixins;
2294         my $superlexer = $self->cursor_fresh($super)->_AUTOLEXpeek($key,$retree);
2295         my $same = 1;
2296         for my $pat (@{$superlexer->{PATS}}) {
2297             if ($pat =~ / $category /) {
2298                 print ::LOG "\tNope: $pat\n" if DEBUG & DEBUG::mixins;
2299                 $same = 0;
2300                 last;
2301             }
2302         }
2303         # no need to regen a sublexer that will turn out the same
2304         return $superlexer if $same;
2305     }
2306     $self->deb("AUTOLEXgen $key in $lang") if DEBUG & DEBUG::autolexer;
2307     my $lexer = {};
2308     (my $dir = $::TMP_PREFIX . 'lex::' . $lang) =~ s/::/\//g;
2309     (my $file = $key) =~ s/::/-/g;
2310     $file =~ s/:\*$//;
2311     my $name = $key;
2312     my $dba = $retree->{$key}{dba};
2313     if (not $dba) {
2314         $dba = $name;
2315         $dba =~ s/_0[01]$//;
2316         $dba =~ s/_(\d\d)$/ (alt $1)/;
2317         $dba =~ s/:\*$//;
2318     }
2319
2320     my $cache_key = "$dir/$file.store";
2321     my $cached_lexer = $lexer_cache{$cache_key};
2322     if ($STORABLE and -e $cache_key) {
2323         my $lexer;
2324         if ($cached_lexer) {
2325             #Cache hit, Keep them coming ;-)
2326             $lexer = $cached_lexer;
2327 #            say "GOT HERE $cache_key";
2328         }
2329         else {
2330             # Cache miss
2331             $lexer_cache{$cache_key} = $lexer = retrieve($cache_key);
2332         }
2333         my $pat = $lexer->{PATS};
2334         my $fates;
2335         my $i = 0;
2336         for (@$pat) {
2337             my $fstr;
2338             if ( m/\(\?#FATE(\d+) +(.*?)\)/) {
2339                 warn "MISMATCH $i $1" unless $i == $1;
2340                 $fstr = $2;
2341             }
2342             else {
2343                 die "Whoops, no fate in storage";
2344             }
2345             my $fate;
2346             if ($fate = $FATECACHE{$fstr}) {
2347                 $fates->[$i] = $fate;
2348             }
2349             else {
2350                 $FATECACHE{$fstr} = $fate = $fates->[$i] = [0,0,0];
2351                 while ($fstr =~ s/(\S+)\s+(\S+)\s*//) {
2352                     $fate->[1] = $1;
2353                     $fate->[2] = $2;
2354                     if ($fate->[0] = $FATECACHE{$fstr}) {
2355                         last;
2356                     }
2357                     $fate = $fate->[0] //= [0,0,0] if $fstr ne '';
2358                 }
2359             }
2360             $i++;
2361         }
2362         $lexer->{FATES} = $fates;
2363         return $lexer;
2364     }
2365     elsif (open(LEX, "$dir/$file")) {
2366         binmode(LEX, ":utf8");
2367         $self->deb("using cached $dir/$file") if DEBUG & DEBUG::autolexer;
2368
2369         chomp($name = <LEX>);
2370         local $/ = "";
2371         my @para = <LEX>;
2372         close LEX;
2373         my %lexer;
2374         $lexer{NAME} = $name;
2375         $lexer{DBA} = $dba;
2376         $lexer{FILE} = "$dir/$file";
2377         my @pat = split(/\n/, $para[0]);
2378         $lexer{PATS} = \@pat;
2379         my $fates;
2380         my $i = 0;
2381         for (@pat) {
2382             s/\(\?#FATE\d* +(.*?)\)/(?#FATE$i $1)/;
2383             my $fstr = $1;
2384             my $fate = $fates->[$i] = [0,0,0];
2385             while ($fstr =~ s/(\S+)\s+(\S+)\s*//) {
2386                 $fate->[1] = $1;
2387                 $fate->[2] = $2;
2388                 $fate = $fate->[0] = [0,0,0] if $fstr ne '';
2389             }
2390             $i++;
2391         }
2392         $lexer{FATES} = $fates;
2393         eval {
2394             $lexer{T} = Load($para[1]) if $TRIE and @para > 1;
2395         };
2396
2397         return \%lexer;
2398     }
2399     else {
2400         { package RE_base; 1; }
2401         my @pat;
2402         my $oldfakepos = $::AUTOLEXED{$key} // 0;
2403         $::AUTOLEXED{$key} = $fakepos;
2404         my $ast = $retree->{$key};
2405         if ($ast and ref $ast ne 'HASH') {
2406             @pat = $ast->longest($self);
2407         }
2408         else {  # a protomethod, look up all methods it can call
2409             my $proto = $key;
2410             if ($proto =~ s/:\*$//) {
2411                 my $protopat = $proto . '__S_';
2412                 my $protolen = length($protopat);
2413                 my $altnum = 0;
2414                 for my $class ($self->meta->linearized_isa) {
2415                     for my $method (sort $class->meta->get_method_list) {
2416                         if (substr($method,0,$protolen) eq $protopat) {
2417                             next if $method =~ /__PEEK/;
2418                             my $callname = $class . '::' . $method . '__PEEK';
2419                             my $peeklex = $self->$callname();
2420                             if ($peeklex and $peeklex->{PATS}) {
2421                                 my @alts = @{$peeklex->{PATS}};
2422                                 for my $alt (@alts) {
2423                                     $alt .= "\t(?#FATE)" unless $alt =~ /FATE/;
2424                                     $alt =~ s/\(\?#FATE\d*/(?#FATE $proto ${class}::$method/;
2425                                     $altnum++;
2426                                 }
2427                                 push @pat, @alts;
2428                             }
2429                         }
2430                     }
2431                 }
2432             }
2433             else {
2434                 die "BAD KEY $key";
2435             }
2436         }
2437         for (@pat) {
2438             s/(\t\(\?#FATE.*?\))(.*)/$2$1/;
2439             s/(\(\?#::\))+/(?#::)/;
2440         }
2441         my $fates;
2442         my $i = 0;
2443         for (@pat) {
2444             my $fstr;
2445             if ( s/\(\?#FATE\d* +(.*?)\)/(?#FATE$i $1)/) {
2446                 $fstr = $1;
2447             }
2448             else {
2449                 $_ .= "\t(?#FATE$i )";
2450                 $fstr = "";
2451             }
2452             my $fate;
2453             if ($fate = $FATECACHE{$fstr}) {
2454                 $fates->[$i] = $fate;
2455             }
2456             else {
2457                 $FATECACHE{$fstr} = $fate = $fates->[$i] = [0,0,0];
2458                 while ($fstr =~ s/(\S+)\s+(\S+)\s*//) {
2459                     $fate->[1] = $1;
2460                     $fate->[2] = $2;
2461                     if ($fate->[0] = $FATECACHE{$fstr}) {
2462                         last;
2463                     }
2464                     $fate = $fate->[0] //= [0,0,0] if $fstr ne '';
2465                 }
2466             }
2467             $i++;
2468         }
2469         warn "(null pattern for $key)" unless @pat;
2470         my $pat = join("\n", @pat);
2471
2472         $::AUTOLEXED{$key} = $oldfakepos;
2473
2474         my $T;
2475         if ($TRIE) {
2476             $T = {};
2477           PAT:
2478             for my $fnum (0..@pat-1) {
2479                 my ($chars) = $pat[$fnum];
2480                 $chars =~ s/\(\?#::\)//g;
2481                 my @chars;
2482                 my $final = '';
2483                 while ($chars ne '') {
2484                     last if $chars =~ m/^\t/;
2485                     if ($chars =~ s/^\\(\W)([*+?{]?)//) {
2486                         if ($2) {
2487                             $final = "\\$1$2$chars";
2488                             last;
2489                         }
2490                         push(@chars, ord($1));
2491                         next;
2492                     }
2493                     if ($chars =~ s/^(\\\w.*)//) {
2494                         $final = $1;
2495                         last;
2496                     }
2497                     if ($chars =~ /^(\[\S+)/) {
2498                         $final = $1;
2499                         last;
2500                     }
2501                     if ($chars =~ /^(\.\S*)/) {
2502                         $final = $1;
2503                         last;
2504                     }
2505                     if ($chars =~ s/^(.)([*+?{]?)//) {
2506                         if ($2) {
2507                             $final = "$1$2$chars";
2508                             last;
2509                         }
2510                         push(@chars, unpack('U',$1));
2511                         next;
2512                     }
2513                 }
2514                 my $state = $T;
2515                 for my $ch (@chars) {
2516                     my $char = chr($ch);
2517                     if (my $next = $state->{$char}) {
2518                         $state = $next;
2519                     }
2520                     else {
2521                         $state = $state->{$char} = {};
2522                     }
2523                 }
2524                 push @{$state->{'~~'}}, $final, $fnum;
2525             }
2526         }
2527
2528
2529         $lexer = { "NAME" => $name, "FILE" => "$dir/$file", "PATS" => [@pat], "FATES" => $fates, "T" => $T, "DBA" => $dba};
2530
2531         return $lexer if $lang =~ /ANON/;
2532
2533         if (not -d $dir) {
2534             use File::Path 'mkpath';
2535             mkpath($dir);
2536         }
2537        if ($STORABLE) {
2538             delete $lexer->{FATES};
2539             store($lexer, "$dir/$file.store");
2540             $lexer->{FATES} = $fates;
2541             if ($file eq 'termish') {
2542                 copy("$dir/termish.store","$dir/EXPR.store")
2543                 or croak "Could not copy $dir/termish.store";
2544             }
2545         }
2546
2547         open(my $cache, '>:utf8', "$dir/$file") // die "Can't print: $!";
2548         print $cache $name,"\n";
2549         print $cache join("\n",@pat),"\n\n" or die "Can't print: $!";
2550         print $cache Dump($T) if $T and not $STORABLE;
2551         close($cache) or die "Can't close: $!";
2552         $self->deb("regenerated $dir/$file") if DEBUG & DEBUG::autolexer;
2553         # force operator precedence method to look like a term
2554         if ($file eq 'termish') {
2555             copy("$dir/termish","$dir/EXPR")
2556             or croak "Could not copy $dir/termish";
2557         }
2558     }
2559     $lexer;
2560 }
2561
2562 #############################################################
2563 # Parser service routines
2564 #############################################################
2565
2566 sub O {
2567     my $self = shift;
2568     my %args = @_;
2569     @$self{keys %args} = values %args;
2570     $self;
2571 }
2572
2573 sub Opairs {
2574     my $self = shift;
2575     my $O = $self->{O} or return ();
2576     my @ret;
2577     for (my ($k,$v) = each %$O) {
2578         push @ret, $k, $v;
2579     }
2580     @ret;
2581 }
2582
2583 sub gettrait {
2584     my $self = shift;
2585     my $traitname = shift;
2586     my $param = shift;
2587     my $text;
2588     if (@$param) {
2589         $text = $param->[0]->Str;
2590         $text =~ s/^<(.*)>$/$1/ or
2591         $text =~ s/^\((.*)\)$/$1/;
2592     }
2593     if ($traitname eq 'export') {
2594         if (defined $text) {
2595             $text =~ s/://g;
2596         }
2597         else {
2598             $text = 'DEFAULT';
2599         }
2600         $self->set_export($text);
2601         $text;
2602     }
2603     elsif (defined $text) {
2604         $text;
2605     }
2606     else {
2607         1;
2608     }
2609 }
2610
2611 sub set_export {
2612     my $self = shift;
2613     my $text = shift;
2614     my $textpkg = $text . '::';
2615     my $name = $::DECLARAND->{name};
2616     my $xpad = $STD::ALL->{ (delete $::DECLARAND->{xpad})->[0] };
2617     $::DECLARAND->{export} = $text;
2618     my $sid = $::CURPAD->idref;
2619     my $x = $xpad->{'EXPORT::'} //= Stash::->new( 'PARENT::' => $sid, '!id' => [$sid->[0] . '::EXPORT'] );
2620     $x->{$textpkg} //= Stash::->new( 'PARENT::' => $x->idref, '!id' => [$sid->[0] . '::EXPORT::' . $text] );
2621     $x->{$textpkg}->{$name} = $::DECLARAND;
2622     $x->{$textpkg}->{'&'.$name} = $::DECLARAND
2623             if $name =~ /^\w/ and $::IN_DECL ne 'constant';
2624     $self;
2625 }
2626
2627 sub mixin {
2628     my $self = shift;
2629     my $WHAT = ref($self)||$self;
2630     my @mixins = @_;
2631
2632     my $NEWWHAT = $WHAT . '::';
2633     my @newmix;
2634     for my $mixin (@mixins) {
2635         my $ext = ref($mixin) || $mixin;
2636         push @newmix, $ext;
2637         $ext =~ s/(\w)\w*::/$1/g;       # just looking for a "cache" key, really
2638         $NEWWHAT .= '_X_' . $ext;
2639     }
2640     $self->deb("mixin $NEWWHAT from $WHAT @newmix") if DEBUG & DEBUG::mixins;
2641     no strict 'refs';
2642     if (not exists &{$NEWWHAT.'::meta'}) {              # never composed this one yet?
2643         # fake up mixin with MI, being sure to put "roles" in front
2644         my $eval = "package $NEWWHAT; use Moose ':all' => { -prefix => 'moose_' };  moose_extends('$WHAT'); moose_with(" . join(',', map {"'$_'"} @newmix) . ");our \$CATEGORY = '.';\n";
2645         $self->deb($eval) if DEBUG & DEBUG::mixins;
2646         eval $eval;
2647         warn $@ if $@;
2648     }
2649     return $self->cursor_fresh($NEWWHAT);
2650 }
2651
2652 sub tweak {
2653     my $self = shift;
2654     my $class = ref $self;
2655     no strict 'refs';
2656     for (;;) {
2657         my $retval = eval {
2658             $self->deb("Calling $class" . '::multitweak') if DEBUG & DEBUG::mixins;
2659             &{$class . '::multitweak'}($self,@_);
2660         };
2661         return $retval if $retval;
2662         die $@ unless $@ =~ /^NOMATCH|^Undefined subroutine/;
2663         last unless $class =~ s/(.*)::.*/$1/;
2664     }
2665 }
2666
2667 sub clean_id { my $self = shift;
2668     my ($id,$name) = @_;
2669     my $file = $::FILE->{name};
2670
2671     $id .= '::';
2672     $id =~ s/^MY:file<CORE.setting>.*?::/CORE::/;
2673     $id =~ s/^MY:file<\w+.setting>.*?::/SETTING::/;
2674     $id =~ s/^MY:file<\Q$file\E>$/UNIT/;
2675     $id =~ s/:pos\(\d+\)//;
2676     $id .= "<$name>";
2677     $id;
2678 }
2679
2680 # remove consistent leading whitespace (mutates text nibbles in place)
2681
2682 sub trim_heredoc { my $doc = shift;
2683     my ($stopper) = $doc->stopper or
2684         $doc->panic("Couldn't find delimiter for heredoc\n");
2685     my $ws = $stopper->{ws}->Str;
2686     return $stopper if $ws eq '';
2687
2688     my $wsequiv = $ws;
2689     $wsequiv =~ s{^(\t+)}[' ' x (length($1) * ($::TABSTOP // 8))]xe;
2690
2691     # We can't use ^^ after escapes, since the escape may be mid-line
2692     # and we'd get false positives.  Use a fake newline instead.
2693     $doc->{nibbles}[0] =~ s/^/\n/;
2694
2695     for (@{$doc->{nibbles}}) {
2696         next if ref $_;   # next unless $_ =~ Str;
2697
2698         # prefer exact match over any ws
2699         s{(?<=\n)(\Q$ws\E|[ \t]+)}{
2700             my $white = $1;
2701             if ($white eq $ws) {
2702                 '';
2703             }
2704             else {
2705                 $white =~ s[^ (\t+) ][ ' ' x (length($1) * ($::TABSTOP // 8)) ]xe;
2706                 if ($white =~ s/^\Q$wsequiv\E//) {
2707                     $white;
2708                 }
2709                 else {
2710                     '';
2711                 }
2712             }
2713         }eg;
2714     }
2715     $doc->{nibbles}[0] =~ s/^\n//;  # undo fake newline
2716     $stopper;
2717 }
2718
2719 sub add_categorical { my $lang = shift;
2720     my $name = shift;
2721     state $GEN = "500";
2722     $name =~ s/:<<(.*)>>$/:«$1»/;
2723     my $WHAT = ref $lang;
2724
2725     # :() is a signature modifier, not an operator
2726     if ($name =~ /^\w+:\(/) {
2727         # XXX canonicalize sig here eventually
2728         $lang->add_my_name($name);
2729         return $lang;
2730     }
2731
2732     if ($name =~ s/^(\w+):(?=[«<{[])/$1:sym/) {
2733         my $cat = $1;
2734         my ($sym) = $name =~ /:sym(.*)/;
2735         $sym =~ s/^<\s*(.*\S)\s*>$/<$1>/g;
2736         $sym =~ s/^\[\s*(.*\S)\s*\]$/$1/g;
2737         if ( $sym =~ s/\\x\[(.*)\]/\\x{$1}/g) {
2738             $sym = '«' . eval($sym) . '»';
2739         }
2740         elsif ($sym =~ s/\\c\[(.*)\]/\\N{$1}/g ) {
2741             $sym = '«' . eval("use charnames ':full'; $sym") . '»';
2742         }
2743
2744         # unfortunately p5 doesn't understand q«...»
2745         if ($sym =~ s/^«\s*(.*\S)\s*»$/$1/) {
2746             my $ok = "'";
2747             for my $try (qw( ' / ! : ; | + - = )) {
2748                 $ok = $try, last if index($sym,$try) < 0;
2749             }
2750             $sym = $ok . $sym . $ok;
2751         }
2752         {
2753             my $canon = substr($sym,1,length($sym)-2);
2754             $canon =~ s/([<>])/\\$1/g;
2755             my $canonname = $cat . ':<' . $canon . '>';
2756             $lang->add_my_name($canonname);
2757         }
2758         if ($sym =~ / /) {
2759             $sym = '[qw' . $sym . ']';
2760         }
2761         else {
2762             $sym = 'q' . $sym;
2763         }
2764
2765         my $rule = "token $name { <sym> }";
2766
2767         # produce p5 method name
2768         my $mangle = $name;
2769         $mangle =~ s/^(\w*):(sym)?//;
2770         my $category = $1;
2771         my @list;
2772         if ($mangle =~ s/^<(.*)>$/$1/ or
2773             $mangle =~ s/^«(.*)»$/$1/) {
2774             $mangle =~ s/\\(.)/$1/g;
2775             @list = $mangle =~ /(\S+)/g;
2776         }
2777         elsif ($mangle =~ s/^\[(.*)\]$/$1/ or
2778             $mangle =~ s/^\{(.*)\}$/$1/) {
2779             $mangle =~ s/\\x\[(.*)\]/\\x{$1}/g;
2780             @list = eval $mangle;
2781         }
2782         elsif ($mangle =~ m/^\(\"(.*)\"\)$/) {
2783             @list = eval $sym;
2784         }
2785         else {
2786             @list = $mangle;
2787         }
2788         $mangle = ::mangle(@list);
2789         $mangle = $category . '__S_' . sprintf("%03d",$GEN++) . $mangle;
2790
2791         # XXX assuming no equiv specified, but to do that right,
2792         # this should be delayed till the block start is seen
2793         my $coercion = '';
2794         if ($name =~ /^infix:/) {
2795             $coercion = 'additive';
2796         }
2797         elsif ($name =~ /^prefix:/) {
2798             if ($sym =~ /^.\W/) {
2799                 $coercion = 'symbolic_unary';
2800             }
2801             else {
2802                 $coercion = 'named_unary';
2803             }
2804         }
2805         elsif ($name =~ /^postfix:/) {
2806             $coercion = 'methodcall';
2807         }
2808         elsif ($name =~ /^circumfix:/) {
2809             $coercion = 'term';
2810         }
2811         elsif ($name =~ /^postcircumfix:/) {
2812             $coercion = 'methodcall';
2813         }
2814         elsif ($name =~ /^term:/) {
2815             $coercion = 'term';
2816         }
2817
2818         state $genpkg = 'ANON000';
2819         $genpkg++;
2820         my $e;
2821         if (@list == 1) {
2822             $e = <<"END";
2823 package $genpkg;
2824 use Moose ':all' => { -prefix => 'moose_' };
2825 moose_extends('$WHAT');
2826
2827 # $rule
2828
2829 my \$retree = {
2830     '$mangle' => bless({
2831         'kind' => 'token',
2832         'min' => 12345,
2833         're' => bless({
2834             'a' => 0,
2835             'i' => 0,
2836             'min' => 12345,
2837             'name' => 'sym',
2838             'rest' => '',
2839             'sym' => $sym,
2840         }, 'RE_method'),
2841     }, 'RE_ast'),
2842 };
2843
2844 our \$CATEGORY = '$category';
2845
2846 sub ${mangle}__PEEK { \$_[0]->_AUTOLEXpeek('$mangle',\$retree) }
2847 sub $mangle {
2848     my \$self = shift;
2849     local \$CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
2850     my %args = \@_;
2851     my \$sym = \$args{sym} // $sym;
2852
2853     my \$xact = ['RULE $mangle', 0, \$::XACT];
2854     local \$::XACT = \$xact;
2855
2856     my \$S = \$self->{_pos};
2857     my \$C = \$self->cursor_xact("RULE $mangle \$S");
2858 #    my \$xact = \$C->xact;
2859
2860     \$C->{'sym'} = \$sym;
2861
2862     \$self->_MATCHIFY(\$S, '$mangle',
2863         do {
2864             if (my (\$C) = (\$C->_SYM(\$sym, 0))) {
2865                 \$C->_SUBSUMEr(['O'], sub {
2866                     my \$C = shift;
2867                     \$C->O(%STD::$coercion)
2868                 });
2869             }
2870             else {
2871                 ();
2872             }
2873         }
2874     );
2875 }
2876 1;
2877 END
2878         }
2879         else {
2880             for (@list) {
2881                 if (/'/) {
2882                     s/(.*)/"$1"/;
2883                 }
2884                 else {
2885                     s/(.*)/'$1'/;
2886                 }
2887             }
2888             my $starter = $list[0];
2889             my $stopper = $list[1];
2890
2891             $e = <<"END";
2892 package $genpkg;
2893 use Moose ':all' => { -prefix => 'moose_' };
2894 moose_extends('$WHAT');
2895
2896 # $rule
2897
2898 my \$retree = {
2899  '$mangle' => bless({
2900   'kind' => 'token',
2901   'min' => 12347,
2902   'pkg' => undef,
2903   're' =>  bless({
2904     'decl' => [],
2905     'a' => 0,
2906     'dba' => '$category expression',
2907     'i' => 0,
2908     'min' => 12347,
2909     'r' => 1,
2910     's' => 0,
2911     'zyg' => [
2912         bless({
2913           'a' => 0,
2914           'dba' => '$category expression',
2915           'i' => 0,
2916           'min' => 1,
2917           'r' => 1,
2918           's' => 0,
2919           'text' => $starter,
2920         }, 'RE_string'),
2921         bless({
2922           'a' => 0,
2923           'dba' => '$category expression',
2924           'i' => 0,
2925           'min' => 0,
2926           'r' => 1,
2927           's' => 0,
2928           'text' => ':',
2929         }, 'RE_meta'),
2930         bless({
2931           'a' => 0,
2932           'dba' => '$category expression',
2933           'i' => 0,
2934           'min' => 12345,
2935           'name' => 'semilist',
2936           'r' => 1,
2937           'rest' => '',
2938           's' => 0,
2939         }, 'RE_method'),
2940         bless({
2941           'decl' => [],
2942           'min' => 1,
2943           're' =>  bless({
2944             'a' => 0,
2945             'dba' => '$category expression',
2946             'i' => 0,
2947             'min' => 1,
2948             'r' => 1,
2949             's' => 0,
2950             'zyg' => [
2951                 bless({
2952                   'a' => 0,
2953                   'dba' => '$category expression',
2954                   'i' => 0,
2955                   'min' => 1,
2956                   'r' => 1,
2957                   's' => 0,
2958                   'text' => ')',
2959                 }, 'RE_string'),
2960                 bless({
2961                   'min' => 0,
2962                   'name' => 'FAILGOAL',
2963                   'nobind' => 1,
2964                 }, 'RE_method'),
2965             ],
2966           }, 'RE_first'),
2967         }, 'RE_bracket'),
2968         bless({
2969           'min' => 0,
2970           'name' => 'O',
2971           'rest' => '(|%term)',
2972         }, 'RE_method'),
2973     ],
2974   }, 'RE_sequence'),
2975  }, 'RE_ast'),
2976 };
2977
2978 our \$CATEGORY = '$category';
2979
2980 sub ${mangle}__PEEK { \$_[0]->_AUTOLEXpeek('$mangle',\$retree) }
2981 sub $mangle {
2982     no warnings 'recursion';
2983     my \$self = shift;
2984     local \$::CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
2985     my %args = \@_;
2986     local \$::sym = \$args{sym} // $sym;
2987     return () if \$::GOAL eq $starter;
2988
2989     my \$C = \$self->cursor_xact("RULE $mangle");
2990     my \$xact = \$C->xact;
2991     my \$S = \$C->{'_pos'};
2992     \$C->{'sym'} = ref \$sym ? join(' ', \@\$sym) : \$sym;
2993
2994     \$self->_MATCHIFYr(\$S, "$mangle",
2995     do {
2996       if (my (\$C) = (\$C->_EXACT($starter))) {
2997         do {
2998           if (my (\$C) = (((local \$::GOAL = $stopper , my \$goalpos = \$C), \$C)[-1])) {
2999             do {
3000               if (my (\$C) = (\$C->_SUBSUMEr(['semilist'], sub {
3001                 my \$C = shift;
3002                 \$C->semilist
3003               }))) {
3004                 do {
3005                   if (my (\$C) = (\$C->_BRACKETr(sub {
3006                   my \$C=shift;
3007                   do {
3008                     my \$C = \$C->cursor_xact('ALT ||');
3009                     my \$xact = \$C->xact;
3010                     my \@gather;
3011                     do {
3012                       push \@gather, \$C->_EXACT($stopper)
3013                     }
3014                     or \$xact->[-2] or
3015                     do {
3016                       push \@gather, \$C->FAILGOAL($stopper , '$category expression',\$goalpos)};
3017                     \@gather;
3018                   }
3019                 }))) {
3020                     \$C->_SUBSUMEr(['O'], sub {
3021                         my \$C = shift;
3022                         \$C->O(%STD::$coercion)
3023                       });
3024                   }
3025                   else {
3026                     ();
3027                   }
3028                 };
3029               }
3030               else {
3031                 ();
3032               }
3033             };
3034           }
3035           else {
3036             ();
3037           }
3038         };
3039       }
3040       else {
3041         ();
3042       }
3043     }
3044     );
3045 }
3046
3047 1;
3048 END
3049         }
3050         $lang->deb("derive $genpkg from $WHAT adding $mangle") if DEBUG & DEBUG::mixins;
3051         eval $e or die "Can't create $name: $@\n";
3052         $::LANG{'MAIN'} = $lang->cursor_fresh($genpkg);
3053         my $oldlexer = $::LEXERS{$WHAT};
3054         my $newlexer = $::LEXERS{$genpkg} //= {};
3055         print ::LOG "=====================================\nADD $rule => $mangle\n" if DEBUG & DEBUG::mixins;;
3056         for my $name (sort keys %{$oldlexer}) {
3057             print ::LOG "  $name:\n" if DEBUG & DEBUG::mixins;
3058             my $same = 1;
3059             for my $pat (@{$oldlexer->{$name}->{PATS}}) {
3060                 if ($pat =~ / $category /) {
3061                     print ::LOG "\t$pat\n" if DEBUG & DEBUG::mixins;
3062                     $same = 0;
3063                     last;
3064                 }
3065             }
3066             # no need to regen a sublexer that will turn out the same
3067             $newlexer->{$name} = $oldlexer->{$name} if $same;
3068         }
3069     }
3070     $lang;
3071 }
3072
3073 sub add_enum { my $self = shift;
3074     my $type = shift;
3075     my $expr = shift;
3076     return unless $type;
3077     return unless $expr;
3078     my $typename = $type->Str;
3079     local $::IN_DECL = 'constant';
3080     # XXX complete kludge, really need to eval EXPR
3081     $expr =~ s/:(\w+)<\S+>/$1/g;  # handle :name<string>
3082     for ($expr =~ m/([a-zA-Z_]\w*)/g) {
3083         $self->add_name($typename . "::$_");
3084         $self->add_name($_);
3085     }
3086     $self;
3087 }
3088
3089 sub do_use { my $self = shift;
3090     my $module = shift;
3091     my $args = shift;
3092     my @imports;
3093
3094     $self->do_need($module);
3095     $self->do_import($module,$args);
3096     $self;
3097 }
3098
3099 sub do_need { my $self = shift;
3100     my $m = shift;
3101     my $module = $m->Str;
3102     my $modfile = $module;
3103     my $topsym;
3104     my $lib = '.';
3105     my $std = -x 'std' ? './std' : 'std';
3106     if (not @::PERL6LIB) {
3107         if ($ENV{PERL6LIB}) {
3108             @::PERL6LIB = split ':', $ENV{PERL6LIB}
3109         }
3110         else {
3111             @::PERL6LIB = qw( ./lib . );
3112         }
3113     }
3114     $modfile =~ s/::/\//g;
3115     my $ext = '';
3116     for my $d (@::PERL6LIB) {
3117         if (-f "$d/$modfile.pm6") {
3118             $ext = '.pm6';
3119             $lib = $d;
3120             last;
3121         }
3122         elsif (-f "$d/$modfile.pm") {
3123             {
3124                 local $/;
3125                 open PM, "$d/$modfile.pm" or next;
3126                 my $pm = <PM>;
3127                 close PM;
3128                 next if $pm =~ /^\s*package\s+\w+\s*;/m; # ignore p5 code
3129             }
3130             $ext = '.pm';
3131             $lib = $d;
3132             last;
3133         }
3134     }
3135     my $syml = $::TMP_PREFIX . 'syml';
3136     mkdir $syml unless -d $syml;
3137     if (not $ext) {
3138         $ext = '.pm';
3139         $ext = '.pm6' unless -f "$syml/$modfile$ext.syml";
3140         if (-f "$syml/$modfile$ext.syml") {
3141             $topsym = LoadFile("$syml/$modfile$ext.syml");
3142             $self->worry("Can't locate module $module, only its symbol table file");
3143         }
3144         else {
3145             $self->worry("Can't locate module $module");
3146         }
3147     }
3148     elsif (-f "$syml/$modfile$ext.syml" and -M "$lib/$modfile$ext" > -M "$syml/$modfile$ext.syml") {
3149         $topsym = LoadFile("$syml/$modfile$ext.syml");
3150     }
3151     elsif (-f "$lib/$modfile$ext") {
3152         # say "$std $lib/$module$ext";
3153         system "$std $lib/$module$ext" and die "Can't compile $lib/$module$ext";
3154         $topsym = LoadFile("$syml/$modfile$ext.syml");
3155     }
3156     else {
3157         $self->worry("Module $module disappeared during load");
3158     }
3159     $self->add_my_name($module);
3160     $::DECLARAND->{really} = $topsym;
3161     $self;
3162 }
3163
3164 sub do_import { my $self = shift;
3165     my $m = shift;
3166     my $args = shift;
3167     my @imports;
3168     my $module = $m->Str;
3169     if ($module =~ /(class|module|role|package)\s+(\S+)/) {
3170         $module = $2;
3171     }
3172
3173     my $pkg = $self->find_stash($module);
3174     if ($pkg->{really}) {
3175         $pkg = $pkg->{really}->{UNIT};
3176     }
3177     else {
3178         $pkg = $self->find_stash($module . '::');
3179     }
3180     if ($args) {
3181         my $text = $args->Str;
3182         return $self unless $text;
3183         while ($text =~ s/^\s*:?(OUR|MY|STATE|HAS|AUGMENT|SUPERSEDE)?<(.*?)>,?//) {
3184             my $scope = lc($1 // 'my');
3185             my $imports = $2;
3186             local $::SCOPE = $scope;
3187             @imports = split ' ', $imports;
3188             for (@imports) {
3189                 if ($pkg) {
3190                     if ($_ =~ s/^://) {
3191                         my @tagimports;
3192                         eval { @tagimports = keys %{ $pkg->{'EXPORT::'}->{$_} }; };
3193                         $self->do_import_aliases($pkg, @tagimports);
3194                     }
3195                     elsif ($pkg->{$_}{export}) {
3196                         $self->add_my_name($_, $pkg->{$_});
3197                     }
3198                     elsif ($pkg->{'&'.$_}{export}) {
3199                         $_ = '&' . $_;
3200                         $self->add_my_name($_, $pkg->{$_});
3201                     }
3202                     elsif ($pkg->{$_}) {
3203                         $self->worry("Can't import $_ because it's not exported by $module");
3204                         next;
3205                     }
3206                 }
3207                 else {
3208                     $self->add_my_name($_);
3209                 }
3210             }
3211         }
3212     }
3213     else {
3214         return $self unless $pkg;
3215         eval { @imports = keys %{ $pkg->{'EXPORT::'}->{'DEFAULT::'} }; };
3216         local $::SCOPE = 'my';
3217         $self->do_import_aliases($pkg, @imports);
3218     }
3219
3220     $self;
3221 }
3222
3223 sub do_import_aliases {
3224     my $self = shift;
3225     my $pkg = shift;
3226 #    say "attempting to import @_";
3227     for (@_) {
3228         next if /^!/;
3229         next if /^PARENT::/;
3230         next if /^OUTER::/;
3231         $self->add_my_name($_, $pkg->{$_});
3232     }
3233     $self;
3234 }
3235
3236 sub canonicalize_name { my $self = shift;
3237     my $name = shift;
3238     $name =~ s/^([\$\@\%\&])(\^|:(?!:))/$1/;
3239     $name =~ s/\b:[UD_]$//;
3240     return $name unless $name =~ /::/;
3241     $self->panic("Can't canonicalize a run-time name at compile time: $name") if $name =~ /::\(/;
3242     $name =~ s/^([\$\@%&][!*=?:^.]?)(.*::)(.*)$/$2<$1$3>/;
3243     my $vname;
3244     if ($name =~ s/::<(.*)>$//) {
3245         $vname = $1;
3246     }
3247     my @components = split(/(?<=::)/, $name, -1);
3248     shift(@components) while @components and $components[0] eq '';
3249     if (defined $vname) {
3250         $components[-1] .= '::' if @components and $components[-1] !~ /::$/;
3251         push(@components, $vname) if defined $vname;
3252     }
3253     @components;
3254 }
3255
3256 sub lookup_dynvar { my $self = shift;
3257     my $name = shift;
3258     no strict 'refs';
3259     if ($name =~ s/^\$\?/::/) {
3260         return $$name if defined $$name;
3261     }
3262     elsif ($name =~ s/^\@\?/::/) {
3263         return \@$name if defined *$name{ARRAY};
3264     }
3265     elsif ($name =~ s/^\%\?/::/) {
3266         return \%$name if defined *$name{HASH};
3267     }
3268     return
3269 }
3270
3271 sub mark_sinks { my $self = shift;
3272     my $statements = shift;
3273     return $self unless @$statements;
3274     my @s = @$statements;
3275     my $final = pop(@s);
3276     for my $s (@s) {
3277         if ($s->is_pure) {
3278             $self->worry("Useless use of " . $s->Str . " in sink context");
3279         }
3280         $s->{_pure} = 1;   # nothing is pure :)
3281         $s->{_sink} = 1;
3282     }
3283     $self;
3284 }
3285
3286 sub is_pure { my $self = shift;
3287     return 1 if $self->{_pure};
3288     # visit kids here?
3289     return 0;
3290 }
3291
3292 sub check_old_cclass { my $self = shift;
3293     my $innards = shift;
3294
3295     my $prev = substr($::ORIG,$self->{_pos}-length($innards)-4,2);
3296     return $self if $prev =~ /=\s*$/;       # don't complain on $var = [\S] capture
3297
3298     my $cclass = '';
3299     my $single = '';
3300     my $singleok = 1;
3301     my $double = '';
3302     my $doubleok = 1;
3303
3304     my $last = '';
3305     my %seen;
3306
3307     my $i = $innards;
3308     my $neg = '';
3309     $neg = '-' if $i =~ s/^\^//;
3310     my $digits = 0;
3311     $i =~ s/0-9/\\d/;
3312     while ($i ne '') {
3313         if ($i =~ s/^-(.)/$1/) {
3314             $singleok = $doubleok = 0;
3315             $cclass .= $last ? '..' : '\\-';
3316             $last = '';
3317         }
3318         elsif ($i =~ /^\|./ and $cclass ne '') {
3319             return $self;       # probable alternation
3320         }
3321         elsif ($i =~ s/^\|//) {
3322             $last = '';
3323             $singleok = $doubleok = 0;
3324             $cclass .= '|';
3325         }
3326         elsif ($i =~ /^[*+?]/ and $cclass ne '') {
3327             return $self;       # probable quantifier
3328         }
3329         elsif ($i =~ s/^\\?'//) {
3330             $last = "'";
3331             $single .= '\\' . $last;
3332             $double .= $last;
3333             $cclass .= $last;
3334         }
3335         elsif ($i =~ s/^\\?"//) {
3336             $last = '"';
3337             $single .= $last;
3338             $double .= '\\' . $last;
3339             $cclass .= $last;
3340         }
3341         elsif ($i =~ s/^(\\[btnrf0])//) {
3342             $last = eval '"' . $1 . '"';
3343             $single .= $last;
3344             $double .= $1;
3345             $cclass .= $1;
3346         }
3347         elsif ($i =~ s/(\\x\w\w)//) {
3348             $last = eval '"' . $1 . '"';
3349             $single .= $last;
3350             $double .= $1;
3351             $cclass .= $1;
3352         }
3353         elsif ($i =~ s/(\\0[0-7]{1,3})//) {
3354             $last = eval '"' . $1 . '"';
3355             $single .= $last;
3356             $double .= "\\o" . substr($1,1);
3357             $cclass .= "\\o" . substr($1,1);
3358         }
3359         elsif ($i =~ s/^(\\[sSwWdD])//) {
3360             $singleok = $doubleok = 0;
3361             $last = '';
3362             $cclass .= $1;
3363         }
3364         elsif ($i =~ s/^(\\?\t)//) {
3365             $last = "\t";
3366             $single .= $last;
3367             $double .= '\\t';
3368             $cclass .= '\\t';
3369         }
3370         elsif ($i =~ s/^(\\?\x20)//) {
3371             $last = ' ';
3372             $single .= $last;
3373             $double .= $last;
3374             $cclass .= '\\x20';
3375         }
3376         elsif ($i =~ s/^\.//) {
3377             $last = '.';
3378             $singleok = $doubleok = 0;
3379             $cclass .= '.';
3380         }
3381         elsif ($i =~ s/^\\(.)//) {
3382             $last = $1;
3383             $single .= $last;
3384             $double .= '\\' . $last;
3385             $cclass .= '\\' . $last;
3386         }
3387         elsif ($i =~ s/^(.)//s) {
3388             $last = $1;
3389             $cclass .= $last;
3390             $single .= $last;
3391             $double .= $last;
3392         }
3393         else {
3394             die "can't happen";
3395         }
3396
3397         if ($last ne '' and $seen{$last}++) {
3398             return $self;       # dup likely indicates not a character class
3399         }
3400     }
3401
3402     my $common = "[$innards] appears to be an old-school character class;";
3403
3404     # XXX not Unicodey yet
3405     if ($neg) {
3406         return $self->worry("$common non-digits should be matched with \\D instead") if $cclass eq '\\d';
3407         return $self->worry("$common non-newlines should be matched with \\N instead") if $cclass eq '\\n';
3408         if ($singleok) {
3409             return $self->worry("$common non-(horizontal whitespace) should be matched with \\H instead") if $single =~ /\A[ \t\b\r]*\z/;
3410             return $self->worry("$common non-(vertical whitespace) should be matched with \\V instead") if $single =~ /\A[\n\f]*\z/;
3411             return $self->worry("$common non-whitespace should be matched with \\S instead") if $single =~ /\A[ \t\b\r\n\f]*\z/;
3412             return $self->worry("$common please use <-[$cclass]> if you mean a character class");
3413         }
3414         elsif ($doubleok) {
3415             return $self->worry("$common please use <-[$cclass]> if you mean a character class");
3416         }
3417     }
3418     else {
3419         return $self->worry("$common digits should be matched with \\d instead") if $cclass eq '\\d';
3420         if ($singleok) {
3421             return $self->worry("$common horizontal whitespace should be matched with \\h instead") if $single =~ /\A[ \t\b\r]*\z/;
3422             return $self->worry("$common vertical whitespace should be matched with \\v instead") if $single =~ /\A[\n\f]*\z/;
3423             return $self->worry("$common whitespace should be matched with \\s instead") if $single =~ /\A[ \t\b\r\n\f]*\z/;
3424         }
3425         if ($singleok and $single eq $double) {
3426             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");
3427         }
3428         elsif ($doubleok) {
3429             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");
3430         }
3431     }
3432     if ($::FATALS) {
3433         return $self->worry("$common please use <${neg}[$cclass]> if you mean a character class");
3434     }
3435     else {
3436         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");
3437     }
3438     $self;
3439 }
3440
3441 ## vim: expandtab sw=4