Legend:
- Unmodified
- Added
- Removed
-
src/perl6/Cursor.pmc
r22836 r22848 11 11 our $CTX = ''; 12 12 our $DEBUG = $ENV{STD5DEBUG} // 0; 13 $::DEBUG = $DEBUG; 14 15 # various bits of info useful for error messages 16 $::HIGHWATER = 0; 17 $::HIGHMESS = ''; 18 $::HIGHEXPECT = {}; 19 $::COMPILING::LAST_NIBBLE = { firstline => 0, lastline => 0 }; 20 $::COMPILING::LAST_NIBBLE_MULTILINE = { firstline => 0, lastline => 0 }; 21 $::COMPILING::LINE = 1; 22 $::COMPILING::FILE = '(eval)'; 23 $::GOAL = "(eof)"; 13 our $DEPTH = 0; 14 our %LEXERS; # per language, the cache of lexers, keyed by rule name 15 16 sub ::init_globals { 17 $::DEBUG = $DEBUG; 18 $::CTX = ''; 19 $::DEPTH = 0; 20 $::ORIG = ''; 21 @::MEMOS = (); 22 %::LEXERS = (); 23 24 # various bits of info useful for error messages 25 $::HIGHWATER = 0; 26 $::HIGHMESS = ''; 27 $::HIGHEXPECT = {}; 28 $::COMPILING::LAST_NIBBLE = { firstline => 0, lastline => 0 }; 29 $::COMPILING::LAST_NIBBLE_MULTILINE = { firstline => 0, lastline => 0 }; 30 $::COMPILING::LINE = 1; 31 $::COMPILING::FILE = '(eval)'; 32 $::GOAL = "(eof)"; 33 } 24 34 25 35 { package DEBUG; … … 41 51 } 42 52 43 our $DEPTH = 0;44 45 53 sub ::deb { 46 54 print ::LOG @_, "\n"; … … 110 118 my $text = shift; 111 119 my $rule = shift() // 'comp_unit'; 120 ::init_globals(); 121 local $::VOID = 1 if not defined wantarray; 112 122 local $::COMPILING::FILE = '(eval)'; 113 123 $class->new($text)->$rule(); … … 118 128 my $file = shift; 119 129 my $rule = shift() // 'comp_unit'; 130 ::init_globals(); 131 local $::VOID = 1 if not defined wantarray; 120 132 local $::COMPILING::FILE = $file; 121 133 my $text = Encode::decode('utf8', `cat $file`); … … 167 179 use YAML::XS; 168 180 169 our %lexers; # per language, the cache of lexers, keyed by rule name170 171 181 sub from { $_[0]->{_from} // $_[0]->{_pos} } 172 182 sub to { $_[0]->{_pos} } … … 201 211 my $lang = ref $self; 202 212 $self->deb("LANG = $lang") if $DEBUG & DEBUG::autolexer; 203 $ lexers{$lang} //= {};213 $::LEXERS{$lang} //= {}; 204 214 } 205 215 … … 474 484 } 475 485 for (@pats) { 476 s/\(\?#FATE (.*?)\)/(?#$i FATE $1)/ or return sub { return };486 s/\(\?#FATE +(.*?)\)/(?#$i FATE $1)/ or return sub { return }; 477 487 my $fstr = $1; 478 488 my $fate = $fates->[$i] = [0,0,0,$fstr]; … … 764 774 } 765 775 766 sub cleanup {767 my $self = shift;768 delete $self->{_fate};769 $self;770 }771 772 776 sub clean { 773 777 my $self = shift; … … 805 809 my $bindings = shift; 806 810 my $submatch = shift; # this is the submatch's cursor 807 $submatch->cleanup;811 delete $self->{_fate}; 808 812 809 813 $self->deb("cursor_bind @$bindings") if $DEBUG & DEBUG::cursors; … … 821 825 $submatch->{_from} = $r{_from} = $r{_pos}; 822 826 $r{_pos} = $submatch->{_pos}; 823 delete $r{_fate};824 827 CORE::bless \%r, ref $self; # return new match cursor for parent 825 828 } … … 850 853 return $self, $tag, $try, $relex; 851 854 } 855 # else { 856 # warn Dump($fate); 857 # warn "FATE mismatch: $name vs " . $fate->[0] . "\n"; 858 # } 852 859 } 853 860 -
src/perl6/STD.pm
r22836 r22848 13 13 my $ORIG is context; 14 14 my @MEMOS is context; 15 my $VOID is context<rw>; 15 16 16 17 # random rule for debugging, please ignore … … 70 71 # XXX shouldn't need this, it should all be defined/imported by the prelude 71 72 72 my @ typenames = qw[73 my @basetypenames = qw[ 73 74 Object Any Junction Whatever 74 75 Capture Match Signature Proxy Matcher … … 102 103 KitchenSink 103 104 ]; 104 push @typenames, "True", "False", "Bool::True", "Bool::False"; # in quotes lest gimme5 translate them 105 105 push @basetypenames, "True", "False", "Bool::True", "Bool::False"; # in quotes lest gimme5 translate them 106 107 my @typenames; 106 108 my %typenames; 107 %typenames{@typenames} = (1 xx @typenames); 109 110 sub init_types { 111 @PKGS = (); 112 @typenames = @basetypenames; 113 %typenames = (); 114 %typenames{@typenames} = (1 xx @typenames); 115 } 108 116 109 117 method is_type ($name) { … … 124 132 # XXX likewise for routine defs 125 133 126 my @ routinenames = qw[134 my @baseroutinenames = qw[ 127 135 WHAT WHICH VAR 128 136 any all none one … … 172 180 fork wait kill sleep 173 181 ]; 174 push @ routinenames, "HOW", "fail", "temp", "let";182 push @baseroutinenames, "HOW", "fail", "temp", "let"; 175 183 176 184 # please don't add: ref length bless delete exists 177 185 186 my @routinenames; 178 187 my %routinenames; 179 %routinenames{@routinenames} = (1 xx @routinenames); 188 189 sub init_routines { 190 %ROUTINES = (); 191 @routinenames = @baseroutinenames; 192 %routinenames = (); 193 %routinenames{@routinenames} = (1 xx @routinenames); 194 } 180 195 181 196 method is_routine ($name) { … … 559 574 :my $endargs is context<rw> = -1; 560 575 576 :my $LANG is context; 577 :my $PKGDECL is context = ""; 578 :my $PKG is context = ""; 579 :my $GOAL is context = "(eof)"; 580 :my $PARSER is context<rw>; 581 :my $IN_DECL is context<rw>; 582 583 { init_types(); init_routines() } 584 561 585 <statementlist> 562 586 [ <?unitstopper> || <.panic: "Can't understand next input--giving up"> ] … … 3421 3445 while @opstack { 3422 3446 last if $op<O><prec> ne @opstack[*-1]<O><prec>; 3423 push @chain, pop(@termstack) .cleanup;3447 push @chain, pop(@termstack); 3424 3448 push @chain, pop(@opstack); 3425 3449 } 3426 push @chain, pop(@termstack) .cleanup;3450 push @chain, pop(@termstack); 3427 3451 @chain = reverse @chain if @chain > 1; 3428 3452 my $startpos = @chain[0].pos; … … 3441 3465 last if $sym ne @opstack[*-1]<sym>; 3442 3466 if @termstack and defined @termstack[0] { 3443 push @list, pop(@termstack) .cleanup;3467 push @list, pop(@termstack); 3444 3468 } 3445 3469 else { … … 3449 3473 } 3450 3474 if @termstack and defined @termstack[0] { 3451 push @list, pop(@termstack) .cleanup;3475 push @list, pop(@termstack); 3452 3476 } 3453 3477 elsif $sym ne ',' { … … 3471 3495 3472 3496 self.deb($op.dump) if $*DEBUG +& DEBUG::EXPR; 3473 $op<arg> = (pop @termstack) .cleanup;3497 $op<arg> = (pop @termstack); 3474 3498 if ($op<arg><_from> < $op<_from>) { 3475 3499 $op<_from> = $op<arg><_from>; … … 3486 3510 self.deb("Termstack size: ", +@termstack) if $*DEBUG +& DEBUG::EXPR; 3487 3511 3488 $op<right> = (pop @termstack) .cleanup;3489 $op<left> = (pop @termstack) .cleanup;3512 $op<right> = (pop @termstack); 3513 $op<left> = (pop @termstack); 3490 3514 $op<_from> = $op<left><_from>; 3491 3515 $op<_pos> = $op<right><_pos>; -
src/perl6/tryfile
r21784 r22848 1 1 #!/usr/local/bin/perl 2 3 my $file = shift;4 2 5 3 use STD; … … 8 6 use Encode; 9 7 10 my $r = STD->parsefile($file); 11 print Dump($r); 8 for my $file (@ARGV) { 9 warn $file,"\n"; 10 eval { 11 STD->parsefile($file); 12 }; 13 warn $@ if $@; 14 }
