File Coverage

blib/lib/JE/Parser.pm
Criterion Covered Total %
statement 554 734 75.4
branch 394 642 61.3
condition 34 49 69.3
subroutine 77 81 95.0
pod 7 66 10.6
total 1066 1572 67.8


line stmt bran cond sub pod time code
1             package JE::Parser;
2              
3             our $VERSION = '0.064';
4              
5 101     101   39994 use strict; # :-(
  101         132  
  101         3260  
6 101     101   429 use warnings;# :-(
  101         119  
  101         2405  
7 101     101   407 no warnings 'utf8';
  101         707  
  101         2697  
8              
9 101     101   406 use Scalar::Util 'blessed';
  101         171  
  101         47671  
10              
11             require JE::Code ;
12             require JE::Number; # ~~~ Don't want to do this
13              
14             import JE::Code 'add_line_number';
15             sub add_line_number;
16              
17             our ($_parser, $global, @_decls, @_stms, $_vars);
18              
19             #----------METHODS---------#
20              
21             sub new {
22 2     2 1 738 my %self = (
23             stm_names => [qw[
24             -function block empty if while with for switch try
25             labelled var do continue break return throw expr
26             ]],
27             stm => {
28             -function => \&function, block => \&block,
29             empty => \&empty, if => \&if,
30             while => \&while, with => \&with,
31             for => \&for, switch => \&switch,
32             try => \&try, labelled => \&labelled,
33             var => \&var, do => \&do,
34             continue => \&continue, break => \&break,
35             return => \&return, throw => \&throw,
36             expr => \&expr_statement,
37             },
38             global => pop,
39             );
40 2         12 return bless \%self, shift;
41             }
42              
43             sub add_statement {
44 0     0 1 0 my($self,$name,$parser) = shift;
45 0         0 my $in_list;
46             # no warnings 'exiting';
47 0         0 grep $_ eq $name && ++$in_list && goto END_GREP,
48 0   0     0 @{$$self{stm_names}};
49 0         0 END_GREP:
50 0 0       0 $in_list or unshift @{$$self{stm_names}} ,$name;
51 0         0 $$self{stm}{$name} = $parser;
52 0         0 return; # Don't return anything for now, because if we return some-
53             # thing, even if it's not documented, someone might start
54             # relying on it.
55             }
56              
57             sub delete_statement {
58 1     1 1 389 my $self = shift;
59 1         3 for my $name (@_) {
60 4         11 delete $$self{stm}{$name};
61 4         15 @{$$self{stm_names}} =
  4         13  
62 4         4 grep $_ ne $name, @{$$self{stm_names}};
63             }
64 1         3 return $self;
65             }
66              
67             sub statement_list {
68 2     2 1 18 $_[0]{stm_names};
69             }
70              
71             sub parse {
72 11     11 1 18 local $_parser = shift;
73 11         17 local(@_decls, @_stms); # Doing this here and localising it saves
74 11         10 for(@{$_parser->{stm_names}}) { # us from having to do it multiple
  11         25  
75 143 50       100 push @{/^-/ ? \@_decls : \@_stms}, # times.
  143         323  
76             $_parser->{stm}{$_};
77             }
78              
79 11         37 JE::Code::parse($_parser->{global}, @_);
80             }
81              
82             sub eval {
83 4     4 1 15 shift->parse(@_)->execute
84             }
85              
86             #----------PARSER---------#
87              
88 101     101   556 use Exporter 5.57 'import';
  101         2477  
  101         7446  
89              
90             our @EXPORT_OK = qw/ $h $n $optional_sc $ss $s $S $id_cont
91             str num skip ident expr expr_noin statement
92             statements expected optional_sc/;
93             our @EXPORT_TAGS = (
94             vars => [qw/ $h $n $optional_sc $ss $s $S $id_cont/],
95             functions => [qw/ str num skip ident expr expr_noin statement
96             statements expected optional_sc /],
97             );
98              
99 101     101   511 use re 'taint';
  101         126  
  101         3952  
100             #use subs qw'statement statements assign assign_noin expr new';
101 101     101   426 use constant JECE => 'JE::Code::Expression';
  101         119  
  101         5513  
102 101     101   459 use constant JECS => 'JE::Code::Statement';
  101         138  
  101         12308  
103              
104             require JE::String;
105             import JE::String 'desurrogify';
106             import JE::String 'surrogify';
107             sub desurrogify($);
108             sub surrogify($);
109              
110              
111             # die is called with a scalar ref when the string contains what is
112             # expected. This will be converted to a longer message afterwards, which
113             # will read something like "Expected %s but found %s" (probably the most
114             # common error message, which is why there is a shorthand). Using an array
115             # ref is the easiest way to stop the 'at ..., line ...' from being appended
116             # when there is no line break at the end already. die is called with a
117             # double reference to a string if the string is the complete error
118             # message.
119             # ~~~ We may need a function for this second usage, in case we change the
120             # \\ yet again.
121              
122             # @ret != push @ret, ... is a funny way of pushing and then checking to
123             # see whether anything was pushed.
124              
125              
126             sub expected($) { # public
127 21     21 0 163 die \shift
128             }
129              
130              
131             # public vars:
132              
133             # optional horizontal comments and whitespace
134             our $h = qr(
135             (?> [ \t\x0b\f\xa0\p{Zs}]* )
136             (?> (?>/\*[^\cm\cj\x{2028}\x{2029}]*?\*/) [ \t\x0b\f\xa0\p{Zs}]* )?
137 1     1   606 )x;
  1         8  
  1         12  
