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