138              
139             # line terminators
140             our $n = qr((?>[\cm\cj\x{2028}\x{2029}]));
141              
142             # single space char
143             our $ss = qr((?>[\p{Zs}\s\ck\x{2028}\x{2029}]));
144              
145             # optional comments and whitespace
146             our $s = qr((?>
147             (?> $ss* )
148             (?> (?> //[^\cm\cj\x{2028}\x{2029}]* (?>$n|\z) | /\*.*?\*/ )
149             (?> $ss* )
150             ) *
151             ))sx;
152              
153             # mandatory comments/whitespace
154             our $S = qr(
155             (?>
156             $ss
157             |
158             //[^\cm\cj\x{2028}\x{2029}]*
159             |
160             /\*.*?\*/
161             )
162             $s
163             )xs;
164              
165             our $id_cont = qr(
166             (?>
167             \\u([0-9A-Fa-f]{4})
168             |
169             [\p{ID_Continue}\$_]
170             )
171             )x;
172              
173             # end public vars
174              
175              
176             sub str() { # public
177             # For very long strings (>~45000), this pattern hits a perl bug (Complex regular subexpression recursion limit (32766) exceeded)
178             #/\G (?: '((?>(?:[^'\\] | \\.)*))'
179             # |
180             # "((?>(?:[^"\\] | \\.)*))" )/xcgs or return;
181             # There are two solutions:
182             # 1) Use the unrolling technique from the Owl Book.
183             # 2) Use shorter patterns but more code (contributed by Kevin
184             # Cameron)
185             # Number 1 should be faster, but it crashes under perl 5.8.8 on
186             # Windows, and perhaps on other platforms, too. So we use #2 for
187             # 5.8.x regardless of platform to be on the safe side.
188              
189 101     101   197020 use constant old_perl => $] < 5.01; # Use a constant so the
  101         162  
  101         26594  
190 42065     42065 0 75766 my $yarn; # if-block disappears
191 42065         33558 if(old_perl) { # at compile-time.
192             # Use a simpler pattern (but more code) to break strings up
193             # into extents bounded by the quote or escape
194             my $qt = substr($_,pos($_),1);
195             $qt =~ /['"]/ or return; # not a string literal if first
196             pos($_)++; # char not a quote
197             my $done = 0;
198             while (defined(substr($_,pos($_),1))) {
199             my ($part) = /\G([^\\$qt]*)/xcgs;
200             defined($part) or $part = "";
201             $yarn .= $part;
202             my $next = substr($_,pos($_)++,1);
203              
204             if ($next eq "\\") {
205             #pass on any escaped char
206             $next = substr($_,pos($_)++,1);
207             $yarn .= "\\$next";
208             } else {
209             # handle end quote
210             $done = 1;
211             last;
212             }
213             }
214              
215             # error if EOF before end of string
216             return if !$done;
217             }
218             else {
219 42065 100       172220 /\G (?: '([^'\\]*(?:\\.[^'\\]*)*)'
220             |
221             "([^"\\]*(?:\\.[^"\\]*)*)" )/xcgs or return;
222 9820         21336 $yarn = $+;
223             }
224             # Get rid of that constant, as it’s no longer needed.
225 101     101   530 BEGIN { no strict; delete ${__PACKAGE__.'::'}{old_perl}; }
  101     101   159  
  101         3756  
  101         146  
  101         2009  
226              
227             # transform special chars
228 101     101   450 no re 'taint'; # I need eval "qq-..." to work
  101         155  
  101         37104  
229 9820         16959 $yarn =~ s/\\(?:
230             u([0-9a-fA-F]{4})
231             |
232             x([0-9a-fA-F]{2})
233             |
234             (\r\n?|[\n\x{2028}\x{2029}])
235             |
236             ([bfnrt])
237             |
238             (v)
239             |
240             ([0-3][0-7]{0,2}|[4-7][0-7]?) # actually slightly looser
241             | # than what ECMAScript v3 has in its
242             (.) # addendum (it forbids \0 when followed by 8)
243             )/
244 21990 100       114451 $1 ? chr(hex $1) :
    100          
    100          
    100          
    100          
    100          
245             $2 ? chr(hex $2) :
246             $3 ? "" : # escaped line feed disappears
247             $4 ? eval "qq-\\$4-" :
248             $5 ? "\cK" :
249             defined $6 ? chr oct $6 :
250             $7
251             /sgex;
252 9820         38390 "s$yarn";
253             }
254              
255             sub num() { # public
256 32245 100   32245 0 301150 /\G (?:
257             0[Xx] ([A-Fa-f0-9]+)
258             |
259             0 ([01234567]+)
260             |
261             (?=[0-9]|\.[0-9])
262             (
263             (?:0|[1-9][0-9]*)?
264             (?:\.[0-9]*)?
265             (?:[Ee][+-]?[0-9]+)?
266             )
267             ) /xcg
268             or return;
269 21596 100       107170 return defined $1 ? hex $1 : defined $2 ? oct $2 : $3;
    100          
270             }
271              
272             our $ident = qr(
273             (?! (?: case | default ) (?!$id_cont) )
274             (?:
275             \\u[0-9A-Fa-f]{4}
276             |
277             [\p{ID_Start}\$_]
278             )
279             (?> $id_cont* )
280             )x;
281              
282             sub unescape_ident($) {
283 23681     23681 0 27824 my $ident = shift;
284 23681         28080 $ident =~ s/\\u([0-9a-fA-F]{4})/chr hex $1/ge;
  18         71  
285 23681         52662 $ident = desurrogify $ident;
286 23681 100       73638 $ident =~ /^[\p{ID_Start}\$_]
287             [\p{ID_Continue}\$_]*
288             \z/x
289             or die \\"'$ident' is not a valid identifier";
290 23680         100111 $ident;
291             }
292              
293             # public
294 34794     34794 0 126578 sub skip() { /\G$s/g } # skip whitespace
295              
296             sub ident() { # public
297 6479 100   6479 0 36617 return unless my($ident) = /\G($ident)/cgox;
298 5549         65874 unescape_ident $ident;
299             }
300              
301             sub params() { # Only called when we know we need it, which is why it dies
302             # on the second line
303 364     364 0 400 my @ret;
304 364 50       1251 /\G\(/gc or expected "'('";
305 364         567 &skip;
306 364 100       1574 if (@ret != push @ret, &ident) { # first identifier (not prec.
307             # by comma)
308 111         1294 while (/\G$s,$s/gc) {
309             # if there's a comma we need another ident
310 100 100       7136 @ret != push @ret, &ident or expected 'identifier';
311             }
312 109         2608 &skip;
313             }
314 362 100       1299 /\G\)/gc or expected "')'";
315 360         791 \@ret;
316             }
317              
318             sub term() {
319 61737     61737 0 88167 my $pos = pos;
320 61737         47102 my $tmp;
321 61737 100 100     365162 if(/\Gfunction(?!$id_cont)$s/cg) {
    100          
    100          
    100          
    100          
    100          
    100          
322 163         378 my @ret = (func => ident);
323 163 100       3593 @ret == 2 and &skip;
324 163         308 push @ret, ¶ms;
325 163         298 &skip;
326 163 50       496 /\G \{ /gcx or expected "'{'";
327             {
328 163         217 local $_vars = [];
  163         298  
329 163         311 push @ret, &statements, $_vars;
330             }
331 163 50       677 /\G \} /gocx or expected "'}'";
332              
333 163         1022 return bless [[$pos, pos], @ret], JECE;
334             }
335             # We don’t call the ident subroutine here,
336             # because we need to sift out null/true/false/this.
337             elsif(($tmp)=/\G($ident)/cgox) {
338 20028 100       108698 $tmp=~/^(?:(?:tru|fals)e|null)\z/ &&return $global->$tmp;
339 18259 100       32906 $tmp eq 'this' and return $tmp;
340 18043         27198 return "i" . unescape_ident $tmp;
341             }
342             elsif(defined($tmp = &str) or
343             defined($tmp = &num)) {
344 31325         118038 return $tmp;
345             }
346             elsif(m-\G
347             /
348             ( (?:[^/*\\[] | \\. | \[ (?>(?:[^]\\] | \\.)*) \] )
349             (?>(?:[^/\\[] | \\. | \[ (?>(?:[^]\\] | \\.)*) \] )*) )
350             /
351             ($id_cont*)
352             -cogx ) {
353              
354             # I have to use local *_ because
355             # 'require JE::Object::RegExp' causes
356             # Scalar::Util->import() to be called (import is inherited
357             # from Exporter), and &Exporter::import does 'local $_',
358             # which, in p5.8.8 (though not 5.9.5) causes pos()
359             # to be reset.
360 317         401 { local *_; require JE::Object::RegExp; }
  317         782  
  317         2968  
361             # ~~~ This needs to unescape the flags.
362 317         1360 return JE::Object::RegExp->new( $global, $1, $2);
363             }
364             elsif(/\G\[$s/cg) {
365 5291         4984 my $anon;
366             my @ret;
367 0         0 my $length;
368              
369 5291         3796 while () {
370 20890 100       27909 @ret != ($length = push @ret, &assign) and &skip;
371 20890         136347 push @ret, bless \$anon, 'comma' while /\G,$s/cg;
372 20890 100       42231 $length == @ret and last;
373             }
374              
375 5291 100       12037 /\G]/cg or expected "']'";
376 5287         37794 return bless [[$pos, pos], array => @ret], JECE;
377             }
378             elsif(/\G\{$s/cg) {
379 552         5047 my @ret;
380              
381 552 100 66     863 if($tmp = &ident or defined($tmp = &str)&&$tmp=~s/^s// or
      66        
      100        
382             defined($tmp = &num)) {
383             # first elem, not preceded by comma
384 125         195 push @ret, $tmp;
385 125         190 &skip;
386 125 50       1141 /\G:$s/cggg or expected 'colon';
387 125 50       2974 @ret != push @ret, &assign
388             or expected \'expression';
389 125         209 &skip;
390              
391 125         751 while (/\G,$s/cg) {
392             $tmp = ident
393             or defined($tmp = &str)&&$tmp=~s/^s// or
394             defined($tmp = &num)
395 101 100 66     1430 or do {
      66        
      100        
396             # ECMAScript 5 allows a
397             # trailing comma
398 1 50       6 /\G}/cg or expected
399             "'}', identifier, or string or ".
400             " number literal";
401 1         9 return bless [[$pos, pos],
402             hash => @ret], JECE;
403             };
404              
405 100         160 push @ret, $tmp;
406 100         137 &skip;
407 100 50       516 /\G:$s/cggg or expected 'colon';
408 100 50       1716 @ret != push @ret, &assign
409             or expected 'expression';
410 100         148 &skip;
411             }
412             }
413 551 50       2759 /\G}/cg or expected "'}'";
414 551         4231 return bless [[$pos, pos], hash => @ret], JECE;
415             }
416             elsif (/\G\($s/cg) {
417 812 50       6323 my $ret = &expr or expected 'expression';
418 812         1369 &skip;
419 812 50       2851 /\G\)/cg or expected "')'";
420 812         2824 return $ret;
421             }
422             return
423 3249         111821 }
424              
425             sub subscript() { # skips leading whitespace
426 71554     71554 0 83550 my $pos = pos;
427 71554         55818 my $subscript;
428 71554 100       655759 if (/\G$s\[$s/cg) {
    100          
429 1012 50       1632 $subscript = &expr or expected 'expression';
430 1012         1585 &skip;
431 1012 50       2687 /\G]/cog or expected "']'";
432             }
433             elsif (/\G$s\.$s/cg) {
434 4216 50       8984 $subscript = &ident or expected 'identifier';
435             }
436 66326         190990 else { return }
437              
438 5228         26956 return bless [[$pos, pos], $subscript], 'JE::Code::Subscript';
439             }
440              
441             sub args() { # skips leading whitespace
442 71522     71522 0 73839 my $pos = pos;
443 71522         56792 my @ret;
444 71522 100       658829 /\G$s\($s/gc or return;
445 10401 100       26841 if (@ret != push @ret, &assign) { # first expression (not prec.
446             # by comma)
447 9018         47202 while (/\G$s,$s/gc) {
448             # if there's a comma we need another expression
449 9249 50       24161 @ret != push @ret, &assign
450             or expected 'expression';
451             }
452 9018         18847 &skip;
453             }
454 10401 100       28842 /\G\)/gc or expected "')'";
455 10399         69224 return bless [[$pos, pos], @ret], 'JE::Code::Arguments';
456             }
457              
458             sub new_expr() {
459 62738 100   62738 0 330494 /\G new(?!$id_cont) $s /cgx or return;
460 1001         4286 my $ret = bless [[pos], 'new'], JECE;
461            
462 1001         1192 my $pos = pos;
463 1001   33     1544 my @member_expr = &new_expr || &term
464             || expected "identifier, literal, 'new' or '('";
465              
466 1001         2070 0 while @member_expr != push @member_expr, &subscript;
467              
468 1001 100       2537 push @$ret, @member_expr == 1 ? @member_expr :
469             bless [[$pos, pos], 'member/call', @member_expr],
470             JECE;
471 1001         1588 push @$ret, args;
472 1001         4123 $ret;
473             }
474              
475             sub left_expr() {
476 61737     61737 0 62511 my($pos,@ret) = pos;
477 61737 100 100     80162 @ret != push @ret, &new_expr || &term or return;
478              
479 58478         112764 0 while @ret != push @ret, &subscript, &args;
480 58476 100       251825 @ret ? @ret == 1 ? @ret :
    50          
481             bless([[$pos, pos], 'member/call', @ret],
482             JECE)
483             : return;
484             }
485              
486             sub postfix() {
487 61737     61737 0 74368 my($pos,@ret) = pos;
488 61737 100       76379 @ret != push @ret, &left_expr or return;
489 58476         173490 push @ret, $1 while /\G $h ( \+\+ | -- ) /cogx;
490 58476 100       169761 @ret == 1 ? @ret : bless [[$pos, pos], 'postfix', @ret],
491             JECE;
492             }
493              
494             sub unary() {
495 61737     61737 0 60806 my($pos,@ret) = pos;
496 61737         426497 push @ret, $1 while /\G $s (
497             (?: delete | void | typeof )(?!$id_cont)
498             |
499             \+\+? | --? | ~ | !
500             ) $s /cgx;
501 61737 100       120845 @ret != push @ret, &postfix or (
    100          
502             @ret
503             ? expected "expression"
504             : return
505             );
506 58476 100       177842 @ret == 1 ? @ret : bless [[$pos, pos], 'prefix', @ret],
507             JECE;
508             }
509              
510             sub multi() {
511 61518     61518 0 60403 my($pos,@ret) = pos;
512 61518 100       75118 @ret != push @ret, &unary or return;
513 58257         298598 while(m-\G $s ( [*%](?!=) | / (?![*/=]) ) $s -cgx) {
514 219         669 push @ret, $1;
515 219 50       335 @ret == push @ret, &unary and expected 'expression';
516             }
517 58257 100       189111 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
518             JECE;
519             }
520              
521             sub add() {
522 60240     60240 0 59629 my($pos,@ret) = pos;
523 60240 100       72971 @ret != push @ret, &multi or return;
524 56979         255051 while(/\G $s ( \+(?![+=]) | -(?![-=]) ) $s /cgx) {
525 1278         3886 push @ret, $1;
526 1278 50       1842 @ret == push @ret, &multi and expected 'expression'
527             }
528 56979 100       180959 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
529             JECE;
530             }
531              
532             sub bitshift() {
533 60084     60084 0 57361 my($pos,@ret) = pos;
534 60084 100       74594 @ret == push @ret, &add and return;
535 56823         245094 while(/\G $s (>>> | >>(?!>) | <<)(?!=) $s /cgx) {
536 156         885 push @ret, $1;
537 156 50       230 @ret == push @ret, &add and expected 'expression';
538             }
539 56823 100       182465 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
540             JECE;
541             }
542              
543             sub rel() {
544 58550     58550 0 57981 my($pos,@ret) = pos;
545 58550 100       72533 @ret == push @ret, &bitshift and return;
546 55302         276058 while(/\G $s ( ([<>])(?!\2|=) | [<>]= |
547             in(?:stanceof)?(?!$id_cont) ) $s /cgx) {
548 957         2762 push @ret, $1;
549 957 50       1503 @ret== push @ret, &bitshift and expected 'expression';
550             }
551 55302 100       197752 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
552             JECE;
553             }
554              
555             sub rel_noin() {
556 565     565 0 626 my($pos,@ret) = pos;
557 565 100       732 @ret == push @ret, &bitshift and return;
558 552         3689 while(/\G $s ( ([<>])(?!\2|=) | [<>]= | instanceof(?!$id_cont) )
559             $s /cgx) {
560 12         393 push @ret, $1;
561 12 50       20 @ret == push @ret, &bitshift and expected 'expression';
562             }
563 552 100       9878 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
564             JECE;
565             }
566              
567             sub equal() {
568 55789     55789 0 55574 my($pos,@ret) = pos;
569 55789 100       69491 @ret == push @ret, &rel and return;
570 52541         512870 while(/\G $s ([!=]==?) $s /cgx) {
571 2761         7442 push @ret, $1;
572 2761 50       4141 @ret == push @ret, &rel and expected 'expression';
573             }
574 52541 100       176472 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
575             JECE;
576             }
577              
578             sub equal_noin() {
579 555     555 0 654 my($pos,@ret) = pos;
580 555 100       866 @ret == push @ret, &rel_noin and return;
581 542         3240 while(/\G $s ([!=]==?) $s /cgx) {
582 10         17 push @ret, $1;
583 10 50       16 @ret == push @ret, &rel_noin and expected 'expression';
584             }
585 542 100       8156 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
586             JECE;
587             }
588              
589             sub bit_and() {
590 55737     55737 0 53971 my($pos,@ret) = pos;
591 55737 100       65941 @ret == push @ret, &equal and return;
592 52489         1049786 while(/\G $s &(?![&=]) $s /cgx) {
593 52 50       850 @ret == push @ret, '&', &equal and expected 'expression';
594             }
595 52489 100       167568 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
596             JECE;
597             }
598              
599             sub bit_and_noin() {
600 553     553 0 608 my($pos,@ret) = pos;
601 553 100       774 @ret == push @ret, &equal_noin and return;
602 540         7999 while(/\G $s &(?![&=]) $s /cgx) {
603 2 50       4 @ret == push @ret, '&', &equal_noin
604             and expected 'expression';
605             }
606 540 100       7903 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
607             JECE;
608             }
609              
610             sub bit_or() {
611 55684     55684 0 55879 my($pos,@ret) = pos;
612 55684 100       70448 @ret == push @ret, &bit_and and return;
613 52436         1041438 while(/\G $s \|(?![|=]) $s /cgx) {
614 53 50       353 @ret == push @ret, '|', &bit_and and expected 'expression';
615             }
616 52436 100       167347 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
617             JECE;
618             }
619              
620             sub bit_or_noin() {
621 551     551 0 624 my($pos,@ret) = pos;
622 551 100       749 @ret == push @ret, &bit_and_noin and return;
623 538         7928 while(/\G $s \|(?![|=]) $s /cgx) {
624 2 50       5 @ret == push @ret, '|', &bit_and_noin
625             and expected 'expression';
626             }
627 538 100       7955 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
628             JECE;
629             }
630              
631             sub bit_xor() {
632 55632     55632 0 52834 my($pos,@ret) = pos;
633 55632 100       69416 @ret == push @ret, &bit_or and return;
634 52384         963730 while(/\G $s \^(?!=) $s /cgx) {
635 52 50       355 @ret == push @ret, '^', &bit_or and expected 'expression';
636             }
637 52384 100       172295 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
638             JECE;
639             }
640              
641             sub bit_xor_noin() {
642 549     549 0 653 my($pos,@ret) = pos;
643 549 100       767 @ret == push @ret, &bit_or_noin and return;
644 536         7901 while(/\G $s \^(?!=) $s /cgx) {
645 2 50       5 @ret == push @ret, '^', &bit_or_noin
646             and expected 'expression';
647             }
648 536 100       7961 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
649             JECE;
650             }
651              
652             sub and_expr() { # If I just call it 'and', then I have to write
653             # CORE::and for the operator! (Far too cumbersome.)
654 55155     55155 0 54346 my($pos,@ret) = pos;
655 55155 100       68644 @ret == push @ret, &bit_xor and return;
656 51907         737221 while(/\G $s && $s /cgx) {
657 477 50       1273 @ret == push @ret, '&&', &bit_xor
658             and expected 'expression';
659             }
660 51907 100       166577 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
661             JECE;
662             }
663              
664             sub and_noin() {
665 547     547 0 616 my($pos,@ret) = pos;
666 547 100       826 @ret == push @ret, &bit_xor_noin and return;
667 534         5225 while(/\G $s && $s /cgx) {
668 2 50       4 @ret == push @ret, '&&', &bit_xor_noin
669             and expected 'expression';
670             }
671 534 100       7884 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
672             JECE;
673             }
674              
675             sub or_expr() {
676 55075     55075 0 57185 my($pos,@ret) = pos;
677 55075 100       68018 @ret == push @ret, &and_expr and return;
678 51827         717215 while(/\G $s \|\| $s /cgx) {
679 80 50       148 @ret == push @ret, '||', &and_expr
680             and expected 'expression';
681             }
682 51827 100       171574 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
683             JECE;
684             }
685              
686             sub or_noin() {
687 545     545 0 803 my($pos,@ret) = pos;
688 545 100       827 @ret == push @ret, &and_noin and return;
689 532         5105 while(/\G $s \|\| $s /cgx) {
690 2 50       30 @ret == push @ret, '||', &and_noin
691             and expected 'expression';
692             }
693 532 100       9095 @ret == 1 ? @ret : bless [[$pos, pos], 'lassoc', @ret],
694             JECE;
695             }
696              
697             sub assign() {
698 53457     53457 0 99887 my($pos,@ret) = pos;
699 53457 100       67162 @ret == push @ret, &or_expr and return;
700 50210         520503 while(m@\G $s ((?>(?: [-*/%+&^|] | << | >>>? )?)=) $s @cgx) {
701 1618         9202 push @ret, $1;
702 1618 50       2652 @ret == push @ret, &or_expr and expected 'expression';
703             }
704 50209 100       1177905 if(/\G$s\?$s/cg) {
705 48 50       109 @ret == push @ret, &assign and expected 'expression';
706 48         95 &skip;
707 48 50       561 /\G:$s/cg or expected "colon";
708 48 50       1446 @ret == push @ret, &assign and expected 'expression';
709             }
710 50209 100       252006 @ret == 1 ? @ret : bless [[$pos, pos], 'assign', @ret],
711             JECE;
712             }
713              
714             sub assign_noin() {
715 321     321 0 2372 my($pos,@ret) = pos;
716 321 100       581 @ret == push @ret, &or_noin and return;
717 308         2414 while(m~\G $s ((?>(?: [-*/%+&^|] | << | >>>? )?)=) $s ~cgx) {
718 224         3382 push @ret, $1;
719 224 50       366 @ret == push @ret, &or_noin and expected 'expression';
720             }
721 308 100       5543 if(/\G$s\?$s/cg) {
722 6 50       10 @ret == push @ret, &assign and expected 'expression';
723 6         11 &skip;
724 6 50       45 /\G:$s/cg or expected "colon";
725 6 50       256 @ret == push @ret, &assign_noin and expected 'expression';
726             }
727 308 100       8378 @ret == 1 ? @ret : bless [[$pos, pos], 'assign', @ret],
728             JECE;
729             }
730              
731             sub expr() { # public
732 11982     11982 0 39523 my $ret = bless [[pos], 'expr'], JECE;
733 11982 100       20800 @$ret == push @$ret, &assign and return;
734 10286         52291 while(/\G$s,$s/cg) {
735 304 50       1276 @$ret == push @$ret,& assign and expected 'expression';
736             }
737 10286         35111 push @{$$ret[0]},pos;
  10286         21373  
738 10286         28423 $ret;
739             }
740              
741             sub expr_noin() { # public
742 237     237 0 4166 my $ret = bless [[pos], 'expr'], JECE;
743 237 100       531 @$ret == push @$ret, &assign_noin and return;
744 224         1723 while(/\G$s,$s/cg) {
745 22 50       40 @$ret == push @$ret, &assign_noin
746             and expected 'expression';
747             }
748 224         5713 push @{$$ret[0]},pos;
  224         514  
749 224         652 $ret;
750             }
751              
752             sub vardecl() { # vardecl is only called when we *know* we need it, so it
753             # will die when it can't get the first identifier, instead
754             # of returning undef
755 385     385 0 438 my @ret;
756 385 50       726 @ret == push @ret, &ident and expected 'identifier';
757 385 100 33     4137 /\G$s=$s/cg and
758             (@ret != push @ret, &assign or expected 'expression');
759 385         3222 push @$_vars, $ret[0];
760 385         3801 \@ret;
761             }
762              
763             sub vardecl_noin() {
764 118     118 0 118 my @ret;
765 118 50       224 @ret == push @ret, &ident and expected 'identifier';
766 118 100 33     1081 /\G$s=$s/cg and
767             (@ret != push @ret, &assign_noin or expected 'expression');
768 118         2906 push @$_vars, $ret[0];
769 118         285 \@ret;
770             }
771              
772             sub finish_for_sc_sc() { # returns the last two expressions of a for (;;)
773             # loop header
774 301     301 0 302 my @ret;
775             my $msg;
776 301 100       522 if(@ret != push @ret, expr) {
777 260         352 $msg = '';
778 260         391 &skip
779             } else {
780 41         279 push @ret, 'empty';
781 41         44 $msg = 'expression or '
782             }
783 301 50       1739 /\G;$s/cg or expected "${msg}semicolon";
784 301 100       3103 if(@ret != push @ret, expr) {
785 194         249 $msg = '';
786 194         273 &skip
787             } else {
788 107         146 push @ret, 'empty';
789 107         134 $msg = 'expression or '
790             }
791 301 50       1703 /\G\)$s/cg or expected "${msg}')'";
792              
793 301         3622 @ret;
794             }
795              
796             # ----------- Statement types ------------ #
797             # (used by custom parsers)
798              
799             our $optional_sc = # public
800             qr-\G (?:
801             $s (?: \z | ; $s | (?=\}) )
802             |
803              
804             # optional horizontal whitespace
805             # then a line terminator or a comment containing one
806             # then optional trailing whitespace
807             $h
808             (?: $n | //[^\cm\cj\x{2028}\x{2029}]* $n |
809             /\* [^*\cm\cj\x{2028}\x{2029}]*
810             (?: \*(?!/) [^*\cm\cj\x{2028}\x{2029}] )*
811             $n
812             (?s:.)*?
813             \*/
814             )
815             $s
816             )-x;
817              
818             sub optional_sc() {
819 9 100   9 0 57 /$optional_sc/gc or expected "semicolon, '}' or end of line";
820             }
821              
822             sub block() {
823 16 50   16 0 61 /\G\{/gc or return;
824 0         0 my $ret = [[pos()-1], 'statements'];
825 0         0 &skip;
826 0         0 while() { # 'last' does not work when 'while' is a
827             # statement modifier
828 0 0       0 @$ret == push @$ret, &statement and last;
829             }
830 0 0       0 expected "'}'" unless /\G\}$s/gc;
831              
832 0         0 push @{$$ret[0]},pos;
  0         0  
833              
834 0         0 bless $ret, JECS;
835             }
836              
837             sub empty() {
838 16     16 0 15 my $pos = pos;
839 16 50       93 /\G;$s/cg or return;
840 0         0 bless [[$pos,pos], 'empty'], JECS;
841             }
842              
843             sub function() {
844 7064     7064 0 9346 my $pos = pos;
845 7064 100       39387 /\Gfunction$S/cg or return;
846 132         5827 my $ret = [[$pos], 'function'];
847 132 50       366 @$ret == push @$ret, &ident
848             and expected "identifier";
849 132         276 &skip;
850 132         4626 push @$ret, ¶ms;
851 132         229 &skip;
852 132 50       413 /\G \{ /gcx or expected "'{'";
853             {
854 132         156 local $_vars = [];
  132         220  
855 132         302 push @$ret, &statements, $_vars;
856             }
857 132 50       1502 /\G \}$s /gcx or expected "'}'";
858              
859 132         5850 push @{$$ret[0]},pos;
  132         334  
860              
861 132         234 push @$_vars, $ret;
862              
863 132         739 bless $ret, JECS;
864             }
865              
866             sub if() {
867 16     16 0 16 my $pos = pos;
868 16 50       89 /\Gif$s\($s/cg or return;
869 0         0 my $ret = [[$pos], 'if'];
870              
871 0 0       0 @$ret == push @$ret, &expr
872             and expected 'expression';
873 0         0 &skip;
874 0 0       0 /\G\)$s/gc or expected "')'";
875 0 0       0 @$ret != push @$ret, &statement
876             or expected 'statement';
877 0 0       0 if (/\Gelse(?!$id_cont)$s/cg) {
878 0 0       0 @$ret == push @$ret, &statement
879             and expected 'statement';
880             }
881              
882 0         0 push @{$$ret[0]},pos;
  0         0  
883              
884 0         0 bless $ret, JECS;
885             }
886              
887             sub while() {
888 0     0 0 0 my $pos = pos;
889 0 0       0 /\Gwhile$s\($s/cg or return;
890 0         0 my $ret = [[$pos], 'while'];
891              
892 0 0       0 @$ret == push @$ret, &expr
893             and expected 'expression';
894 0         0 &skip;
895 0 0       0 /\G\)$s/gc or expected "')'";
896 0 0       0 @$ret != push @$ret, &statement
897             or expected 'statement';
898              
899 0         0 push @{$$ret[0]},pos;
  0         0  
900              
901 0         0 bless $ret, JECS;
902             }
903              
904             sub for() {
905 0     0 1 0 my $pos = pos;
906 0 0       0 /\Gfor$s\($s/cg or return;
907 0         0 my $ret = [[$pos], 'for'];
908              
909 0 0       0 if (/\G var$S/cgx) {
    0          
910 0         0 push @$ret, my $var = bless
911             [[pos() - length $1], 'var'],
912             'JE::Code::Statement';
913              
914 0         0 push @$var, &vardecl_noin;
915 0         0 &skip;
916 0 0       0 if (/\G([;,])$s/gc) {
917             # if there's a comma or sc then
918             # this is a for(;;) loop
919 0 0       0 if ($1 eq ',') {
920             # finish getting the var
921             # decl list
922 0         0 do{
923 0 0       0 @$var ==
924             push @$var, &vardecl
925             and expected
926             'identifier'
927             } while (/\G$s,$s/gc);
928 0         0 &skip;
929 0 0       0 /\G;$s/cg
930             or expected 'semicolon';
931             }
932 0         0 push @$ret, &finish_for_sc_sc;
933             }
934             else {
935 0 0       0 /\Gin$s/cg or expected
936             "'in', comma or semicolon";
937 0         0 push @$ret, 'in';
938 0 0       0 @$ret == push @$ret, &expr
939             and expected 'expresssion';
940 0         0 &skip;
941 0 0       0 /\G\)$s/cg or expected "')'";
942             }
943             }
944             elsif(@$ret != push @$ret, &expr_noin) {
945 0         0 &skip;
946 0 0       0 if (/\G;$s/gc) {
947             # if there's a semicolon then
948             # this is a for(;;) loop
949 0         0 push @$ret, &finish_for_sc_sc;
950             }
951             else {
952 0 0       0 /\Gin$s/cg or expected
953             "'in' or semicolon";
954 0         0 push @$ret, 'in';
955 0 0       0 @$ret == push @$ret, &expr
956             and expected 'expresssion';
957 0         0 &skip;
958 0 0       0 /\G\)$s/cg or expected "')'";
959             }
960             }
961             else {
962 0         0 push @$ret, 'empty';
963 0 0       0 /\G;$s/cg
964             or expected 'expression or semicolon';
965 0         0 push @$ret, &finish_for_sc_sc;
966             }
967              
968             # body of the for loop
969 0 0       0 @$ret != push @$ret, &statement
970             or expected 'statement';
971              
972 0         0 push @{$$ret[0]},pos;
  0         0  
973              
974 0         0 bless $ret, JECS;
975             }
976              
977             sub with() { # almost identical to while
978 16     16 0 23 my $pos = pos;
979 16 50       90 /\Gwith$s\($s/cg or return;
980 0         0 my $ret = [[$pos], 'with'];
981              
982 0 0       0 @$ret == push @$ret, &expr
983             and expected 'expression';
984 0         0 &skip;
985 0 0       0 /\G\)$s/gc or expected "')'";
986 0 0       0 @$ret != push @$ret, &statement
987             or expected 'statement';
988              
989 0         0 push @{$$ret[0]},pos;
  0         0  
990              
991 0         0 bless $ret, JECS;
992             }
993              
994             sub switch() {
995 16     16 0 18 my $pos = pos;
996 16 50       91 /\Gswitch$s\($s/cg or return;
997 0         0 my $ret = [[$pos], 'switch'];
998              
999 0 0       0 @$ret == push @$ret, &expr
1000             and expected 'expression';
1001 0         0 &skip;
1002 0 0       0 /\G\)$s/gc or expected "')'";
1003 0 0       0 /\G\{$s/gc or expected "'{'";
1004              
1005 0         0 while (/\G case(?!$id_cont) $s/cgx) {
1006 0 0       0 @$ret == push @$ret, &expr
1007             and expected 'expression';
1008 0         0 &skip;
1009 0 0       0 /\G:$s/cg or expected 'colon';
1010 0         0 push @$ret, &statements;
1011             }
1012 0         0 my $default=0;
1013 0 0       0 if (/\G default(?!$id_cont) $s/cgx) {
1014 0 0       0 /\G : $s /cgx or expected 'colon';
1015 0         0 push @$ret, default => &statements;
1016 0         0 ++$default;
1017             }
1018 0         0 while (/\G case(?!$id_cont) $s/cgx) {
1019 0 0       0 @$ret == push @$ret, &expr
1020             and expected 'expression';
1021 0         0 &skip;
1022 0 0       0 /\G:$s/cg or expected 'colon';
1023 0         0 push @$ret, &statements;
1024             }
1025 0 0       0 /\G \} $s /cgx or expected (
    0          
1026             $default
1027             ? "'}' or 'case'"
1028             : "'}', 'case' or 'default'"
1029             );
1030              
1031 0         0 push @{$$ret[0]},pos;
  0         0  
1032              
1033 0         0 bless $ret, JECS;
1034             }
1035              
1036             sub try() {
1037 16     16 0 16 my $pos = pos;
1038 16 50       91 /\Gtry$s\{$s/cg or return;
1039 0         0 my $ret = [[$pos], 'try', &statements];
1040              
1041 0 0       0 /\G \} $s /cgx or expected "'}'";
1042              
1043 0         0 $pos = pos;
1044              
1045 0 0       0 if(/\Gcatch$s/cg) {
1046 0 0       0 /\G \( $s /cgx or expected "'('";
1047 0 0       0 @$ret == push @$ret, &ident
1048             and expected 'identifier';
1049 0         0 &skip;
1050 0 0       0 /\G \) $s /cgx or expected "')'";
1051              
1052 0 0       0 /\G \{ $s /cgx or expected "'{'";
1053 0         0 push @$ret, &statements;
1054 0 0       0 /\G \} $s /cgx or expected "'}'";
1055             }
1056 0 0       0 if(/\Gfinally$s/cg) {
1057 0 0       0 /\G \{ $s /cgx or expected "'{'";
1058 0         0 push @$ret, &statements;
1059 0 0       0 /\G \} $s /cgx or expected "'}'";
1060             }
1061              
1062 0 0       0 pos eq $pos and expected "'catch' or 'finally'";
1063              
1064 0         0 push @{$$ret[0]},pos;
  0         0  
1065              
1066 0         0 bless $ret, JECS;
1067             }
1068              
1069             sub labelled() {
1070 16     16 0 18 my $pos = pos;
1071 16 50       119 /\G ($ident) $s : $s/cgx or return;
1072 0         0 my $ret = [[$pos], 'labelled', unescape_ident $1];
1073              
1074 0         0 while (/\G($ident)$s:$s/cg) {
1075 0         0 push @$ret, unescape_ident $1;
1076             }
1077 0 0       0 @$ret != push @$ret, &statement
1078             or expected 'statement';
1079              
1080 0         0 push @{$$ret[0]},pos;
  0         0  
1081              
1082 0         0 bless $ret, JECS;
1083             }
1084              
1085             sub var() {
1086 16     16 0 16 my $pos = pos;
1087 16 50       92 /\G var $S/cgx or return;
1088 0         0 my $ret = [[$pos], 'var'];
1089              
1090 0         0 do{
1091 0         0 push @$ret, &vardecl;
1092             } while(/\G$s,$s/gc);
1093              
1094 0         0 optional_sc;
1095              
1096 0         0 push @{$$ret[0]},pos;
  0         0  
1097              
1098 0         0 bless $ret, JECS;
1099             }
1100              
1101             sub do() {
1102 0     0 0 0 my $pos = pos;
1103 0 0       0 /\G do(?!$id_cont)$s/cgx or return;
1104 0         0 my $ret = [[$pos], 'do'];
1105              
1106 0 0       0 @$ret != push @$ret, &statement
1107             or expected 'statement';
1108 0 0       0 /\Gwhile$s/cg or expected "'while'";
1109 0 0       0 /\G\($s/cg or expected "'('";
1110 0 0       0 @$ret != push @$ret, &expr
1111             or expected 'expression';
1112 0         0 &skip;
1113 0 0       0 /\G\)/cog or expected "')'";
1114              
1115 0         0 optional_sc;
1116              
1117 0         0 push @{$$ret[0]},pos;
  0         0  
1118              
1119 0         0 bless $ret, JECS;
1120             }
1121              
1122             sub continue() {
1123 16     16 0 22 my $pos = pos;
1124 16 50       70 /\G continue(?!$id_cont)/cogx or return;
1125 0         0 my $ret = [[$pos], 'continue'];
1126              
1127 0 0       0 /\G$h($ident)/cog
1128             and push @$ret, unescape_ident $1;
1129              
1130 0         0 optional_sc;
1131              
1132 0         0 push @{$$ret[0]},pos;
  0         0  
1133              
1134 0         0 bless $ret, JECS;
1135             }
1136              
1137             sub break() { # almost identical to continue
1138 16     16 0 20 my $pos = pos;
1139 16 50       63 /\G break(?!$id_cont)/cogx or return;
1140 0         0 my $ret = [[$pos], 'break'];
1141              
1142 0 0       0 /\G$h($ident)/cog
1143             and push @$ret, unescape_ident $1;
1144              
1145 0         0 optional_sc;
1146              
1147 0         0 push @{$$ret[0]},pos;
  0         0  
1148              
1149 0         0 bless $ret, JECS;
1150             }
1151              
1152             sub return() {
1153 16     16 0 18 my $pos = pos;
1154 16 50       58 /\G return(?!$id_cont)/cogx or return;
1155 0         0 my $ret = [[$pos], 'return'];
1156              
1157 0         0 $pos = pos;
1158 0         0 /\G$h/g; # skip horz ws
1159 0 0       0 @$ret == push @$ret, &expr and pos = $pos;
1160             # reverse to before the white space if
1161             # there is no expr
1162              
1163 0         0 optional_sc;
1164              
1165 0         0 push @{$$ret[0]},pos;
  0         0  
1166              
1167 0         0 bless $ret, JECS;
1168             }
1169              
1170             sub throw() {
1171 16     16 0 14 my $pos = pos;
1172 16 50       56 /\G throw(?!$id_cont)/cogx
1173             or return;
1174 0         0 my $ret = [[$pos], 'throw'];
1175              
1176 0         0 /\G$h/g; # skip horz ws
1177 0 0       0 @$ret == push @$ret, &expr and expected 'expression';
1178              
1179 0         0 optional_sc;
1180              
1181 0         0 push @{$$ret[0]},pos;
  0         0  
1182              
1183 0         0 bless $ret, JECS;
1184             }
1185              
1186             sub expr_statement() {
1187 16 100   16 0 20 my $ret = &expr or return;
1188 9         15 optional_sc; # the only difference in behaviour between
1189             # this and &expr
1190 5         16 $ret;
1191             }
1192              
1193              
1194              
1195             # -------- end of statement types----------#
1196              
1197             # This takes care of trailing white space.
1198             sub statement_default() {
1199 10949     10949 0 19626 my $ret = [[pos]];
1200              
1201             # Statements that do not have an optional semicolon
1202 10949 100       106306 if (/\G (?:
1203             ( \{ | ; )
1204             |
1205             (function)$S
1206             |
1207             ( if | w(?:hile|ith) | for | switch ) $s \( $s
1208             |
1209             ( try $s \{ $s )
1210             |
1211             ($ident) $s : $s
1212             ) /xgc) {
1213 101     101   705087 no warnings 'uninitialized';
  101         217  
  101         198445  
1214 1222 100       24527 if($1 eq '{') {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
1215 166         298 push @$ret, 'statements';
1216 166         279 &skip;
1217 166         483 while() { # 'last' does not work when 'while' is a
1218             # statement modifier
1219 509 100       1121 @$ret == push @$ret,
1220             &statement_default and last;
1221             }
1222            
1223 165 50       1859 expected "'}'" unless /\G\}$s/gc;
1224             }
1225             elsif($1 eq ';') {
1226 156         251 push @$ret, 'empty';
1227 156         250 &skip;
1228             }
1229             elsif($2) {
1230 34         48 push @$ret, 'function';
1231 34 50       55 @$ret == push @$ret, &ident
1232             and expected "identifier";
1233 34         45 &skip;
1234 34         50 push @$ret, ¶ms;
1235 34         47 &skip;
1236 34 50       79 /\G \{ /gcx or expected "'{'";
1237             {
1238 34         30 local $_vars = [];
  34         47  
1239 34         64 push @$ret, &statements, $_vars;
1240             }
1241 34 50       245 /\G \}$s /gcx or expected "'}'";
1242 34         600 push @$_vars, $ret;
1243             }
1244             elsif($3 eq 'if') {
1245 84         165 push @$ret, 'if';
1246 84 50       197 @$ret == push @$ret, &expr
1247             and expected 'expression';
1248 84         147 &skip;
1249 84 50       837 /\G\)$s/gc or expected "')'";
1250 84 50       2223 @$ret != push @$ret, &statement_default
1251             or expected 'statement';
1252 84 100       735 if (/\Gelse(?!$id_cont)$s/cg) {
1253 29 50       702 @$ret == push @$ret,
1254             &statement_default
1255             and expected 'statement';
1256             }
1257             }
1258             elsif($3 eq 'while') {
1259 22         40 push @$ret, 'while';
1260 22 50       43 @$ret == push @$ret, &expr
1261             and expected 'expression';
1262 22         46 &skip;
1263 22 50       376 /\G\)$s/gc or expected "')'";
1264 22 50       922 @$ret != push @$ret, &statement_default
1265             or expected 'statement';
1266             }
1267             elsif($3 eq 'for') {
1268 355         618 push @$ret, 'for';
1269 355 100       2577 if (/\G var$S/cgx) {
    100          
1270 118         3893 push @$ret, my $var = bless
1271             [[pos() - length $1], 'var'],
1272             'JE::Code::Statement';
1273              
1274 118         241 push @$var, &vardecl_noin;
1275 118         190 &skip;
1276 118 100       809 if (/\G([;,])$s/gc) {
1277             # if there's a comma or sc then
1278             # this is a for(;;) loop
1279 85 100       1431 if ($1 eq ',') {
1280             # finish getting the var
1281             # decl list
1282 34         32 do{
1283 34 50       55 @$var ==
1284             push @$var, &vardecl
1285             and expected
1286             'identifier'
1287             } while (/\G$s,$s/gc);
1288 34         668 &skip;
1289 34 50       172 /\G;$s/cg
1290             or expected 'semicolon';
1291             }
1292 85         516 push @$ret, &finish_for_sc_sc;
1293             }
1294             else {
1295 33 50       1262 /\Gin$s/cg or expected
1296             "'in', comma or semicolon";
1297 33         1540 push @$ret, 'in';
1298 33 50       88 @$ret == push @$ret, &expr
1299             and expected 'expresssion';
1300 33         75 &skip;
1301 33 50       311 /\G\)$s/cg or expected "')'";
1302             }
1303             }
1304             elsif(@$ret != push @$ret, &expr_noin) {
1305 224         361 &skip;
1306 224 100       2132 if (/\G;$s/gc) {
1307             # if there's a semicolon then
1308             # this is a for(;;) loop
1309 203         1993 push @$ret, &finish_for_sc_sc;
1310             }
1311             else {
1312 21 50       1374 /\Gin$s/cg or expected
1313             "'in' or semicolon";
1314 21         1414 push @$ret, 'in';
1315 21 50       58 @$ret == push @$ret, &expr
1316             and expected 'expresssion';
1317 21         43 &skip;
1318 21 50       217 /\G\)$s/cg or expected "')'";
1319             }
1320             }
1321             else {
1322 13         20 push @$ret, 'empty';
1323 13 50       95 /\G;$s/cg
1324             or expected 'expression or semicolon';
1325 13         187 push @$ret, &finish_for_sc_sc;
1326             }
1327              
1328             # body of the for loop
1329 355 50       3828 @$ret != push @$ret, &statement_default
1330             or expected 'statement';
1331             }
1332             elsif($3 eq 'with') {
1333 18         38 push @$ret, 'with';
1334 18 50       57 @$ret == push @$ret, &expr
1335             and expected 'expression';
1336 18         43 &skip;
1337 18 50       446 /\G\)$s/gc or expected "')'";
1338 18 50       1138 @$ret != push @$ret, &statement_default
1339             or expected 'statement';
1340             }
1341             elsif($3 eq 'switch') {
1342 33         58 push @$ret, 'switch';
1343 33 50       60 @$ret == push @$ret, &expr
1344             and expected 'expression';
1345 33         59 &skip;
1346 33 50       399 /\G\)$s/gc or expected "')'";
1347 33 50       719 /\G\{$s/gc or expected "'{'";
1348              
1349 33         622 while (/\G case(?!$id_cont) $s/cgx) {
1350 31 50       273 @$ret == push @$ret, &expr
1351             and expected 'expression';
1352 31         46 &skip;
1353 31 50       195 /\G:$s/cg or expected 'colon';
1354 31         525 push @$ret, &statements;
1355             }
1356 33         433 my $default=0;
1357 33 100       220 if (/\G default(?!$id_cont) $s/cgx) {
1358 20 50       389 /\G : $s /cgx or expected 'colon';
1359 20         484 push @$ret, default => &statements;
1360 20         27 ++$default;
1361             }
1362 33         603 while (/\G case(?!$id_cont) $s/cgx) {
1363 19 50       257 @$ret == push @$ret, &expr
1364             and expected 'expression';
1365 19         36 &skip;
1366 19 50       145 /\G:$s/cg or expected 'colon';
1367 19         537 push @$ret, &statements;
1368             }
1369 33 0       664 /\G \} $s /cgx or expected (
    50          
1370             $default
1371             ? "'}' or 'case'"
1372             : "'}', 'case' or 'default'"
1373             );
1374             }
1375             elsif($4) { # try
1376 316         703 push @$ret, 'try', &statements;
1377 316 50       3031 /\G \} $s /cgx or expected "'}'";
1378              
1379 316         6651 my $pos = pos;
1380              
1381 316 100       2017 if(/\Gcatch$s/cg) {
1382 314 50       7251 /\G \( $s /cgx or expected "'('";
1383 314 50       6204 @$ret == push @$ret, &ident
1384             and expected 'identifier';
1385 314         595 &skip;
1386 314 50       2501 /\G \) $s /cgx or expected "')'";
1387              
1388 314 50       7595 /\G \{ $s /cgx or expected "'{'";
1389 314         5953 push @$ret, &statements;
1390 314 50       2931 /\G \} $s /cgx or expected "'}'";
1391             }
1392 316 100       7615 if(/\Gfinally$s/cg) {
1393 7 50       263 /\G \{ $s /cgx or expected "'{'";
1394 7         507 push @$ret, &statements;
1395 7 50       79 /\G \} $s /cgx or expected "'}'";
1396             }
1397              
1398 316 50       7036 pos eq $pos and expected "'catch' or 'finally'";
1399             }
1400             else { # labelled statement
1401 38         89 push @$ret, 'labelled', unescape_ident $5;
1402 38         527 while (/\G($ident)$s:$s/cg) {
1403 21         1187 push @$ret, unescape_ident $1;
1404             }
1405 38 50       2735 @$ret != push @$ret, &statement_default
1406             or expected 'statement';
1407             }
1408             }
1409             # Statements that do have an optional semicolon
1410             else {
1411 9727 100       222381 if (/\G var$S/xcg) {
    100          
    100          
    100          
    100          
1412 339         4471 push @$ret, 'var';
1413              
1414 339         402 do{
1415 351         1237 push @$ret, &vardecl;
1416             } while(/\G$s,$s/gc);
1417             }
1418             elsif(/\Gdo(?!$id_cont)$s/cg) {
1419 25         267 push @$ret, 'do';
1420 25 50       71 @$ret != push @$ret, &statement_default
1421             or expected 'statement';
1422 25 50       211 /\Gwhile$s/cg or expected "'while'";
1423 25 50       790 /\G\($s/cg or expected "'('";
1424 25 50       614 @$ret != push @$ret, &expr
1425             or expected 'expression';
1426 25         54 &skip;
1427 25 50       265 /\G\)/cog or expected "')'";
1428             }
1429             elsif(/\G(continue|break)(?!$id_cont)/cog) {
1430 109         1292 push @$ret, $1;
1431 109 100       680 /\G$h($ident)/cog
1432             and push @$ret, unescape_ident $1;
1433             }
1434             elsif(/\Greturn(?!$id_cont)/cog) {
1435 135         965 push @$ret, 'return';
1436 135         224 my $pos = pos;
1437 135         1279 /\G$h/g; # skip horz ws
1438 135 100       5251 @$ret == push @$ret, &expr and pos = $pos;
1439             # reverse to before the white space if
1440             # there is no expr
1441             }
1442             elsif(/\Gthrow(?!$id_cont)/cog) {
1443 23         46 push @$ret, 'throw';
1444 23         276 /\G$h/g; # skip horz ws
1445 23 100       1343 @$ret == push @$ret, &expr
1446             and expected 'expression';
1447             }
1448             else { # expression statement
1449 9096 100       78235 $ret = &expr or return;
1450             }
1451              
1452             # Check for optional semicolon
1453 8189 100       87598 m-$optional_sc-cgx
1454             or expected "semicolon, '}' or end of line";
1455             }
1456 9407 100       17539 push @{$$ret[0]},pos unless @{$$ret[0]} == 2; # an expr will
  1851         3358  
  9407         20129  
1457             # already have this
1458              
1459 9407 100       22968 ref $ret eq 'ARRAY' and bless $ret, 'JE::Code::Statement';
1460              
1461 9407         27119 return $ret;
1462             }
1463              
1464             sub statement() { # public
1465 16     16 0 23 my $ret;
1466 16         19 for my $sub(@_stms) {
1467 208 100       3344 defined($ret = &$sub)
1468             and last;
1469             }
1470 10 100       32 defined $ret ? $ret : ()
1471             }
1472              
1473             # This takes care of leading white space.
1474             sub statements() {
1475 1036     1036 0 4255 my $ret = bless [[pos], 'statements'], 'JE::Code::Statement';
1476 1036         7350 /\G$s/g; # skip initial whitespace
1477 1036         9011 while () { # 'last' does not work when 'while' is a
1478             # statement modifier
1479 2937 50       7741 @$ret != push @$ret,
    100          
1480             $_parser ? &statement : &statement_default
1481             or last;
1482             }
1483 1036         1695 push @{$$ret[0]},pos;
  1036         2635  
1484 1036         2741 return $ret;
1485             }
1486              
1487             sub program() { # like statements(), but it allows function declarations
1488             # as well
1489 351     351 0 1721 my $ret = bless [[pos], 'statements'], 'JE::Code::Statement';
1490 351         5363 /\G$s/g; # skip initial whitespace
1491 351 100       21457 if($_parser) {
1492 11         12 while () {
1493             DECL: {
1494 16         18 for my $sub(@_decls) {
  16         28  
1495 0 0       0 @$ret != push @$ret, &$sub
1496             and redo DECL;
1497             }
1498             }
1499 16 100       32 @$ret != push @$ret, &statement or last;
1500             }
1501             }
1502             else {
1503 340         455 while () {
1504 6932         6602 while() {
1505 7064 100       13319 @$ret == push @$ret, &function and last;
1506             }
1507 6932 100       26412 @$ret != push @$ret, &statement_default or last;
1508             }
1509             }
1510 330         688 push @{$$ret[0]},pos;
  330         883  
1511 330         901 return $ret;
1512             }
1513              
1514              
1515             # ~~~ The second arg to add_line_number is a bit ridiculous. I may change
1516             # add_line_number's parameter list, perhaps so it accepts either a
1517             # code object, or (src,file,line) if $_[1] isn'ta JE::Code. I don't
1518             # know....
1519             sub _parse($$$;$$) { # Returns just the parse tree, not a JE::Code object.
1520             # Actually, it returns the source followed by the
1521             # parse tree in list context, or just the parse tree
1522             # in scalar context.
1523 386     386   723 my ($rule, $src, $my_global, $file, $line) = @_;
1524 386         842 local our($_source, $_file, $_line) =($src,$file,$line);
1525              
1526             # Note: We *hafta* stringify the $src, because it could be an
1527             # object with overloading (e.g., JE::String) and we
1528             # need to rely on its pos(), which simply cannot be
1529             # done with an object. Furthermore, perl5.8.5 is
1530             # a bit buggy and sometimes mangles the contents
1531             # of $1 when one does $obj =~ /(...)/.
1532 386 100 100     4559 $src = defined blessed $src && $src->isa("JE::String")
1533             ? $src->value16
1534             : surrogify("$src");
1535              
1536             # remove unicode format chrs
1537 386         52986 $src =~ s/\p{Cf}//g;
1538              
1539             # In HTML mode, modify the whitespace regexps to remove HTML com-
1540             # ment delimiters and following junk up to the end of the line.
1541 386 100       1210 $my_global->html_mode and
1542             local $s = qr((?>
1543             (?> [ \t\x0b\f\xa0\p{Zs}]* )
1544             (?> (?>
1545             $n
1546             (?>(?:
1547             (?>[ \t\x0b\f\xa0\p{Zs}]*) -->
1548             (?>[^\cm\cj\x{2028}\x{2029}]*)(?>$n|\z)
1549             )?)
1550             |
1551             ^
1552             (?>[ \t\x0b\f\xa0\p{Zs}]*) -->
1553             (?>[^\cm\cj\x{2028}\x{2029}]*)(?>$n|\z)
1554             |
1555             (?>//|