5 viv - The STD.pm6 command line multitool
9 viv [options] [file...]
11 -e --evaluate TEXT Use code from the command line
12 --thaw Input is a --freeze dump, not Perl 6
13 -o --output FILE Send result to FILE, not stdout
14 --noperl6lib Disable use of the PERL6LIB variable
15 --symlroot DIR Use DIR as parsed module cache
16 --concise Pretty-print the parse tree (default)
17 -c --check Just check syntax
18 --freeze Generate Storable dump of parse tree
19 -y --yaml Generate YAML parse tree
20 -5 --p5 Translate to Perl 5 syntax
21 -6 --p6 Translate back to Perl 6
22 --psq Translate to Perlesque syntax
23 -s --stab Include symbol table in output
24 -m --match Include match tree in output
25 --no-indent Disable indentation of output
26 -l --log Be verbose while generating output
27 -k --keep-going Don't stop if error found during output phase
28 --compile-setting FILE Preparse a CORE.setting file
35 use warnings FATAL
=> 'all';
37 use List
::Util qw
/sum min/;
40 use YAML
::XS
; # An attempt to replace this with YAML::Syck passed the
41 # tests but produced a different output format that
42 # confused some calling programs. For example, anchors
43 # are usually numbers ascending from 1, and they became
44 # disjoint sets of descending numbers. Also, empty
45 # sequences shown as [] became followed by an empty line.
46 # See also: YAML::Syck in package VAST::package_def below.
48 use Scalar
::Util
'blessed', 'refaddr';
56 our $OPT_keep_going = 0;
57 our $OPT_compile_setting = 0;
58 our $OPT_output_file = undef;
66 # XXX STD Global trait tables simulate inheritence
68 local $::PROTOSIG
= {};
71 # Let's say you have a tricky optimization that breaks the build. You want
72 # to know exactly which rewrite is culpable? Try bisecting with
73 # VIV_OPTLIMIT, after wrapping the rewrite in if (DARE_TO_OPTIMIZE).
74 my $optlimit = $ENV{VIV_OPTLIMIT
};
75 if (defined $optlimit) {
76 *DARE_TO_OPTIMIZE
= Sub
::Name
::subname
(DARE_TO_OPTIMIZE
=> sub {
80 constant
->import(DARE_TO_OPTIMIZE
=> 1);
84 our $OPT_output = 'concise';
88 use Getopt
::Long
2.34 'HelpMessage';
90 my ($boot, $symlroot);
93 $CursorBase::NOPERL6LIB
;
97 "evaluate|e=s" => sub { $PROG .= Encode
::decode_utf8
($_[1]) . "\n" },
99 "noperl6lib" => \
$CursorBase::NOPERL6LIB
,
100 "symlroot" => \
$symlroot,
101 "concise" => sub { $OPT_output = 'concise' },
102 "yaml|y" => sub { $OPT_output = 'yaml' },
103 "output|o=s" => \
$OPT_output_file,
104 "p5|5" => sub { $OPT_output = 'p5' },
105 "p6|6" => sub { $OPT_output = 'p6' },
106 "psq" => sub { $OPT_output = 'psq' },
107 "freeze" => sub { $OPT_output = 'store' },
108 "check|c" => sub { $OPT_output = 'none' },
109 "stab|s" => \
$OPT_stab,
110 "log|l" => \
$OPT_log,
113 no warnings
'redefine';
114 *indent
= \
&no_indent
;
117 "match|m" => \
$OPT_match,
118 "thaw" => \
$OPT_thaw,
119 "keep-going|k" => \
$OPT_keep_going,
120 "compile-setting=s" => \
$OPT_compile_setting,
121 "help" => sub { HelpMessage
() }
124 unshift @INC, $FindBin::Bin
;
127 unshift @INC, File
::Spec
->catdir($FindBin::Bin
, "boot");
128 $CursorBase::SET_STD5PREFIX
= "boot";
129 $CursorBase::NOSTDSYML
= 1;
131 if (defined $symlroot) {
132 $CursorBase::SET_STD5PREFIX
= $symlroot;
140 $bits .= "\n" unless $bits ~~ /\n\z/;
141 if (defined $OPT_output_file) {
142 open my $out, ">", $OPT_output_file
143 or die "cannot open $OPT_output_file for writing: $!";
144 binmode $out, ":utf8";
145 print $out $bits or die "cannot write: $!";
146 close $out or die "cannot close: $!";
152 sub no_indent
{ $_[0] }
155 my ($arg, $leader) = @_;
157 $arg =~ s/\n/\n$leader/g;
164 for my $i (0 .. $#_) {
165 $r .= ($i == $#_) ?
"\n└─" : "\n├─";
166 $r .= hang
($_[$i], $i == $#_ ?
" " : "│ ");
172 my ($first, $rest, $tx) = @_;
175 while (length $tx > $first) {
176 $out .= substr($tx, 0, $first);
178 $tx = substr($tx, $first);
186 my ($node, $width) = @_;
188 $width = 30 if $width < 30;
191 return defined($node) ? shred
($width, $width, "$node") : "undef";
192 } elsif (blessed
($node) && ref($node) =~ /^VAST/) {
194 ref($node->{"."}) eq 'ARRAY' ? @
{$node->{"."}} :
195 defined($node->{"."}) ?
$node->{"."} :
201 # don't list the same node twice
202 my %inpos = map { ref($_) ?
(refaddr
($_) , 1) : () } @pos;
204 @pos = map { concise
($_, $width-2) } @pos;
207 my $title = blessed
$node;
208 my $x = length($title);
209 for my $ch (sort keys %nam) {
210 next if $ch eq '_fate';
212 # hide named children that are just (lists of) positional children
213 if ($inpos{refaddr
($nam{$ch})}) { next }
214 if (ref($nam{$ch}) eq 'ARRAY') {
216 for (@
{$nam{$ch}}) { $all = 0 unless ref $_ && $inpos{refaddr
$_} }
221 my $repr = concise
($nam{$ch}, $width-4);
223 if ($repr !~ /\n/ && length $repr < 30) {
224 if ($x + length($ch) + length($repr) + 6 > $width) {
231 $title .= "$ch: $repr";
232 $x += length("$ch: $repr");
234 my $hang = " " x
(length($ch)+2);
235 push @oobnam, "$ch: " . hang
($repr, $hang);
239 $title = hang
($title, (@pos ?
"│ " : " ") . (@oobnam ?
"│ " : " "));
243 $result .= hang
(listify
(@oobnam), @pos ?
"│ " : " ");
244 $result .= listify
(@pos);
249 return substr($d, 4, length($d)-5);
253 # viv should likely be abstracted into a module instead of doing this hack... - pmurias
256 $OPT_match = $opt{match
};
257 $OPT_log = $opt{log};
262 return $text unless $text =~ /\n/;
263 my @text = split(/^/, $text);
267 $in_begin = $1 if /^=begin\s+(\w+)/;
268 $in_for = 1 if /^=for/;
269 $in_for = 0 if /^\s*$/;
270 my $docomment = $in_begin || $in_for;
271 $in_begin = 0 if /^=end\s+(\w+)/ and $1 eq $in_begin;
272 s/^/# / if $docomment;
277 # rules of thumb: a block (0 or more statements) is a chunk of text, use
278 # indent. for expressions, the overall philosophy is that the indentation
279 # of a line should be proportional to the number of outstanding syntactic
293 $out .= $1 if $in =~ s/^\\([\\'])//;
294 $out .= $1 if $in =~ s/^(.)//;
299 # XXX this is only used for backslash escapes in regexes
303 my %trans = ( 'n' => "\n" );
305 $out .= $trans{$1} // $1 if $in =~ s/^\\(.)//;
306 $out .= $1 if $in =~ s/^(.)//;
314 for my $ch (split //, $in) {
315 $out .= $ch eq "\n" ?
'\n' : quotemeta($ch);
320 ###################################################################
322 { package VAST
::Base
;
324 sub Str
{ my $self = shift;
325 my $b = $self->{BEG
};
326 my $e = $self->{END};
327 return '' if $b > length($ORIG);
328 substr($ORIG, $b, $e - $b);
331 sub kids
{ my $self = shift;
332 my $key = shift() // '.';
333 return () unless exists $self->{$key};
334 my $entry = $self->{$key};
335 return ref($entry) eq 'ARRAY' ? @
$entry : $entry;
338 sub emit_p6
{ my $self = shift;
340 if (exists $self->{'.'}) {
341 my $last = $self->{BEG
};
342 my $all = $self->{'.'};
344 for my $kid (ref($all) eq 'ARRAY' ? @
$all : $all) {
346 if (not defined $kid->{BEG
}) {
347 $kid->{BEG
} = $kid->{_from
} // next;
348 $kid->{END} = $kid->{_pos
};
352 for my $kid (sort { $a->{BEG
} <=> $b->{BEG
} } @kids) {
353 my $kb = $kid->{BEG
};
355 push @text, substr($ORIG, $last, $kb - $last);
357 if (ref($kid) eq 'HASH') {
358 print STDERR
::Dump
($self);
359 die "in a weird place";
361 push @text, scalar $kid->p6;
365 my $se = $self->{END};
367 push @text, substr($ORIG, $last, $se - $last);
371 # print STDERR "OOPS " . ref($self) . " $$self{TEXT}\n";
372 push @text, $self->{TEXT
};
374 wantarray ?
@text : join('', @text);
377 sub emit_p5
{ my $self = shift;
379 if (exists $self->{'.'}) {
380 my $last = $self->{BEG
};
381 my $all = $self->{'.'};
383 for my $kid (ref($all) eq 'ARRAY' ? @
$all : $all) {
385 if (not defined $kid->{BEG
}) {
386 $kid->{BEG
} = $kid->{_from
} // next;
387 $kid->{END} = $kid->{_pos
};
391 for my $kid (sort { $a->{BEG
} <=> $b->{BEG
} } @kids) {
392 my $kb = $kid->{BEG
};
394 push @text, substr($ORIG, $last, $kb - $last);
396 if (ref($kid) eq 'HASH') {
397 print STDERR
::Dump
($self);
398 die "in a weird place";
400 push @text, scalar $kid->p5;
404 my $se = $self->{END};
406 push @text, substr($ORIG, $last, $se - $last);
410 # print STDERR "OOPS " . ref($self) . " $$self{TEXT}\n";
411 push @text, $self->{TEXT
};
413 wantarray ?
@text : join('', @text);
417 my $tpl = <<'TEMPLATE';
418 sub VAST::Base::FORM { my $self = shift; my $lvl = @context;
420 say STDERR ' ' x $lvl, ref $self, " from ",$self->{BEG}," to ",$self->{END} if $OPT_log;
421 $context[$lvl] = $self;
422 # print STDERR "HERE " . ref($self) . "\n";
423 local $SIG{__DIE__} = sub {
425 $args[-1] =~ s/ at .*? line .*?\n$//s if $args[-1] =~ /\n$/s;
426 die Carp::longmess(@args);
428 my @bits = !$OPT_keep_going ? $self->emit_FORM(@_) : (::try {
429 $self->emit_FORM(@_);
431 my $char = $self->{BEG} // $self->{_from} // 0;
432 my $line = 1 + (substr($ORIG, 0, $char) =~ y/\n/\n/);
433 say STDERR "!!! FAILED at $char (L$line)";
437 my $val = join '', @bits;
438 my @c = map { ref $_ } @context;
441 say STDERR ' ' x ($lvl-1), "$c returns $val\n" if $OPT_log;
442 # Note that we may have skipped levels, so you can't just pop
443 splice(@context,$lvl);
444 wantarray ? @bits : $val;
447 for my $format (qw
/p5 p6 psq/) {
449 $t =~ s/FORM/$format/g;
454 sub gap
{ my $self = shift;
456 my $beg = $self->{END};
457 my $end = $after->{BEG
};
458 return '' unless $beg && $end;
459 return substr($ORIG, $beg, $end - $beg);
462 sub base_re_quantifier
{ my $self = shift; my $x = shift; my $min = shift;
463 my $qm = $self->{quantmod
}->Str;
465 $qm ||= $::RATCHET ?
':' : '!';
467 return [ $self->{SYM
}, $qm, $x, $min ];
471 { package VAST
::ViaDEEP
;
472 sub emit_psq
{ my $self = shift;
473 $self->_deep->psqexpr;
477 { package VAST
::InfixCall
;
478 sub emit_psq
{ my $self = shift;
479 return DEEP
::call
("infix:<" . $self->{infix
}{SYM
} . ">",
480 map { DEEP
::raw
($_->psq) } $self->kids('args'))->psqexpr;
484 { package VAST
::Str
; our @ISA = 'VAST::Base';
485 sub emit_p5
{ my $self = shift;
486 return $self->{TEXT
};
488 sub emit_p6
{ my $self = shift;
489 return $self->{TEXT
};
493 { package VAST
::Additive
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
494 sub emit_p5
{ my $self = shift;
495 my @t = $self->SUPER::emit_p5
;
496 if ($t[0] eq '*') { # *-1
503 { package VAST
::Adverb
; our @ISA = 'VAST::Base';
504 sub emit_p5
{ my $self = shift;
505 my @t = $self->SUPER::emit_p5
;
507 if ($adv eq ':delete' or $adv eq ':exists') {
509 unshift(@t, $adv . ' ');
516 { package VAST
::apostrophe
; our @ISA = 'VAST::Base';
520 { package VAST
::arglist
; our @ISA = 'VAST::Base';
524 { package VAST
::args
; our @ISA = 'VAST::Base';
525 sub deepn
{ my $self = shift;
526 my $al = $self->{arglist
}[0] // $self->{semiarglist
}{arglist
}[0];
528 $al = $al->{EXPR
} or return;
530 if ($al->isa('VAST::infix__S_Comma')) {
531 return map { DEEP
::raw
($_->psq) } $al->kids('args');
533 return DEEP
::raw
($al->psq);
539 { package VAST
::assertion
; our @ISA = 'VAST::Base';
543 { package VAST
::assertion__S_Bang
; our @ISA = 'VAST::Base';
544 sub re_ast
{ my $self = shift;
545 my $ast = $self->{assertion
} ?
$self->{assertion
}->re_ast
548 RE_assertion
->new(assert
=> '!', re
=> $ast);
553 { package VAST
::assertion__S_Bra
; our @ISA = 'VAST::Base';
554 sub re_ast
{ my $self = shift;
555 my $cclass = $self->Str;
556 $cclass =~ s/\\x([0-9a-fA-F]{3,4})/\\x\{$1\}/g;
557 RE_cclass
->new(text
=> $cclass);
561 { package VAST
::assertion__S_Minus
; our @ISA = 'VAST::assertion__S_Bra';
564 { package VAST
::assertion__S_Plus
; our @ISA = 'VAST::assertion__S_Bra';
568 { package VAST
::assertion__S_Cur_Ly
; our @ISA = 'VAST::Base';
569 sub re_ast
{ my $self = shift;
570 local $::NEEDMATCH
= 0;
571 my $text = $self->{embeddedblock
}{statementlist
}->p5;
572 $text = "my \$M = \$C;\n" . $text if $::NEEDMATCH
;
573 RE_block
->new(body
=> $text, context
=> 'bool');
578 { package VAST
::assertion__S_DotDotDot
; our @ISA = 'VAST::Base';
582 { package VAST
::assertion__S_method
; our @ISA = 'VAST::Base';
583 sub re_ast
{ my $self = shift;
584 my $ast = $self->{assertion
}->re_ast;
591 { package VAST
::assertion__S_name
; our @ISA = 'VAST::Base';
592 sub re_ast
{ my $self = shift;
593 my $name = $self->{longname
}->Str;
595 if ($self->{nibbler
}[0]) {
596 local $::DBA
= $::DBA
;
597 local $::RATCHET
= $::RATCHET
;
598 local $::SIGSPACE
= $::SIGSPACE
;
599 local $::IGNORECASE
= $::IGNORECASE
;
600 return RE_method_re
->new(name
=> $name,
601 re
=> $self->{nibbler
}[0]{"."}->re_ast);
604 if ($self->{assertion
}[0]) {
605 return RE_bindnamed
->new(var
=> $name,
606 atom
=> $self->{assertion
}[0]->re_ast);
609 if ($name eq 'sym' && defined $::ENDSYM
) {
610 return RE_sequence
->new(
611 RE_method
->new(name
=> $name, sym
=> $::SYM
),
612 RE_method
->new(name
=> $::ENDSYM
, nobind
=> 1));
615 my $al = $self->{arglist
}[0];
616 local $::NEEDMATCH
= 0;
617 $al = defined $al ?
"(" . $al->p5 . ")" : undef;
618 RE_method
->new(name
=> $name, ($name eq 'sym' ?
(sym
=> $::SYM
) : ()),
619 rest
=> $al, need_match
=> $::NEEDMATCH
);
624 { package VAST
::assertion__S_Question
; our @ISA = 'VAST::Base';
625 sub re_ast
{ my $self = shift;
626 my $ast = $self->{assertion
} ?
$self->{assertion
}->re_ast
629 RE_assertion
->new(assert
=> '?', re
=> $ast);
634 { package VAST
::atom
; our @ISA = 'VAST::Base';
635 sub re_ast
{ my $self = shift;
636 if (exists $self->{TEXT
}) {
637 RE_string
->new(text
=> $self->{TEXT
});
639 $self->{metachar
}->re_ast;
645 { package VAST
::Autoincrement
; our @ISA = 'VAST::Base';
649 { package VAST
::babble
; our @ISA = 'VAST::Base';
653 { package VAST
::backslash
; our @ISA = 'VAST::Base';
657 { package VAST
::backslash__S_Back
; our @ISA = 'VAST::Base';
661 { package VAST
::backslash__S_d
; our @ISA = 'VAST::Base';
665 { package VAST
::backslash__S_h
; our @ISA = 'VAST::Base';
669 { package VAST
::backslash__S_misc
; our @ISA = 'VAST::Base';
673 { package VAST
::backslash__S_n
; our @ISA = 'VAST::Base';
677 { package VAST
::backslash__S_s
; our @ISA = 'VAST::Base';
681 { package VAST
::backslash__S_stopper
; our @ISA = 'VAST::Base';
685 { package VAST
::backslash__S_t
; our @ISA = 'VAST::Base';
689 { package VAST
::backslash__S_v
; our @ISA = 'VAST::Base';
693 { package VAST
::backslash__S_w
; our @ISA = 'VAST::Base';
697 { package VAST
::backslash__S_x
; our @ISA = 'VAST::Base';
698 sub emit_p5
{ my $self = shift;
699 my @t = $self->SUPER::emit_p5
;
706 { package VAST
::before
; our @ISA = 'VAST::Base';
710 { package VAST
::block
; our @ISA = 'VAST::Base';
714 { package VAST
::blockoid
; our @ISA = 'VAST::Base';
715 sub emit_p5
{ my $self = shift;
716 "{\n" . ::indent
(scalar($self->{statementlist
}->p5), 1) . "}";
721 { package VAST
::capterm
; our @ISA = 'VAST::Base';
725 { package VAST
::cclass_elem
; our @ISA = 'VAST::Base';
729 { package VAST
::Chaining
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
733 { package VAST
::circumfix
; our @ISA = 'VAST::Base';
737 { package VAST
::circumfix__S_Bra_Ket
; our @ISA = 'VAST::Base';
741 { package VAST
::circumfix__S_Cur_Ly
; our @ISA = 'VAST::Base';
745 { package VAST
::circumfix__S_Paren_Thesis
; our @ISA = 'VAST::Base';
749 { package VAST
::circumfix__S_sigil
; our @ISA = 'VAST::Base';
753 { package VAST
::codeblock
; our @ISA = 'VAST::Base';
757 { package VAST
::colonpair
; our @ISA = 'VAST::Base';
758 sub adverbs
{ my $self = shift;
760 if (Scalar
::Util
::blessed
$self->{v
} &&
761 $self->{v
}->isa('VAST::coloncircumfix')) {
762 my $s = $self->{v
}->Str;
763 my $val = $s =~ /^<\s*(.*?)\s*>$/ ?
::unsingle
($1) :
764 $s =~ /^«\s*(.*?)\s*»$/ ?
::undouble
($1) :
765 $s =~ /^\['(.*)'\]$/ ?
::unsingle
($1) :
766 die "Unparsable coloncircumfix";
767 return $self->{k
} => $val;
768 } elsif ($self->{v
} == 1) {
769 return "sym" => $self->{k
};
771 die "Unsupported compile-time adverb " . $self->Str;
777 { package VAST
::Comma
; our @ISA = 'VAST::Base';
782 { package VAST
::comp_unit
; our @ISA = 'VAST::Base';
783 sub emit_p5
{ my $self = shift;
784 "use 5.010;\nuse utf8;\n" . $self->{statementlist
}->p5, "\n";
786 sub emit_p6
{ my $self = shift;
787 substr($ORIG, 0, $self->{statementlist
}{BEG
}),
788 $self->{statementlist
}->p5;
790 sub emit_psq
{ my $self = shift;
792 my $body = $self->{statementlist
}->psq;
793 for (sort keys %::PRELUDE
) {
796 $body = "use \"$fn.psq\";\n$body";
802 { package VAST
::Concatenation
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
806 { package VAST
::Conditional
; our @ISA = 'VAST::Base';
807 sub emit_p5
{ my $self = shift;
808 my @t = $self->SUPER::emit_p5
;
818 { package VAST
::CORE
; our @ISA = 'VAST::Base';
822 { package VAST
::declarator
; our @ISA = 'VAST::Base';
823 sub emit_p5
{ my $self = shift;
824 if ($self->{signature
}) {
825 return "(" . join(", ", map { $_->{param_var
}->Str }
826 $self->{signature
}->kids('parameter')) . ")";
828 return $self->SUPER::emit_p5
;
832 sub emit_psq
{ my $self = shift;
833 if ($self->{variable_declarator
}) {
834 $self->{variable_declarator
}->psq(@_);
835 } elsif ($self->{signature
}) {
836 $self->{signature
}->psq(@_, declaring
=> 1);
837 } elsif ($self->{routine_declarator
}) {
838 $self->{routine_declarator
}->psq(@_);
839 } elsif ($self->{regex_declarator
}) {
840 $self->{regex_declarator
}->psq(@_);
841 } elsif ($self->{type_declarator
}) {
842 $self->{type_declarator
}->psq(@_);
848 { package VAST
::default_value
; our @ISA = 'VAST::Base';
852 { package VAST
::deflongname
; our @ISA = 'VAST::Base';
853 sub adverbs
{ my $self = shift;
854 map { $_->adverbs } $self->kids('colonpair');
859 { package VAST
::def_module_name
; our @ISA = 'VAST::Base';
863 { package VAST
::desigilname
; our @ISA = 'VAST::Base';
867 { package VAST
::dotty
; our @ISA = 'VAST::Base';
871 { package VAST
::dotty__S_Dot
; our @ISA = 'VAST::Methodcall';
875 { package VAST
::SYM_dotty__S_Dot
; our @ISA = 'VAST::Base';
879 { package VAST
::dottyop
; our @ISA = 'VAST::Base';
883 { package VAST
::eat_terminator
; our @ISA = 'VAST::Base';
887 { package VAST
::escape
; our @ISA = 'VAST::Base';
891 { package VAST
::escape__S_At
; our @ISA = 'VAST::Base';
895 { package VAST
::escape__S_Back
; our @ISA = 'VAST::Base';
899 { package VAST
::escape__S_Dollar
; our @ISA = 'VAST::Base';
903 { package VAST
::EXPR
; our @ISA = 'VAST::Base';
907 { package VAST
::fatarrow
; our @ISA = 'VAST::Base';
911 { package VAST
::fulltypename
; our @ISA = 'VAST::Base';
915 { package VAST
::hexint
; our @ISA = 'VAST::Base';
919 { package VAST
::ident
; our @ISA = 'VAST::Base';
923 { package VAST
::identifier
; our @ISA = 'VAST::Base';
927 { package VAST
::index; our @ISA = 'VAST::Base';
932 { package VAST
::infix
; our @ISA = 'VAST::Base';
935 { package VAST
::infix_prefix_meta_operator__S_Bang
; our @ISA = 'VAST::Base';
936 sub emit_p5
{ my $self = shift;
937 my @t = $self->SUPER::emit_p5
;
938 $t[1] = '~' if $t[1] eq '=~';
939 $t[1] = '=' if $t[1] eq '==';
940 @t = ('ne', '') if $t[1] eq 'eq';
945 { package VAST
::SYM_infix__S_ColonEqual
; our @ISA = 'VAST::Item_assignment';
946 sub emit_p5
{ my $self = shift;
947 my @t = $self->SUPER::emit_p5
;
948 $t[0] = '='; # XXX oversimplified
953 { package VAST
::SYM_infix__S_ColonColonEqual
; our @ISA = 'VAST::Item_assignment';
954 sub emit_p5
{ my $self = shift;
955 my @t = $self->SUPER::emit_p5
;
956 $t[0] = '='; # XXX oversimplified
962 { package VAST
::infixish
; our @ISA = 'VAST::Base';
966 { package VAST
::SYM_infix__S_PlusAmp
; our @ISA = 'VAST::Multiplicative';
967 sub emit_p5
{ my $self = shift;
968 my @t = $self->SUPER::emit_p5
;
974 { package VAST
::SYM_infix__S_eqv
; our @ISA = 'VAST::Chaining';
975 sub emit_p5
{ my $self = shift;
976 my @t = $self->SUPER::emit_p5
;
982 { package VAST
::SYM_infix__S_leg
; our @ISA = 'VAST::Structural_infix';
983 sub emit_p5
{ my $self = shift;
984 my @t = $self->SUPER::emit_p5
;
990 { package VAST
::SYM_infix__S_EqualEqualEqual
; our @ISA = 'VAST::Chaining';
991 sub emit_p5
{ my $self = shift;
992 my @t = $self->SUPER::emit_p5
;
993 $t[0] = '=='; # only correct for objects (and ints)
998 { package VAST
::SYM_infix__S_orelse
; our @ISA = 'VAST::Loose_or';
999 sub emit_p5
{ my $self = shift;
1000 my @t = $self->SUPER::emit_p5
;
1006 { package VAST
::SYM_infix__S_andthen
; our @ISA = 'VAST::Loose_and';
1007 sub emit_p5
{ my $self = shift;
1008 my @t = $self->SUPER::emit_p5
;
1014 { package VAST
::SYM_infix__S_PlusVert
; our @ISA = 'VAST::Additive';
1015 sub emit_p5
{ my $self = shift;
1016 my @t = $self->SUPER::emit_p5
;
1023 { package VAST
::SYM_infix__S_Tilde
; our @ISA = 'VAST::Concatenation';
1024 sub emit_p5
{ my $self = shift;
1025 my @t = $self->SUPER::emit_p5
;
1032 { package VAST
::SYM_infix__S_TildeTilde
; our @ISA = 'VAST::Chaining';
1033 sub emit_p5
{ my $self = shift;
1034 my @t = $self->SUPER::emit_p5
;
1040 { package VAST
::SYM_infix__S_TildeVert
; our @ISA = 'VAST::Additive';
1041 sub emit_p5
{ my $self = shift;
1042 my @t = $self->SUPER::emit_p5
;
1049 { package VAST
::integer
; our @ISA = 'VAST::Base';
1053 { package VAST
::Item_assignment
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1057 { package VAST
::Junctive_or
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1061 { package VAST
::label
; our @ISA = 'VAST::Base';
1065 { package VAST
::lambda
; our @ISA = 'VAST::Base';
1066 sub emit_p5
{ my $self = shift;
1067 my @t = $self->SUPER::emit_p5
;
1074 { package VAST
::left
; our @ISA = 'VAST::Base';
1078 { package VAST
::List_assignment
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1082 { package VAST
::litchar
; our @ISA = 'VAST::Base';
1086 { package VAST
::longname
; our @ISA = 'VAST::Base';
1087 sub adverbs
{ my $self = shift;
1088 map { $_->adverbs } $self->kids('colonpair');
1093 { package VAST
::Loose_and
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1097 { package VAST
::Loose_or
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1101 { package VAST
::Loose_unary
; our @ISA = 'VAST::Base';
1105 { package VAST
::metachar
; our @ISA = 'VAST::Base';
1106 sub re_ast
{ my $self = shift;
1107 RE_meta
->new(text
=> $self->Str);
1112 { package VAST
::metachar__S_Back
; our @ISA = 'VAST::metachar';
1113 sub re_ast
{ my $self = shift;
1114 RE_meta
->new(text
=> $self->Str, min
=> 1);
1119 { package VAST
::metachar__S_Bra_Ket
; our @ISA = 'VAST::Base';
1120 sub re_ast
{ my $self = shift;
1121 local $::DBA
= $::DBA
;
1122 local $::RATCHET
= $::RATCHET
;
1123 local $::SIGSPACE
= $::SIGSPACE
;
1124 local $::IGNORECASE
= $::IGNORECASE
;
1127 my $bodyast = $self->{nibbler
}{"."}->re_ast;
1128 RE_bracket
->new(decl
=> \@
::DECLAST
, re
=> $bodyast);
1133 { package VAST
::metachar__S_Caret
; our @ISA = 'VAST::metachar';
1137 { package VAST
::metachar__S_CaretCaret
; our @ISA = 'VAST::metachar';
1140 { package VAST
::metachar__S_ColonColon
; our @ISA = 'VAST::metachar';
1143 { package VAST
::metachar__S_ColonColonColon
; our @ISA = 'VAST::metachar';
1146 { package VAST
::metachar__S_ColonColonKet
; our @ISA = 'VAST::metachar';
1150 { package VAST
::metachar__S_Cur_Ly
; our @ISA = 'VAST::Base';
1151 sub re_ast
{ my $self = shift;
1152 local $::NEEDMATCH
= 0;
1153 my $text = $self->{embeddedblock
}{statementlist
}->p5;
1154 $text = "my \$M = \$C;\n" . $text if $::NEEDMATCH
;
1155 RE_block
->new(body
=> $text, context
=> 'void');
1160 { package VAST
::metachar__S_Dollar
; our @ISA = 'VAST::metachar';
1164 { package VAST
::metachar__S_DollarDollar
; our @ISA = 'VAST::metachar';
1168 { package VAST
::metachar__S_Dot
; our @ISA = 'VAST::metachar';
1169 sub re_ast
{ my $self = shift;
1170 RE_meta
->new(text
=> $self->Str, min
=> 1);
1175 { package VAST
::metachar__S_Double_Double
; our @ISA = 'VAST::Base';
1176 sub re_ast
{ my $self = shift;
1177 my $text = ::undouble
($self->{quote
}{nibble
}->Str);
1178 RE_double
->new(text
=> $text);
1183 { package VAST
::metachar__S_Lt_Gt
; our @ISA = 'VAST::Base';
1184 sub re_ast
{ my $self = shift;
1185 $self->{assertion
}->re_ast;
1190 { package VAST
::metachar__S_mod
; our @ISA = 'VAST::Base';
1191 sub re_ast
{ my $self = shift;
1192 $self->{mod_internal
}->re_ast;
1197 { package VAST
::metachar__S_Nch
; our @ISA = 'VAST::metachar';
1201 { package VAST
::metachar__S_Paren_Thesis
; our @ISA = 'VAST::Base';
1202 sub re_ast
{ my $self = shift;
1203 local $::DBA
= $::DBA
;
1204 local $::RATCHET
= $::RATCHET
;
1205 local $::SIGSPACE
= $::SIGSPACE
;
1206 local $::IGNORECASE
= $::IGNORECASE
;
1209 my $bodyast = $self->{nibbler
}{"."}->re_ast;
1210 # XXX STD gimme5 disables binding to $0 in $<foo> = (bar)
1211 my $inner = RE_paren
->new(decl
=> \@
::DECLAST
, re
=> $bodyast);
1212 $::PARSENAME ?
$inner : RE_bindpos
->new(var
=> $::PAREN
++, atom
=> $inner)
1217 { package VAST
::metachar__S_qw
; our @ISA = 'VAST::Base';
1218 sub re_ast
{ my $self = shift;
1220 my @elems = split(' ', $self->{circumfix
}{nibble
}->Str);
1222 my $l = ::min
(1_000_000_000
, map { length } @elems);
1223 RE_qw
->new(min
=> $l, text
=> $self->Str);
1228 { package VAST
::metachar__S_sigwhite
; our @ISA = 'VAST::Base';
1229 sub re_ast
{ my $self = shift;
1231 RE_method
->new(name
=> 'ws', nobind
=> 1) :
1237 { package VAST
::metachar__S_Single_Single
; our @ISA = 'VAST::Base';
1238 sub re_ast
{ my $self = shift;
1239 my $text = ::unsingle
($self->{quote
}{nibble
}->Str);
1240 RE_string
->new(text
=> $text);
1245 { package VAST
::metachar__S_var
; our @ISA = 'VAST::Base';
1246 sub re_ast
{ my $self = shift;
1247 # We don't un6 because some things need to un6 specially - backrefs
1248 if ($self->{binding
}) {
1249 local $::PARSENAME
= 1;
1250 $self->{SYM
} =~ /^\$<(.*)>$/ or die "Can't bind backref to " . $self->{SYM
};
1251 RE_bindnamed
->new(var
=> $1, atom
=>
1252 $self->{binding
}{quantified_atom
}->re_ast);
1254 RE_var
->new(var
=> $self->{termish
}->p5);
1260 { package VAST
::Methodcall
; our @ISA = 'VAST::Base';
1261 sub emit_p5
{ my $self = shift;
1262 my @t = $self->SUPER::emit_p5
;
1264 my $first = shift @t;
1265 my $second = join '', @t;
1266 @t = ($first,$second);
1268 if ($t[1] eq '.pos') { $t[1] = '.<_pos>'; }
1269 $t[1] =~ s/^(\.?)<(.*)>$/$1\{'$2'\}/;
1270 if ($t[0] =~ /^[@%]/) {
1271 if ($t[1] =~ s/^\.?([[{])/$1/) {
1273 substr($t[0],0,1) = '@';
1276 substr($t[0],0,1) = '$';
1281 elsif ($t[1] =~ /^[[{]/) {
1282 $t[1] =~ s/^([[{])/.$1/;
1284 elsif ($t[0] =~ s/^&(\w+)/\$$1/) {
1285 $t[1] =~ s/^\(/->(/;
1288 my $t = join('', @t);
1289 $t =~ s/^(.*\S)\s*:(delete|exists)/$2 $1/;
1290 # print STDERR ::Dump(\@t);
1296 { package VAST
::method_def
; our @ISA = 'VAST::Base';
1297 sub emit_p5
{ my $self = shift;
1298 my $name = $self->{longname
} ?
$self->{longname
}->p5 . " " : "";
1299 my $sig = $self->{multisig
}[0] ?
$self->{multisig
}[0]->p5 : "";
1300 my $body = $self->{blockoid
}{statementlist
}->p5;
1302 if ($::MULTINESS
eq 'multi') {
1303 $::MULTIMETHODS
{$name} .= <<EOT
1306 return scalar do { # work around #38809
1309 . ::indent
($sig . $body, 2) . <<EOT
1317 # not quite right, this should be an expression
1318 ($name eq 'EXPR' ?
# XXX STD
1319 "sub EXPR__PEEK { \$_[0]->_AUTOLEXpeek(\'EXPR\',\$retree) }\n" : '').
1320 "sub " . $name . "{\n" .
1321 ::indent
("no warnings 'recursion';\nmy \$self = shift;\n" .
1328 { package VAST
::methodop
; our @ISA = 'VAST::Base';
1332 { package VAST
::modifier_expr
; our @ISA = 'VAST::Base';
1336 { package VAST
::mod_internal
; our @ISA = 'VAST::Base';
1340 { package VAST
::mod_internal__S_p6adv
; our @ISA = 'VAST::Base';
1341 sub re_ast
{ my $self = shift;
1342 my $key = $self->{quotepair
}{k
};
1344 if ($key eq 'dba') {
1345 $::DBA
= eval ($self->{quotepair
}{circumfix
}[0]->Str);
1346 } elsif ($key eq 'lang') {
1347 my $lang = $self->{quotepair
}{circumfix
}[0]->p5;
1348 return RE_decl
->new(body
=> <<BODY);
1349 my \$newlang = $lang;
1350 \$C = bless(\$C, (ref(\$newlang) || \$newlang));
1353 die "unhandled internal adverb $key";
1361 { package VAST
::mod_internal__S_ColonBangs
; our @ISA = 'VAST::Base';
1365 { package VAST
::mod_internal__S_Coloni
; our @ISA = 'VAST::Base';
1366 sub re_ast
{ my $self = shift;
1372 { package VAST
::mod_internal__S_Colonr
; our @ISA = 'VAST::Base';
1373 sub re_ast
{ my $self = shift;
1380 { package VAST
::mod_internal__S_Colonmy
; our @ISA = 'VAST::Base';
1381 sub re_ast
{ my $self = shift;
1382 local $::NEEDMATCH
= 0;
1383 my $text = $self->{statement
}->p5 . ";";
1384 $text = "my \$M = \$C;\n" . $text if $::NEEDMATCH
;
1386 push @
::DECLAST
, RE_decl
->new(body
=> $text);
1392 { package VAST
::mod_internal__S_Colons
; our @ISA = 'VAST::Base';
1393 sub re_ast
{ my $self = shift;
1400 { package VAST
::mod_internal__S_ColonBangs
; our @ISA = 'VAST::Base';
1401 sub re_ast
{ my $self = shift;
1408 { package VAST
::module_name
; our @ISA = 'VAST::Base';
1412 { package VAST
::module_name__S_normal
; our @ISA = 'VAST::Base';
1416 { package VAST
::morename
; our @ISA = 'VAST::Base';
1420 { package VAST
::multi_declarator
; our @ISA = 'VAST::Base';
1421 sub emit_psq
{ my $self = shift;
1422 if ($self->{declarator
}) {
1423 $self->{declarator
}->psq(@_, multiness
=> $self->{SYM
});
1425 $self->{routine_def
}->psq(@_, multiness
=> $self->{SYM
});
1431 { package VAST
::multi_declarator__S_multi
; our @ISA = 'VAST::multi_declarator';
1432 sub emit_p5
{ my $self = shift;
1433 local $::MULTINESS
= 'multi';
1439 { package VAST
::multi_declarator__S_null
; our @ISA = 'VAST::multi_declarator';
1443 { package VAST
::multi_declarator__S_proto
; our @ISA = 'VAST::multi_declarator';
1444 sub emit_p5
{ my $self = shift;
1445 local $::MULTINESS
= 'proto';
1451 { package VAST
::Multiplicative
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
1454 # We don't currently do MMD so no need for later sigs
1455 { package VAST
::multisig
; our @ISA = 'VAST::Base';
1456 sub emit_p5
{ my $self = shift;
1457 $self->{signature
}[0]->p5;
1462 { package VAST
::name
; our @ISA = 'VAST::Base';
1466 { package VAST
::named_param
; our @ISA = 'VAST::Base';
1470 { package VAST
::Named_unary
; our @ISA = 'VAST::Base';
1473 { package VAST
::nibbler
; our @ISA = 'VAST::Base';
1477 { package VAST
::nofun
; our @ISA = 'VAST::Base';
1481 { package VAST
::normspace
; our @ISA = 'VAST::Base';
1486 { package VAST
::nulltermish
; our @ISA = 'VAST::Base';
1490 { package VAST
::number
; our @ISA = 'VAST::Base';
1491 sub emit_psq
{ my $self = shift;
1492 die "unsupported literal format" unless $self->{integer
}{decint
};
1493 my $str = $self->{integer
}{decint
}->Str;
1500 { package VAST
::number__S_numish
; our @ISA = 'VAST::Base';
1504 { package VAST
::numish
; our @ISA = 'VAST::Base';
1508 { package VAST
::opener
; our @ISA = 'VAST::Base';
1512 { package VAST
::package_declarator
; our @ISA = 'VAST::Base';
1513 sub emit_psq
{ my $self = shift;
1514 local $::PKGDECL
= $self->{SYM
};
1515 $self->{package_def
}->psq;
1520 { package VAST
::package_declarator__S_class
; our @ISA = 'VAST::package_declarator';
1521 sub emit_p5
{ my $self = shift;
1522 local $::PKGDECL
= 'class';
1523 $self->{package_def
}->p5;
1528 { package VAST
::package_declarator__S_grammar
; our @ISA = 'VAST::package_declarator';
1529 sub emit_p5
{ my $self = shift;
1530 local $::PKGDECL
= 'grammar';
1531 $self->{package_def
}->p5;
1536 { package VAST
::package_declarator__S_role
; our @ISA = 'VAST::package_declarator';
1537 sub emit_p5
{ my $self = shift;
1538 local $::PKGDECL
= 'role';
1539 $self->{package_def
}->p5;
1543 { package VAST
::package_declarator__S_knowhow
; our @ISA = 'VAST::package_declarator';
1544 sub emit_p5
{ my $self = shift;
1545 local $::PKGDECL
= 'knowhow';
1546 $self->{package_def
}->p5;
1551 { package VAST
::package_def
; our @ISA = 'VAST::Base';
1552 sub module_name
{ my $self = shift;
1553 my $def_module_name = $self->{longname
}[0]{name
}->Str;
1554 if ($self->{decl
}{inpkg
}[0] =~ /GLOBAL::(.*)/) {
1556 for ($mod) { s/::::/::/g; s/^:://; s/::$//; } # XXX STD misparse?
1557 $::OUR
{$def_module_name} = "${mod}::$def_module_name";
1558 $def_module_name = "${mod}::$def_module_name";
1562 sub superclasses
{ my $self = shift;
1564 for (@
{$self->{trait
}}) {
1566 push(@extends, $t =~ /^is\s+(\S+)/);
1568 @extends = map { $::OUR
{$_} // $_ } @extends;
1569 @extends = 'Cursor' if $::PKGDECL
eq 'grammar' && !@extends;
1572 sub roles
{ my $self = shift;
1574 for (@
{$self->{trait
}}) {
1576 push(@does, $t =~ /^does\s+(\S+)/);
1578 @does = map { $::OUR
{$_} // $_ } @does;
1580 sub emit_p5_header
{ my $self = shift;
1584 my $meta = $::PKGDECL
eq 'role' ?
'Moose::Role' : 'Moose';
1587 use $meta ':all' => { -prefix => "moose_" };
1591 $header .= <<"END" for $self->superclasses;
1592 moose_extends('$_');
1595 $header .= <<"END" for $self->roles;
1599 if (! $self->roles) {
1600 $header .= "our \$ALLROLES = { '$::PKG', 1 };\n";
1603 $header .= "our \$REGEXES = {\n";
1604 $::PROTORX_HERE
{ALL
} = [ sort keys %::OVERRIDERX
];
1605 for my $p (sort keys %::PROTORX_HERE
) {
1606 $header .= " $p => [ qw/" . join(" ",
1607 @
{ $::PROTORX_HERE
{$p} }) . "/ ],\n";
1609 $header .= "};\n\n";
1613 no warnings 'qw', 'recursion';
1616 \$DB::deep = \$DB::deep = 1000; # suppress used-once warning
1620 \$SIG{__WARN__} = sub { die \@_," statement started at line ", 'Cursor'->lineof(\$::LASTSTATE), "\n" } if \$::DEBUG;
1626 sub emit_p5
{ my $self = shift;
1627 my $block = $self->{blockoid
}{statementlist
} // $self->{statementlist
};
1628 local $::RETREE
= {};
1629 local $::PKG
= $self->module_name;
1630 local $::MULTIRX_SEQUENCE
= 0;
1631 local %::PROTORX_HERE
;
1632 local %::OVERRIDERX
;
1633 local %::MULTIMETHODS
;
1634 my $body3 = $block->p5;
1635 my $body1 = $self->emit_p5_header;
1639 $body2 = "\$retree = YAML::XS::Load(Encode::encode_utf8(<<'RETREE_END'));\n" .
1640 Encode
::decode_utf8
(::Dump
($::RETREE
)) . "RETREE_END\n";
1642 my $body = $body1 . $body2 . $body3;
1645 if (my ($sig) = $self->kids('signature')) {
1646 my @parm = map { $_->Str } $sig->kids('parameter');
1647 my $plist = join ", ", @parm;
1649 $body = <<EOT . $body;
1651 require "mangle.pl";
1653 sub __instantiate__ { my \$self = shift;
1655 my \$mangle = ::mangle($plist);
1656 my \$mixin = "${name}::" . \$mangle;
1657 return \$mixin if \$INSTANTIATED{\$mixin}++;
1658 ::deb(" instantiating \$mixin") if \$::DEBUG & DEBUG::mixins;
1659 my \$eval = "package \$mixin" . q{;
1660 sub _PARAMS { { ${\ join(", ", map { "'$_' => $_" } @parm) } } }
1670 $body = "package $name;\n" . $body;
1673 my $finalmulti = '';
1675 for my $mm (sort keys %::MULTIMETHODS
) {
1676 $finalmulti .= "moose_around $mm => sub {\n my \$orig = shift;\n no warnings 'recursion';\n" .
1677 ::indent
($::MULTIMETHODS
{$mm}, 1) . <<EOFINAL
1685 "{ $body $finalmulti 1; }";
1688 sub psq_finish_multis
{ my $self = shift;
1689 die "multis not yet implemented for psq";
1692 sub psq_retree
{ my $self = shift;
1693 die "LTM not yet implemented for psq";
1696 sub psq_parameterized
{ my $self = shift;
1697 die "roles not yet implemented for psq";
1700 sub psq_plain
{ my $self = shift; my $body = shift;
1701 die "roles not yet implemented for psq"
1702 if $::PKGDECL
eq 'role' or $self->roles;
1703 die "multiple inheritance not available in psq"
1704 if $self->superclasses > 1;
1705 my ($is) = $self->superclasses;
1706 "class " . $::PKG
. " " . ($is ?
"is $is " : "") .
1707 "{\n" . ::indent
($body) . "\n}";
1710 sub emit_psq
{ my $self = shift;
1711 my $block = $self->{blockoid
}{statementlist
} // $self->{statementlist
};
1712 local $::RETREE
= {};
1713 local $::PKG
= $self->module_name;
1714 local $::MULTIRX_SEQUENCE
= 0;
1715 local %::MULTIMETHODS
;
1717 my $body = $block->psq;
1718 $body = $body . $self->psq_finish_multis
1720 $body = $self->psq_retree . $body
1723 if (my ($sig) = $self->kids('signature')) {
1724 $body = $self->psq_parameterized($body,
1725 map { $_->Str } $sig->kids('parameter'));
1727 $body = $self->psq_plain($body);
1734 # Perl5 invocations don't carry enough context for a proper binder; in
1735 # particular we can't distinguish named stuff from positionals
1736 { package VAST
::parameter
; our @ISA = 'VAST::Base';
1737 sub emit_p5
{ my $self = shift;
1738 my $pvar = $self->{param_var
};
1742 my $np = $self->{named_param
};
1744 $pvar = $np->{param_var
};
1745 push @names, $np->{name
} ?
$np->{name
}{TEXT
}
1746 : $np->{param_var
}{name
}[0]{TEXT
};
1747 $np = $np->{named_param
};
1749 $posit = 1 unless @names;
1750 my $pname = $pvar->{name
}[0]{TEXT
};
1751 my $sigil = $pvar->{sigil
}{SYM
};
1752 my $twigil = $pvar->{twigil
}[0] ?
$pvar->{twigil
}[0]{SYM
} : '';
1753 my ($dv) = $self->kids('default_value');
1757 if (($self->{quant
} eq '!' || $self->{quant
} eq '' && $posit) && !$dv) {
1758 $check .= $::MULTINESS
eq 'multi' ?
"last " :
1759 "die 'Required argument $pname omitted' ";
1760 $check .= $posit ?
'unless @_'
1761 : 'unless ' . join(" || ", map ("exists \$args{$_}", @names));
1766 my $value = "undef";
1768 $value = $dv->{"."}->p5;
1771 $value = '@_ ? shift() : ' . $value;
1773 for (reverse @names) {
1774 $value = "exists \$args{$_} ? delete \$args{$_} : $value";
1776 if ($self->{quant
} eq '*') {
1777 $value = ($sigil eq '%') ?
'%args' : '@_';
1778 $posit = 0 if $sigil eq '%';
1781 # Store it somewhere useful
1782 if ($twigil eq '*' && $pname eq 'endsym') {
1783 # XXX this optimization needs to be refactored, I think
1784 my ($dv) = $self->kids('default_value');
1785 $::ENDSYM
= $dv->{"."}->Str;
1786 $::ENDSYM
= substr($::ENDSYM
, 1, length($::ENDSYM
)-2);
1791 if ($twigil eq '*') {
1792 $assn = "local ${sigil}::${pname} = $value";
1794 $assn = "my ${sigil}${pname} = $value";
1797 (!$posit), ($check . $assn);
1802 { package VAST
::param_sep
; our @ISA = 'VAST::Base';
1806 { package VAST
::param_var
; our @ISA = 'VAST::Base';
1810 { package VAST
::pblock
; our @ISA = 'VAST::Base';
1814 { package VAST
::pod_comment
; our @ISA = 'VAST::Base';
1818 { package VAST
::POST
; our @ISA = 'VAST::Base';
1822 { package VAST
::postcircumfix
; our @ISA = 'VAST::Base';
1826 { package VAST
::SYM_postcircumfix__S_Lt_Gt
; our @ISA = 'VAST::Base';
1827 sub emit_p5
{ my $self = shift;
1828 my @t = $self->SUPER::emit_p5
;
1836 { package VAST
::postfix
; our @ISA = 'VAST::Base';
1840 { package VAST
::postop
; our @ISA = 'VAST::Base';
1844 { package VAST
::PRE
; our @ISA = 'VAST::Base';
1848 { package VAST
::prefix
; our @ISA = 'VAST::Base';
1852 { package VAST
::SYM_prefix__S_Plus
; our @ISA = 'VAST::Symbolic_unary';
1853 sub emit_p5
{ my $self = shift;
1854 my @t = $self->SUPER::emit_p5
;
1860 { package VAST
::SYM_prefix__S_Vert
; our @ISA = 'VAST::Symbolic_unary';
1861 sub emit_p5
{ my $self = shift;
1867 { package VAST
::prefix__S_temp
; our @ISA = 'VAST::Base';
1868 sub emit_p5
{ my $self = shift;
1869 my $arg = $self->{arg
}->p5;
1870 "local $arg = $arg";
1875 { package VAST
::quantified_atom
; our @ISA = 'VAST::Base';
1876 sub re_ast
{ my $self = shift;
1877 if (!@
{$self->{quantifier
}}) {
1878 return $self->{atom
}->re_ast;
1881 if ($self->{quantifier
}[0]{SYM
} eq '~') {
1882 return $self->_tilde;
1885 if ($self->{quantifier
}[0]{SYM
} eq ':') {
1886 my $ast = $self->{atom
}->re_ast;
1891 my $quant = $self->{quantifier
}[0]->re_quantifier;
1893 my $ast = $self->{atom
}->re_ast;
1895 my $r = RE_quantified_atom
->new(atom
=> $ast, quant
=> $quant);
1896 $r->{r
} = 0 if $quant->[1] ne ':';
1900 sub _tilde
{ my $self = shift;
1901 my $opener = $self->{atom
}->re_ast;
1902 my $closer = $self->{quantifier
}[0]{quantified_atom
}[0]->re_ast;
1903 my $inner = $self->{quantifier
}[0]{quantified_atom
}[1]->re_ast;
1905 my $strcloser = $closer->{text
}; #XXX
1908 local \$::GOAL = "${\ quotemeta $strcloser}";
1911 if ($strcloser !~ /^[])}]$/) {
1913 my \$newlang = \$C->unbalanced(\$::GOAL);
1914 \$C = bless(\$C, (ref(\$newlang) || \$newlang));
1919 push @expn, $opener;
1920 # XXX STD break LTM for gimme5 bug-compatibility
1921 push @expn, RE_block
->new(body
=> '', context
=> 'void');
1923 push @expn, RE_bracket
->new(decl
=> [], re
=> RE_first
->new(
1924 RE_string
->new(text
=> $strcloser),
1925 RE_method
->new(name
=> 'FAILGOAL', nobind
=> 1,
1926 rest
=> "(\$::GOAL, '$::DBA', \$goalpos)")));
1928 RE_bracket
->new(decl
=> [RE_decl
->new(body
=> $begin)], re
=>
1929 RE_sequence
->new(@expn));
1933 { package VAST
::quant_atom_list
; our @ISA = 'VAST::Base';
1934 sub re_ast
{ my $self = shift;
1935 my @kids = map { $_->re_ast } $self->kids("quantified_atom");
1936 RE_sequence
->new(@kids);
1941 { package VAST
::quantifier
; our @ISA = 'VAST::Base';
1945 { package VAST
::quantifier__S_Plus
; our @ISA = 'VAST::Base';
1946 sub re_quantifier
{ my $self = shift;
1947 $self->base_re_quantifier("", 1);
1952 { package VAST
::quantifier__S_Question
; our @ISA = 'VAST::Base';
1953 sub re_quantifier
{ my $self = shift;
1954 $self->base_re_quantifier("", 0);
1959 { package VAST
::quantifier__S_Star
; our @ISA = 'VAST::Base';
1960 sub re_quantifier
{ my $self = shift;
1961 $self->base_re_quantifier("", 0);
1966 { package VAST
::quantifier__S_StarStar
; our @ISA = 'VAST::Base';
1967 sub re_quantifier
{ my $self = shift;
1968 my ($range) = $self->Str =~ /.*(\d+\.\.\d+)$/;
1969 $self->base_re_quantifier($self->{embeddedblock
} //
1970 $range // $self->{quantified_atom
}->re_ast, 1);
1975 { package VAST
::quantmod
; our @ISA = 'VAST::Base';
1979 { package VAST
::quibble
; our @ISA = 'VAST::Base';
1984 { package VAST
::quote
; our @ISA = 'VAST::Base';
1985 sub emit_p5
{ my $self = shift;
1986 my @t = $self->SUPER::emit_p5
;
1988 # print STDERR ::Dump(\@t);
1993 { package VAST
::quote__S_Double_Double
; our @ISA = 'VAST::Base';
1997 { package VAST
::circumfix__S_Fre_Nch
; our @ISA = 'VAST::Base';
1998 sub emit_p5
{ my $self = shift;
1999 '[split(/ /, "' . $self->{nibble
}->p5 . '", -1)]'
2004 { package VAST
::quote__S_Lt_Gt
; our @ISA = 'VAST::Base';
2008 { package VAST
::quotepair
; our @ISA = 'VAST::Base';
2012 { package VAST
::quote__S_s
; our @ISA = 'VAST::Base';
2016 { package VAST
::quote__S_Single_Single
; our @ISA = 'VAST::Base';
2017 sub emit_psq
{ my $self = shift;
2018 my $str = $self->Str;
2024 { package VAST
::quote__S_Slash_Slash
; our @ISA = 'VAST::Base';
2028 { package VAST
::regex_block
; our @ISA = 'VAST::Base';
2032 { package VAST
::regex_declarator
; our @ISA = 'VAST::Base';
2036 { package VAST
::regex_declarator__S_regex
; our @ISA = 'VAST::Base';
2037 sub emit_p5
{ my $self = shift;
2038 local $::RATCHET
= 0;
2039 local $::SIGSPACE
= 0;
2040 local $::REGEX_DECLARATOR
= 'regex';
2041 my $comment = substr($ORIG, $self->{BEG
},100);
2042 $comment =~ s/\n.*//s;
2043 "## $comment\n" . $self->{regex_def
}->p5;
2048 { package VAST
::regex_declarator__S_rule
; our @ISA = 'VAST::Base';
2049 sub emit_p5
{ my $self = shift;
2050 local $::RATCHET
= 1;
2051 local $::SIGSPACE
= 1;
2052 local $::REGEX_DECLARATOR
= 'rule';
2053 my $comment = substr($ORIG, $self->{BEG
},100);
2054 $comment =~ s/\n.*//s;
2055 "## $comment\n" . $self->{regex_def
}->p5;
2060 { package VAST
::regex_declarator__S_token
; our @ISA = 'VAST::Base';
2061 sub emit_p5
{ my $self = shift;
2062 local $::RATCHET
= 1;
2063 local $::SIGSPACE
= 0;
2064 local $::REGEX_DECLARATOR
= 'token';
2065 my $comment = substr($ORIG, $self->{BEG
}, 100);
2066 $comment =~ s/\n.*//s;
2067 "## $comment\n" . $self->{regex_def
}->p5;
2071 { package VAST
::regex_def
; our @ISA = 'VAST::Base';
2072 sub re_ast
{ my $self = shift;
2073 RE_ast
->new(kind
=> $::REGEX_DECLARATOR
, decl
=> \@
::DECLAST
,
2074 re
=> $self->{regex_block
}{nibble
}{"."}->re_ast);
2076 sub protoregex
{ my $self = shift; my $name = shift;
2077 $::PROTO
->{$name} = 1;
2078 $::RETREE
->{$name . ":*"} = { dic
=> $::PKG
};
2079 $::PROTOSIG
->{$name} = ($self->kids("signature"))[0];
2081 sub ${name}__PEEK { \$_[0]->_AUTOLEXpeek('$name:*',\$retree); }
2086 local \$::CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
2088 my \$C = \$self->cursor_xact('RULE $name');
2089 my \$S = \$C->{'_pos'};
2096 if (my \$fate = \$C->{'_fate'}) {
2097 if (\$fate->[1] eq '$name') {
2098 \$C->deb("Fate passed to $name: ", ::fatestr(\$fate)) if \$::DEBUG & DEBUG::fates;
2099 (\$C->{'_fate'}, \$tag, \$try) = \@\$fate;
2104 \$x = 'ALTLTM $name';
2108 \$x = 'ALTLTM $name';
2110 my \$C = \$C->cursor_xact(\$x);
2111 my \$xact = \$C->{_xact};
2116 \$relex //= \$C->cursor_fate('$::PKG', '$name:*', \$retree);
2117 \@try = \$relex->(\$C) or last;
2119 \$try = shift(\@try) // next;
2122 (\$C->{'_fate'}, \$tag, \$try) = \@\$try; # next candidate fate
2125 \$C->deb("$name trying \$tag \$try") if \$::DEBUG & DEBUG::try_processing;
2126 push \@gather, \$C->\$try(\@_);
2128 last if \$xact->[-2]; # committed?
2130 \$self->_MATCHIFYr(\$S, "$name", \@gather);
2137 sub emit_p5
{ my $self = shift;
2138 my $name = $self->{deflongname
}[0]{name
}->Str;
2139 $::OVERRIDERX
{$name} = 1;
2140 if (defined $::MULTINESS
&& $::MULTINESS
eq 'proto') {
2141 return $self->protoregex($name);
2144 my %adv = $self->{deflongname
}[0]->adverbs;
2145 local $::SYM
= $adv{sym
};
2148 local $::PLURALITY
= 1;
2151 local $::NEEDORIGARGS
= 0;
2152 local $::IGNORECASE
= 0;
2156 my $spcsig = $self->kids('signature') ?
2157 (($self->kids('signature'))[0])->p5 : '';
2158 my $defsig = $::PROTO
&& $::PROTOSIG
->{$name}
2159 ?
$::PROTOSIG
->{$name}->p5 : '';
2160 if (defined $adv{sym
}) {
2161 $p5name = sprintf "%s__S_%03d%s", $name, $::MULTIRX_SEQUENCE
++,
2162 ::mangle
(split " ", $adv{sym
});
2163 push @
{$::PROTORX_HERE
{$name}}, $p5name . "__PEEK";
2165 local $::DBA
= $name;
2166 local $::DECL_CLASS
= $::PKG
;
2167 local $::NAME
= $p5name;
2169 my $ast = $self->re_ast->optimize;
2171 $::RETREE
->{$p5name} = $ast;
2173 my $urbody = $ast->walk;
2174 say STDERR
"<<< " . $urbody . ": " . $urbody->p5expr if $OPT_log;
2175 my ($body, $ratchet) = $urbody->uncut;
2176 say STDERR
"<<< " . $body . ": " . $body->p5expr if $OPT_log;
2177 $ast->{dba_needed
} = 1;
2181 sub ${p5name}__PEEK { \$_[0]->_AUTOLEXpeek('$p5name', \$retree) }
2185 no warnings 'recursion';
2189 . ($::NEEDORIGARGS ?
" my \@origargs = \@_;\n" : "")
2190 . ::indent
($defsig || $spcsig, 1)
2191 . ::indent
(join("", @
::DECL
), 1)
2194 local \$::CTX = \$self->callm() if \$::DEBUG & DEBUG::trace_call;
2196 my \$C = \$self->cursor_xact("RULE $p5name");
2197 my \$xact = \$C->xact;
2198 my \$S = \$C->{'_pos'};
2200 . join("", map { "\$C->{'$_'} = [];\n" }
2201 grep { $::BINDINGS
{$_} > 1 }
2202 sort keys %::BINDINGS
)
2203 . ($::SYM ?
'$C->{sym} = "' . ::rd
($::SYM
) . "\";\n" : '')
2205 \$self->_MATCHIFY$ratchet(\$S, "$p5name", ${\ $body->p5expr });
2212 { package VAST
::Replication
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
2216 { package VAST
::right
; our @ISA = 'VAST::Base';
2220 { package VAST
::routine_declarator
; our @ISA = 'VAST::Base';
2224 { package VAST
::routine_declarator__S_method
; our @ISA = 'VAST::Base';
2225 sub emit_p5
{ my $self = shift;
2226 my $comment = substr($ORIG, $self->{BEG
},100);
2227 $comment =~ s/\s*\{.*//s;
2228 "## $comment\n" . $self->{method_def
}->p5;
2233 { package VAST
::regex_infix
; our @ISA = 'VAST::Base';
2236 { package VAST
::regex_infix__S_Tilde
; our @ISA = 'VAST::Base';
2240 { package VAST
::regex_infix__S_Vert
; our @ISA = 'VAST::Base';
2241 sub re_ast
{ my $self = shift;
2242 my $altname = $::NAME
. "_" . $::ALT
++;
2244 RE_any
->new(altname
=> $altname,
2245 zyg
=> [map { $_->re_ast } $self->kids('args')]);
2250 { package VAST
::regex_infix__S_VertVert
; our @ISA = 'VAST::Base';
2251 sub re_ast
{ my $self = shift;
2252 RE_first
->new(map { $_->re_ast } $self->kids('args'));
2258 { package VAST
::scoped
; our @ISA = 'VAST::Base';
2259 sub emit_p5
{ my $self = shift;
2260 if (@
{$self->{typename
}}) {
2261 " " . $self->{multi_declarator
}->p5;
2263 $self->SUPER::emit_p5
;
2267 sub emit_psq
{ my $self = shift; my $scope = shift;
2268 if ($self->{multi_declarator
}) {
2269 $self->{multi_declarator
}->psq(scope
=> $scope,
2270 typename
=> $self->{typename
}[0]->psq);
2271 } elsif ($self->{regex_declarator
}) {
2272 $self->{regex_declarator
}->psq(scope
=> $scope);
2273 } elsif ($self->{package_declarator
}) {
2274 $self->{package_declarator
}->psq(scope
=> $scope);
2276 $self->{declarator
}->psq(scope
=> $scope);
2282 { package VAST
::scope_declarator
; our @ISA = 'VAST::Base';
2283 sub emit_psq
{ my $self = shift;
2284 $self->{scoped
}->psq($self->{SYM
});
2289 { package VAST
::scope_declarator__S_has
; our @ISA = 'VAST::scope_declarator';
2290 sub emit_p5
{ my $self = shift;
2291 my $scoped = $self->{scoped
};
2292 my $typename = $scoped->{typename
}[0];
2293 my $multi = $scoped->{multi_declarator
};
2294 my $decl = $scoped->{declarator
} // $multi->{declarator
};
2295 my $vdecl = $decl->{variable_declarator
};
2296 my $var = $vdecl->{variable
};
2297 "moose_has '" . $var->{desigilname
}->Str . "' => (" . join (", ",
2298 ($typename ?
("isa => '" . $typename->Str . "'") : ()),
2305 { package VAST
::scope_declarator__S_my
; our @ISA = 'VAST::scope_declarator';
2306 sub emit_p5
{ my $self = shift;
2307 my $t = $self->SUPER::emit_p5
;
2308 $t =~ s/my(\s+)&(\w+)/my$1\$$2/;
2309 $t =~ s/my(\s+)([\$@%])::(\w+)/local$1${2}::$3/;
2315 { package VAST
::scope_declarator__S_our
; our @ISA = 'VAST::scope_declarator';
2319 { package VAST
::semiarglist
; our @ISA = 'VAST::Base';
2323 { package VAST
::semilist
; our @ISA = 'VAST::Base';
2327 { package VAST
::sibble
; our @ISA = 'VAST::Base';
2331 { package VAST
::sigil
; our @ISA = 'VAST::Base';
2332 my %psq_hash = ( '$', 'S', '@', 'A', '%', 'H', '&', 'C' );
2333 sub psq_mangle
{ my $self = shift;
2334 return $psq_hash{$self->{SYM
}};
2339 { package VAST
::sigil__S_Amp
; our @ISA = 'VAST::sigil';
2343 { package VAST
::sigil__S_At
; our @ISA = 'VAST::sigil';
2347 { package VAST
::sigil__S_Dollar
; our @ISA = 'VAST::sigil';
2351 { package VAST
::sigil__S_Percent
; our @ISA = 'VAST::sigil';
2355 { package VAST
::sign
; our @ISA = 'VAST::Base';
2359 { package VAST
::signature
; our @ISA = 'VAST::Base';
2360 sub emit_p5
{ my $self = shift;
2361 for ($self->kids('param_sep')) {
2362 next if $_->{TEXT
} =~ /,/;
2363 die "Unusual parameter separators not yet supported";
2366 # signature stuff is just parsing code
2368 for my $pv ($self->kids('parameter')) {
2369 my ($named, $st) = $pv->p5;
2370 $seg[$named] .= $st . ";\n";
2373 if ($seg[1]) { $seg[1] = "my %args = \@_;\n" . $seg[1]; }
2380 { package VAST
::spacey
; our @ISA = 'VAST::Base';
2385 { package VAST
::special_variable
; our @ISA = 'VAST::Base';
2388 { package VAST
::special_variable__S_Dollar_a2_
; our @ISA = 'VAST::Base';
2389 sub emit_p5
{ my $self = shift;
2390 my @t = $self->SUPER::emit_p5
;
2397 { package VAST
::special_variable__S_DollarSlash
; our @ISA = 'VAST::Base';
2398 sub emit_p5
{ my $self = shift;
2399 my @t = $self->SUPER::emit_p5
;
2407 { package VAST
::statement
; our @ISA = 'VAST::Base';
2408 sub emit_psq
{ my $self = shift;
2409 if ($self->{label
}) {
2410 return $self->{label
}{identifier
}->Str . ":\n" .
2411 $self->{statement
}->psq;
2414 if ($self->{statement_control
}) {
2415 return $self->{statement_control
}->psq;
2418 return "" if !$self->{EXPR
};
2420 my $body = $self->{EXPR
}->psq . ";";
2421 for my $m ($self->kids('statement_mod_cond'),
2422 $self->kids('statement_mod_loop')) {
2423 $body = $m->psq . " {\n" . ::indent
($body) . "\n}";
2430 { package VAST
::statement_control
; our @ISA = 'VAST::Base';
2434 { package VAST
::statement_control__S_default
; our @ISA = 'VAST::Base';
2438 { package VAST
::statement_control__S_use
; our @ISA = 'VAST::Base';
2439 sub emit_psq
{ my $self = shift;
2440 $::PRELUDE
{$self->{module_name
}->Str} = 1;
2446 { package VAST
::statement_control__S_for
; our @ISA = 'VAST::Base';
2450 { package VAST
::statement_control__S_given
; our @ISA = 'VAST::Base';
2454 { package VAST
::statement_control__S_if
; our @ISA = 'VAST::Base';
2455 sub emit_p5
{ my $self = shift;
2456 join("\n", ("if " . $self->{xblock
}->p5)
2457 , (map { "elsif " .$_->p5 } @
{$self->{elsif}})
2458 , (map { "else " . $_->p5 } @
{$self->{else}}));
2463 { package VAST
::statement_control__S_loop
; our @ISA = 'VAST::Base';
2464 sub emit_p5
{ my $self = shift;
2465 my $t = $self->SUPER::emit_p5
;
2466 $t =~ s/^loop(\s+\()/for$1/;
2467 $t =~ s/^loop/for (;;)/;
2473 { package VAST
::statement_control__S_when
; our @ISA = 'VAST::Base';
2474 sub emit_p5
{ my $self = shift;
2475 my @t = $self->SUPER::emit_p5
;
2476 if ($t[1] =~ s/^\s*\(\s*\*\s*\)//) { $t[0] = 'default'; }
2482 { package VAST
::statement_control__S_while
; our @ISA = 'VAST::Base';
2486 { package VAST
::statementlist
; our @ISA = 'VAST::Base';
2487 sub emit_p5
{ my $self = shift;
2488 my @stmts = $self->kids('statement');
2489 # XXX mostly for the benefit of hashes
2491 return $stmts[0]->p5;
2493 join("", map { $_->p5 . ";\n" } @stmts);
2495 sub emit_psq
{ my $self = shift;
2496 my @stmts = $self->kids('statement');
2498 my $b = join("", map { $_->psq . "\n" } @stmts);
2499 join("", @
::LEXVARS
, $b);
2504 { package VAST
::statement_mod_cond
; our @ISA = 'VAST::Base';
2508 { package VAST
::statement_mod_cond__S_if
; our @ISA = 'VAST::Base';
2512 { package VAST
::statement_mod_cond__S_unless
; our @ISA = 'VAST::Base';
2516 { package VAST
::statement_mod_loop
; our @ISA = 'VAST::Base';
2520 { package VAST
::statement_mod_loop__S_for
; our @ISA = 'VAST::Base';
2524 { package VAST
::statement_mod_loop__S_while
; our @ISA = 'VAST::Base';
2528 { package VAST
::statement_prefix
; our @ISA = 'VAST::Base';
2532 { package VAST
::statement_prefix__S_do
; our @ISA = 'VAST::Base';
2536 { package VAST
::statement_prefix__S_try
; our @ISA = 'VAST::Base';
2537 sub emit_p5
{ my $self = shift;
2538 my @t = $self->SUPER::emit_p5
;
2545 { package VAST
::stdstopper
; our @ISA = 'VAST::Base';
2549 { package VAST
::stopper
; our @ISA = 'VAST::Base';
2553 { package VAST
::Structural_infix
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
2557 { package VAST
::sublongname
; our @ISA = 'VAST::Base';
2561 { package VAST
::subshortname
; our @ISA = 'VAST::Base';
2565 { package VAST
::Symbolic_unary
; our @ISA = 'VAST::Base';
2569 { package VAST
::term
; our @ISA = 'VAST::Base';
2572 { package VAST
::term__S_capterm
; our @ISA = 'VAST::Base';
2576 { package VAST
::term__S_circumfix
; our @ISA = 'VAST::Base';
2580 { package VAST
::term__S_colonpair
; our @ISA = 'VAST::Base';
2581 sub emit_p5
{ my $self = shift;
2582 my $t = $self->SUPER::emit_p5
;
2584 if ($t =~ s/^:!//) {
2587 elsif ($t =~ s/^:(\d+)//) {
2594 if ($t =~ s/^(\w+)$/'$1'/) {
2598 my ($name,$rest) = $t =~ /^(\w+)(.*)$/s;
2599 $rest =~ s/^<([^\s']*)>/'$1'/ or
2600 $rest =~ s/^(<\S*>)/q$1/ or
2601 $rest =~ s/^(<\s*\S+\s*>)/qw$1/ or
2602 $rest =~ s/^(<.*>)/[qw$1]/; # p5's => isn't scalar context
2603 $t = "'$name' => $rest";
2611 { package VAST
::term__S_fatarrow
; our @ISA = 'VAST::Base';
2615 { package VAST
::term__S_identifier
; our @ISA = ('VAST::ViaDEEP', 'VAST::Base');
2616 sub emit_p5
{ my $self = shift;
2617 my @t = $self->SUPER::emit_p5
;
2618 if ($t[0] eq 'item') {
2622 if ($t[0] eq 'map' || $t[0] eq 'grep' || $t[0] eq 'sort') {
2623 # XXX this should be more robust, but it belongs in DEEP after
2624 # all arguments are collected anyway
2625 $t[1] =~ s/}\s*,/} /;
2627 if ($t[0] eq 'invert') {
2630 if ($t[0] eq 'chars') {
2633 if ($t[0] eq 'note') {
2634 $t[0] = 'print STDERR';
2636 if ($t[0] eq 'False') {
2639 if ($t[0] eq 'True') {
2642 if ($t[0] eq 'Nil') {
2648 sub _deep
{ my $self = shift;
2649 my $id = $self->{identifier
}->Str;
2650 my @args = $self->{args
}->deepn;
2652 DEEP
::call
($id, @args);
2657 { package VAST
::term__S_multi_declarator
; our @ISA = 'VAST::Base';
2661 { package VAST
::term__S_package_declarator
; our @ISA = 'VAST::Base';
2662 sub emit_psq
{ $_[0]{package_declarator
}->psq }
2666 { package VAST
::term__S_regex_declarator
; our @ISA = 'VAST::Base';
2667 sub emit_p5
{ my $self = shift;;
2668 $self->{regex_declarator
}->p5;
2673 { package VAST
::term__S_routine_declarator
; our @ISA = 'VAST::Base';
2677 { package VAST
::term__S_scope_declarator
; our @ISA = 'VAST::Base';
2678 sub emit_psq
{ my $self = shift;
2679 $self->{scope_declarator
}->psq;
2684 { package VAST
::term__S_statement_prefix
; our @ISA = 'VAST::Base';
2688 { package VAST
::term__S_term
; our @ISA = 'VAST::Base';
2692 { package VAST
::term__S_value
; our @ISA = 'VAST::Base';
2693 sub emit_psq
{ $_[0]{value
}->psq}
2697 { package VAST
::term__S_variable
; our @ISA = 'VAST::Base';
2701 { package VAST
::terminator
; our @ISA = 'VAST::Base';
2702 sub emit_p6
{ my $self = shift;
2703 my @t = $self->SUPER::emit_p6
;
2708 { package VAST
::terminator__S_BangBang
; our @ISA = 'VAST::terminator'; }
2710 { package VAST
::terminator__S_for
; our @ISA = 'VAST::terminator'; }
2712 { package VAST
::terminator__S_if
; our @ISA = 'VAST::terminator'; }
2714 { package VAST
::terminator__S_Ket
; our @ISA = 'VAST::terminator'; }
2716 { package VAST
::terminator__S_Ly
; our @ISA = 'VAST::terminator'; }
2718 { package VAST
::terminator__S_Semi
; our @ISA = 'VAST::terminator'; }
2720 { package VAST
::terminator__S_Thesis
; our @ISA = 'VAST::terminator'; }
2722 { package VAST
::terminator__S_unless
; our @ISA = 'VAST::terminator'; }
2724 { package VAST
::terminator__S_while
; our @ISA = 'VAST::terminator'; }
2726 { package VAST
::terminator__S_when
; our @ISA = 'VAST::terminator'; }
2729 { package VAST
::termish
; our @ISA = 'VAST::Base';
2734 { package VAST
::term
; our @ISA = 'VAST::Base';
2737 { package VAST
::term__S_name
; our @ISA = ('VAST::Base');
2738 sub emit_p5
{ my $self = shift;
2739 my @t = $self->SUPER::emit_p5
;
2740 if (my ($pkg) = ($t[0] =~ /^::(.*)/)) {
2741 $pkg = $::OUR
{$pkg} // $pkg;
2742 if (defined $t[1] && $t[1] =~ /^\s*\[/) {
2743 $t[1] =~ s/^\s*\[/->__instantiate__(/;
2744 $t[1] =~ s/\]\s*$/)/;
2755 { package VAST
::term__S_self
; our @ISA = 'VAST::Base';
2756 sub emit_p5
{ my $self = shift;
2757 my @t = $self->SUPER::emit_p5
;
2764 { package VAST
::term__S_Star
; our @ISA = 'VAST::Base';
2768 { package VAST
::term__S_undef
; our @ISA = 'VAST::Base';
2772 { package VAST
::Tight_or
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
2775 { package VAST
::Tight_and
; our @ISA = ('VAST::Base', 'VAST::InfixCall');
2779 { package VAST
::trait
; our @ISA = 'VAST::Base';
2783 { package VAST
::trait_auxiliary
; our @ISA = 'VAST::Base';
2787 { package VAST
::trait_auxiliary__S_does
; our @ISA = 'VAST::Base';
2791 { package VAST
::trait_auxiliary__S_is
; our @ISA = 'VAST::Base';
2796 { package VAST
::twigil
; our @ISA = 'VAST::Base';
2799 { package VAST
::twigil__S_Dot
; our @ISA = 'VAST::Base';
2800 sub emit_p5
{ my $self = shift;
2801 my @t = $self->SUPER::emit_p5
;
2802 $t[0] = 'self->'; # XXX
2808 { package VAST
::twigil__S_Star
; our @ISA = 'VAST::Base';
2809 sub emit_p5
{ my $self = shift;
2810 my @t = $self->SUPER::emit_p5
;
2816 { package VAST
::twigil__S_Caret
; our @ISA = 'VAST::Base';
2817 sub emit_p5
{ my $self = shift;
2818 my @t = $self->SUPER::emit_p5
;
2819 $t[0] = ''; #XXX only correct for sorts
2825 { package VAST
::type_constraint
; our @ISA = 'VAST::Base';
2828 { package VAST
::type_declarator__S_constant
; our @ISA = 'VAST::Base';
2829 sub emit_p5
{ my $self = shift;
2830 my $t = $self->SUPER::emit_p5
;
2831 $t =~ s/constant/our/;
2838 { package VAST
::typename
; our @ISA = 'VAST::Base';
2839 sub emit_p5
{ my $self = shift;
2841 if (ref $context[-1] ne 'VAST::scoped') {
2842 @t = $self->SUPER::emit_p5
;
2847 sub emit_psq
{ my $self = shift;
2849 $s eq 'Str' && return 'str';
2850 $s eq 'Int' && return 'int';
2856 { package VAST
::unitstopper
; our @ISA = 'VAST::Base';
2860 { package VAST
::unspacey
; our @ISA = 'VAST::Base';
2864 { package VAST
::unv
; our @ISA = 'VAST::Base';
2868 { package VAST
::val
; our @ISA = 'VAST::Base';
2872 { package VAST
::value
; our @ISA = 'VAST::Base';
2876 { package VAST
::value__S_number
; our @ISA = 'VAST::Base';
2877 sub emit_psq
{ $_[0]{number
}->psq}
2881 { package VAST
::value__S_quote
; our @ISA = 'VAST::Base';
2882 sub emit_psq
{ $_[0]{quote
}->psq}
2886 { package VAST
::variable
; our @ISA = 'VAST::Base';
2887 sub emit_p5
{ my $self = shift;
2888 my @t = $self->SUPER::emit_p5
;
2889 if (@t >= 2) { # $t[0] eq '$' but XXX STD uses %<O><prec> (erroneously?)
2890 if ($t[1] =~ /^\d+$/) {
2891 $t[1] = "M->{$t[1]}";
2893 } elsif ($t[1] =~ /^{/) {
2901 sub emit_psq
{ my $self = shift;
2902 return '$' . $self->{sigil
}->psq_mangle . '_' . $self->{desigilname
}->Str;
2907 { package VAST
::variable_declarator
; our @ISA = 'VAST::Base';
2908 sub emit_psq
{ my $self = shift; my %args = @_;
2909 my $scope = $args{scope
};
2910 my $type = $args{typename
};
2911 my $var = $self->{variable
}->psq;
2912 my $s = $self->{variable
}{sigil
}{SYM
};
2914 if ($scope eq 'my') {
2915 die "Variables in Perlesque *must* be typed" unless $type;
2916 push @
::LEXVARS
, "my $type $var;\n" if $s eq '$';
2917 push @
::LEXVARS
, "my List[$type] $var = List[$type].new();\n"
2919 push @
::LEXVARS
, "my Dictionary[str,$type] $var = Dictionary[str,$type].new();\n" if $s eq '%';
2926 { package VAST
::vws
; our @ISA = 'VAST::Base';
2930 { package VAST
::ws
; our @ISA = 'VAST::Base';
2935 { package VAST
::xblock
; our @ISA = 'VAST::Base';
2936 sub emit_p5
{ my $self = shift;
2937 my @t = $self->SUPER::emit_p5
;
2938 $t[0] = '(' . $t[0] . ')';
2939 $t[0] =~ s/(\s+)\)$/)$1/;
2944 { package VAST
::XXX
; our @ISA = 'VAST::Base';
2951 my $dopp = bless { %$self }, ref($self);
2952 for my $dkid ($dopp->kids) {
2953 $$dkid = $$dkid->clone;
2957 sub new
{ my $class = shift;
2958 my $self = bless { a
=> 0, i
=> $::IGNORECASE ?
1 : 0,
2959 r
=> $::RATCHET ?
1 : 0, s
=> $::SIGSPACE ?
1 : 0,
2960 dba
=> $::DBA
, dic
=> $::DECL_CLASS
, @_ }, $class;
2964 sub optimize
{ my $self = shift;
2965 for my $kid ($self->kids) {
2966 $$kid = $$kid->optimize;
2971 sub clean
{ my $self = shift;
2972 for my $kid ($self->kids) {
2978 delete $self->{i
} unless $self->{i_needed
};
2979 delete $self->{i_needed
};
2980 delete $self->{dba
} unless $self->{dba_needed
};
2981 delete $self->{dic
} unless $self->{dba_needed
};
2982 delete $self->{dba_needed
};
2985 sub walk
{ my $self = shift;
2986 say STDERR
"--> $self" if $OPT_log;
2987 my $exp = $self->_walk;
2988 if ($self->{r
} && $exp->maybacktrack) {
2989 $exp = DEEP
::cut
($exp);
2991 say STDERR
"<-- $exp: ", $exp->p5expr if $OPT_log;
2999 foreach my $kid (@
{$$self{zyg
}}) {
3000 my $x = $kid->walk->p5;
3001 $result .= $x if defined $x;
3007 return DEEP
::raw
($result);
3010 sub bind { my $self = shift; my $re = shift;
3011 return $re unless @_;
3012 DEEP
::bind($re, @_);
3015 sub remove_leading_ws
{ } # this tree node not interested
3016 sub has_trailing_ws
{ 0 }
3019 { package RE_double
; use base
"REbase";
3022 my $text = $$self{text
};
3023 $$self{i_needed
} = 1;
3024 # XXX needs interpolation
3026 $text = $::REV ?
"(?<=" . ::rd
($text) . ")" : ::rd
($text);
3027 DEEP
::raw
('$C->_PATTERN(qr/\\G(?i:' . $text . ')/")', precut
=> 1);
3030 DEEP
::raw
("\$C->_EXACT(\"" . ::rd
($text) . "\")", precut
=> 1);
3035 { package RE_string
; use base
"REbase";
3038 $$self{i_needed
} = 1;
3039 my $text = ::rd
($$self{text
});
3040 $text = "(?<=$text)" if $::REV
;
3041 $text = "(?i:$text)" if $$self{i
};
3042 DEEP
::p5regex
($text, has_meta
=> ($::REV
|| $$self{i
}),
3043 needs_bracket
=> !($::REV
|| $$self{i
}) && (length($$self{text
}) != 1));
3047 { package RE_sequence
;
3049 my ($class, @zyg) = @_;
3050 $class->SUPER::new
(zyg
=> \
@zyg);
3054 my ($self, $outer, $inner) = @_;
3055 my ($out1, $outr) = $outer->uncut;
3057 DEEP
::ratchet
($inner, $out1);
3059 DEEP
::raw
(::hang
("LazyMap::lazymap(" . DEEP
::chunk
($inner)->p5expr .
3060 ",\n" . $outer->p5expr . ")", " "));
3069 my @kids = @
{$$self{zyg
}};
3072 while (@kids and ref $kids[0] eq 'RE_decl') {
3073 push @decl, shift(@kids)->walk->p5block;
3076 @kids = map { $_->walk } @kids;
3082 while (@kids && $kids[0]->isa('DEEP::p5regex')) {
3083 my $rk = shift(@kids);
3084 $rx .= $rk->cutre(0);
3085 $hm ||= $rk->{has_meta
};
3089 push @ckids, DEEP
::p5regex
($rx, needs_bracket
=> 1,
3094 push @ckids, shift(@kids);
3098 @ckids = reverse @ckids if $::REV
;
3101 my $result = pop @result;
3102 for (reverse @result) {
3103 $result = $self->wrapone($_,$result);
3106 DEEP
::raw
(join('', @decl, $result ?
$result->p5expr . "\n" : ''), isblock
=> 1) :
3107 $result // DEEP
::raw
('', isblock
=> 1);
3110 sub kids
{ my $self = shift; map { \
$_ } @
{$self->{zyg
}} }
3112 sub optimize
{ my $self = shift;
3116 for my $kid ($self->kids) {
3117 $$kid->remove_leading_ws if $afterspace;
3118 $afterspace = $$kid->has_trailing_ws($afterspace);
3121 $self = $self->SUPER::optimize
;
3123 for my $k (@
{$self->{zyg
}}) {
3124 next if $k->isa('RE_noop');
3125 if ($k->isa('RE_sequence')) {
3126 push @ok, @
{$k->{zyg
}};
3132 return RE_noop
->new if @ok == 0;
3133 return $ok[0] if @ok == 1;
3134 $self->{zyg
} = \
@ok;
3138 sub remove_leading_ws
{
3141 for my $kid ($self->kids) {
3142 my $l = $$kid->has_trailing_ws(1);
3143 $$kid->remove_leading_ws;
3148 sub has_trailing_ws
{
3152 for my $kid ($self->kids) {
3153 $before = $$kid->has_trailing_ws($before);
3160 { package RE_any
; use base
"REbase";
3165 my $altname = $self->{altname
};
3167 my %B = %::BINDINGS
;
3168 for my $kid (@
{$$self{zyg
}}) {
3171 for my $b (keys %::BINDINGS
) {
3172 $B{$b} = 2 if $::BINDINGS
{$b} > 1 or $B{$b};
3175 $kid->{alt
} = $altname . ' ' . $alt++;
3183 $::RETREE
->{$self->{altname
}} = $self;
3184 $self->{dba_needed
} = 1;
3185 my $result = <<"END";
3193 if (\$fate = \$C->{'_fate'} and \$fate->[1] eq '$altname') {
3194 \$C->deb("Fate passed to $altname: ", ::fatestr(\$fate)) if \$::DEBUG & DEBUG::fates;
3195 (\$C->{'_fate'}, \$tag, \$try) = \@\$fate;
3197 \$x = 'ALT $altname'; # some outer ltm is controlling us
3200 \$x = 'ALTLTM $altname'; # we are top level ltm
3202 my \$C = \$C->cursor_xact(\$x);
3203 my \$xact = \$C->{_xact};
3208 \$relex //= \$C->cursor_fate('$::PKG', '$altname', \$retree);
3209 \@try = \$relex->(\$C) or last;
3211 \$try = shift(\@try) // next;
3214 (\$C->{'_fate'}, \$tag, \$try) = \@\$try; # next candidate fate
3217 \$C->deb("$altname trying \$tag \$try") if \$::DEBUG & DEBUG::try_processing;
3220 for my $i (0 .. @result - 1) {
3221 $result .= ::indent
(DEEP
::chunk
($result[$i])->p5expr, 3);
3222 if ($i != @result - 1) {
3230 last if \$xact->[-2]; # committed?
3235 DEEP
::raw
($result, isblock
=> 1);
3239 sub kids
{ my $self = shift; map { \
$_ } @
{$self->{zyg
}} }
3241 sub optimize
{ my $self = shift()->SUPER::optimize
;
3244 for my $k (@
{$self->{zyg
}}) {
3245 if ($k->isa('RE_any')) {
3246 push @ok, @
{$k->{zyg
}};
3252 return $ok[0] if @ok == 1;
3253 $self->{zyg
} = \
@ok;
3257 # yes, this affects LTM, but S05 specs it
3258 sub remove_leading_ws
{
3260 for my $kid (@
{$$self{zyg
}}) {
3261 $kid->remove_leading_ws();
3265 sub has_trailing_ws
{
3270 for my $kid ($self->kids) {
3271 $after &&= $$kid->has_trailing_ws($before);
3278 { package RE_first
; use base
"REbase";
3280 my ($class, @zyg) = @_;
3281 $class->SUPER::new
(zyg
=> \
@zyg);
3288 my %B = %::BINDINGS
;
3289 foreach my $kid (@
{$$self{zyg
}}) {
3291 push @result, $kid->walk->p5expr;
3292 for my $b (keys %::BINDINGS
) {
3293 $B{$b} = 2 if $::BINDINGS
{$b} > 1 or $B{$b};
3299 DEEP
::raw
($result[0]);
3302 die("Can't reverse serial disjunction") if $::REV
;
3303 for (@result) { $_ = "do {\n" . ::indent
("push \@gather, $_\n") . "}"; }
3304 # We need to force the scope here because of the my $C
3305 my $result = "do {" . ::indent
(
3306 "my \$C = \$C->cursor_xact('ALT ||');\n" .
3307 "my \$xact = \$C->xact;\nmy \@gather;\n" .
3308 join("\nor \$xact->[-2] or\n", @result) . ";\n" .
3309 "\@gather;\n") . "}";
3314 sub kids
{ my $self = shift; map { \
$_ } @
{$self->{zyg
}} }
3316 sub remove_leading_ws
{
3318 for my $kid (@
{$$self{zyg
}}) {
3319 $kid->remove_leading_ws();
3323 sub has_trailing_ws
{
3328 for my $kid ($self->kids) {
3329 $after &&= $$kid->has_trailing_ws($before);
3336 { package RE_method
; use base
"REbase";
3337 sub clean
{ my $self = shift;
3338 $self->SUPER::clean
;
3339 delete $self->{nobind
};
3340 delete $self->{need_match
};
3341 $self->{rest
} = defined $self->{rest
};
3345 local $::NEEDMATCH
= 0;
3346 my $name = $$self{name
};
3347 die "Can't reverse $name" if $::REV
;
3350 if ($name eq "sym") {
3351 $$self{i_needed
} = 1;
3352 $$self{sym
} = $::SYM
;
3353 $$self{endsym
} = $::ENDSYM
if defined $::ENDSYM
;
3355 return DEEP
::p5regex
("(?i:" . ::rd
($::SYM
) . ")");
3358 return DEEP
::p5regex
(::rd
($::SYM
), has_meta
=> 0);
3361 elsif ($name eq "alpha") {
3362 return DEEP
::p5regex
("[_[:alpha:]]");
3364 elsif ($name eq "_ALNUM") {
3365 return DEEP
::p5regex
("\\w");
3367 elsif ($name eq "nextsame") {
3369 $re = '$self->SUPER::' . $::NAME
. '(@origargs)';
3371 elsif ($name =~ /^\w/) {
3372 my $al = $self->{rest
} // '';
3373 $re = '$C->' . $name . $al;
3376 my $al = $self->{rest
} // '';
3382 elsif (ref $name eq 'Regexp') {
3383 if (\$::ORIG =~ m/$name/gc) {
3384 \$C->cursor(\$+[0]);
3396 $re = "do {\n" . ::indent
("my \$M = \$C;\n$re") . "\n}" if $self->{need_match
};
3397 $re = DEEP
::raw
($re);
3398 if ($name =~ /^\w/ and not $self->{nobind
}) {
3399 $::BINDINGS
{$name} += $::PLURALITY
;
3400 $re = $self->bind($re, $name);
3405 sub has_trailing_ws
{
3407 return $self->{name
} eq 'ws';
3410 sub remove_leading_ws
{
3412 if ($self->{name
} eq 'ws' && $self->{nobind
}) {
3413 bless $self, 'RE_noop';
3418 { package RE_ast
; use base
"REbase";
3419 sub clean
{ my $self = shift;
3420 $self->SUPER::clean
;
3421 delete $self->{decl
};
3422 delete $self->{kind
};
3427 for my $decl (@
{$$self{decl
}}) {
3428 push @
::DECL
, $decl->walk->p5block;
3436 sub kids
{ my $self = shift; \
$self->{re
}, map { \
$_ } @
{$self->{decl
}}; }
3439 { package RE_quantified_atom
; use base
"REbase";
3440 # handles cutting itself
3441 sub clean
{ my $self = shift;
3442 $self->SUPER::clean
;
3443 splice @
{$self->{quant
}}, ($self->{quant
}[0] eq '**' ?
3 : 1);
3448 local $::PLURALITY
= 2;
3451 my $q = $$self{quant
};
3452 my $bind = $::BINDINSIDE
;
3453 undef $::BINDINSIDE
;
3454 my $atom = $$self{atom
}->walk;
3455 if ($bind) { #XXX STD
3456 $atom = $self->bind($atom, $bind);
3458 my $atom_is_cut = !$atom->maybacktrack;
3459 my ($qfer,$how,$rest) = @
{$$self{quant
}};
3460 my $hc = $how eq '!' ?
'g' :
3463 my $hr = $how eq '!' ?
'' :
3466 if ($atom->isa('DEEP::p5regex') && $hc eq 'r' && !$::REV
&& $qfer ne '**') {
3467 return DEEP
::p5regex
($atom->cutre(1) . "$qfer$hr", needs_bracket
=> 1);
3471 $quant = "\$C->_STAR$hc$::REV(";
3473 elsif ($qfer eq '+') {
3474 $quant = "\$C->_PLUS$hc$::REV(";
3476 elsif ($qfer eq '?') {
3477 $quant = "\$C->_OPT$hc$::REV(";
3479 elsif ($qfer eq '**') {
3481 if (ref $rest eq "RE_block") {
3482 $rep = "_REPINDIRECT$::REV";
3483 $rest = $rest->walk;
3486 $rep = "_REPSEP$::REV";
3487 $rest = DEEP
::chunk
($rest->walk)->p5expr;
3493 $quant = "\$C->$rep$hc( $rest, ";
3495 return DEEP
::raw
($quant . ::hang
(DEEP
::chunk
($atom)->p5expr, " ") . ")", precut
=> ($hc eq 'r'));
3498 sub kids
{ my $self = shift; \
$self->{atom
} }
3501 my $self = shift()->SUPER::optimize
;
3502 if ($self->{quant
}[0] eq '*' &&
3503 $self->{quant
}[1] ne ':' &&
3504 $self->{atom
}->isa('RE_meta') &&
3505 $self->{atom
}{text
} eq '.') {
3506 delete $self->{atom
};
3507 $self->{text
} = ($self->{quant
}[1] eq '?') ?
'.*?' : '.*';
3508 delete $self->{quant
};
3509 bless $self, 'RE_meta';
3515 { package RE_qw
; use base
"REbase";
3518 DEEP
::raw
("\$C->_ARRAY$::REV( qw$$self{text} )");
3522 { package RE_method_re
; use base
"REbase";
3525 my $re = $$self{re
};
3526 my $name = $$self{name
};
3527 die("Can't reverse $name") if $::REV
and $name ne 'before';
3528 local $::REV
= $name eq 'after' ?
'_rev' : '';
3531 $re = $re->walk->p5block;
3533 for my $binding ( keys %::BINDINGS
) {
3534 next unless $::BINDINGS
{$binding} > 1;
3535 $re = <<"END" . $re;
3536 \$C->{'$binding'} = [];
3543 $re = DEEP
::raw
('$C->' . $name . "(" . ::hang
(DEEP
::chunk
(DEEP
::raw
($re, isblock
=> 1))->p5expr, " ") . ")");
3544 if ($name =~ /^\w/ and not $self->{nobind
}) {
3545 $re = $self->bind($re, $name);
3546 $::BINDINGS
{$name} += $::PLURALITY
;
3551 sub kids
{ my $self = shift; \
$self->{re
} }
3554 { package RE_assertion
; use base
"REbase";
3557 if ($$self{assert
} eq '!') {
3558 my $re = $$self{re
}->walk;
3559 DEEP
::raw
("\$C->_NOTBEFORE(" . ::hang
(DEEP
::chunk
($re)->p5expr, " ") .")");
3562 my $re = $$self{re
}->walk;
3563 return $re if $re->p5expr =~ /^\$C->before/; #XXX
3564 DEEP
::raw
("\$C->before(" . ::hang
(DEEP
::chunk
($re)->p5expr, " ") . ")");
3567 # TODO: Investigate what the LTM engine is doing with assertions and
3570 sub has_trailing_ws
{
3574 $before; # Transparent
3577 sub remove_leading_ws
{
3580 $self->{re
}->remove_leading_ws;
3583 sub kids
{ my $self = shift; \
$self->{re
} }
3586 { package RE_meta
; use base
"REbase";
3589 my $text = $$self{text
};
3593 if ($text =~ /^(\\[A-Z])(.*)/) {
3594 $text = lc($1) . $2;
3597 # to return yourself, you must either be a symbol or handle $not
3600 return DEEP
::p5regex
("(?<=(?s:.)");
3603 $code = "\$C->cursor_incr()";
3606 elsif ($text eq '.*') {
3607 $code = "\$C->_SCANg$::REV()";
3610 elsif ($text eq '.*?') {
3611 $code = "\$C->_SCANf$::REV()";
3614 elsif ($text eq '^') {
3615 return DEEP
::p5regex
('\A');
3617 elsif ($text eq '^^') {
3618 return DEEP
::p5regex
('(?m:^)');
3620 elsif ($text eq '$') {
3621 return DEEP
::p5regex
('\z');
3623 elsif ($text eq '$$') {
3624 return DEEP
::p5regex
('(?m:$)');
3626 elsif ($text eq ':') {
3627 my $extra = $self->{extra
} || '';
3628 $code = "(($extra), \$C)[-1]";
3630 elsif ($text eq '::') {
3631 $code = "\$C->_COMMITLTM$::REV()";
3633 elsif ($text eq '::>') {
3634 $code = "\$C->_COMMITBRANCH$::REV()";
3636 elsif ($text eq ':::') {
3637 $code = "\$C->_COMMITRULE$::REV()";
3639 elsif ($text eq '\\d') {
3641 return DEEP
::p5regex
($not ?
'(?<=\D)' : '(?<=\d)');
3644 return DEEP
::p5regex
($not ?
'\D' : '\d');
3647 elsif ($text eq '\\w') {
3649 return DEEP
::p5regex
($not ?
'(?<=\W)' : '(?<=\w)');
3652 return DEEP
::p5regex
($not ?
'\W' : '\w');
3655 elsif ($text eq '\\s') {
3657 return DEEP
::p5regex
($not ?
'(?<=\W)' : '(?<=\w)');
3660 return DEEP
::p5regex
($not ?
'\S' : '\s');
3663 elsif ($text eq '\\h') {
3665 return DEEP
::p5regex
($not ?
'(?<=[^\x20\t\r])' : '(?<=[\x20\t\r])');
3668 return DEEP
::p5regex
($not ?
'[^\x20\t\r]' : '[\x20\t\r]');
3671 elsif ($text eq '\\v') {
3673 return DEEP
::p5regex
($not ?
'(?<=[^\n])' : '(?<=[\n])');
3676 return DEEP
::p5regex
($not ?
'[^\n]' : '\n');
3679 elsif ($text eq '»') {
3680 return DEEP
::p5regex
('\b');
3682 elsif ($text eq '«') {
3683 return DEEP
::p5regex
('\b');
3685 elsif ($text eq '>>') {
3686 $code = "\$C->_RIGHTWB$::REV()";
3688 elsif ($text eq '<<') {
3689 $code = "\$C->_LEFTWB$::REV()";
3691 elsif ($text eq '<(') {
3692 $code = "\$C->_LEFTRESULT$::REV()";
3694 elsif ($text eq ')>') {
3695 $code = "\$C->_RIGHTRESULT$::REV()";
3697 elsif ($text eq '<~~>') {
3698 $code = "\$C->$::NAME()";
3702 $code = "\$C->_EXACT$::REV(\"$text\")";
3704 if ($not) { # XXX or maybe just .NOT on the end...
3705 $code = "\$C->_NOTCHAR( sub { my \$C=shift;\n" . ::indent
($code) . "\n})";
3707 DEEP
::raw
($code, precut
=> !$bt);
3711 { package RE_cclass
; use base
"REbase";
3714 my $text = $$self{text
};
3715 $self->{i_needed
} = 1;
3716 $text =~ s!(\/|\\\/)!\\$1!g;
3718 $text =~ s/\.\./-/g;
3719 $text =~ s/^-\[/[^/;
3720 $text = "(?<=$text)" if $::REV
;
3722 DEEP
::p5regex
("(?i:$text)");
3725 DEEP
::p5regex
($text, needs_bracket
=> 1);
3730 { package RE_noop
; use base
"REbase";
3733 DEEP
::raw
('$C', precut
=> 1);
3736 sub has_trailing_ws
{
3744 { package RE_decl
; use base
"REbase";
3745 # because cutting one of these would be a disaster
3748 my $self = $class->SUPER::new
(@_);
3752 sub clean
{ my $self = shift;
3753 $self->SUPER::clean
;
3754 delete $self->{body
};
3758 DEEP
::raw
($$self{body
}, isblock
=> 1);
3761 sub has_trailing_ws
{
3769 { package RE_block
; use base
"REbase";
3770 sub clean
{ my $self = shift;
3771 $self->SUPER::clean
;
3772 delete $self->{context
};
3773 delete $self->{body
};
3777 my $ctx = $$self{context
};
3778 my $text = ::indent
($$self{body
});
3779 if ($ctx eq 'void') {
3780 return DEEP
::raw
("scalar(do {\n" . ::indent
($text) . "}, \$C)", precut
=> 1);
3782 elsif ($ctx eq 'bool') {
3783 return DEEP
::raw
("((\$C) x !!do {\n" . ::indent
($text) . "})", precut
=> 1);
3786 return DEEP
::raw
("sub {\n" . ::indent
("my \$C=shift;\n" . $text) . "}", precut
=> 1);
3790 sub has_trailing_ws
{
3798 { package RE_bracket
; use base
"REbase";
3799 sub clean
{ my $self = shift;
3800 $self->SUPER::clean
;
3801 delete $self->{decl
};
3805 my ($re, $r) = $$self{re
}->walk->uncut;
3806 my @decl = map { $_->walk } @
{$$self{decl
}};
3807 DEEP
::raw
("\$C->_BRACKET$r(" . ::hang
(DEEP
::chunk
($re, @decl)->p5expr, " ") . ")");
3810 sub kids
{ my $self = shift; \
$self->{re
} }
3812 sub remove_leading_ws
{
3814 my $re = $$self{re
};
3815 $re->remove_leading_ws();
3818 sub has_trailing_ws
{
3821 $$self{re
}->has_trailing_ws($before);
3825 { package RE_var
; use base
"REbase";
3828 my $var = $$self{var
};
3829 if ($var =~ /^\$/) {
3830 if ($var =~ /^\$M->{(.*)}/) {
3831 my $p = (substr($1,0,1) eq "'") ?
"n" : "p";
3832 DEEP
::raw
("\$C->_BACKREF$p$::REV($1)");
3835 DEEP
::raw
("\$C->_EXACT$::REV($var)");
3838 elsif ($var =~ /^\@/) {
3839 DEEP
::raw
("\$C->_ARRAY$::REV($var)");
3841 elsif ($var =~ /^\%/) {
3842 DEEP
::raw
("\$C->_HASH$::REV($var)");
3847 { package RE_paren
; use base
"REbase";
3848 sub clean
{ my $self = shift;
3849 $self->SUPER::clean
;
3850 delete $self->{decl
};
3857 $re = $$self{re
}->walk->p5block;
3859 for my $binding ( keys %::BINDINGS
) {
3860 next unless $::BINDINGS
{$binding} > 1;
3861 my $re = <<"END" . $re;
3862 \$C->{'$binding'} = [];
3867 $re = "\$C->_$::REV"."PAREN( " . ::hang
(DEEP
::chunk
(DEEP
::raw
($re))->p5expr, " ") . ")";
3871 sub kids
{ my $self = shift; \
$self->{re
} }
3873 # yes, () would capture the ws, but we're guaranteed to be past it already
3874 sub remove_leading_ws
{
3876 my $re = $$self{re
};
3877 $re->remove_leading_ws();
3880 sub has_trailing_ws
{
3883 $$self{re
}->has_trailing_ws($before);
3887 { package RE_bindpos
; use base
"REbase";
3888 sub clean
{ my $self = shift;
3889 $self->SUPER::clean
;
3890 delete $self->{var
};
3894 my $var = $$self{var
};
3895 $::BINDINGS
{$var} += $::PLURALITY
;
3896 my $re = $$self{atom
}->walk;
3897 $self->bind($re, $var);
3900 sub kids
{ my $self = shift; \
$self->{atom
} }
3902 sub remove_leading_ws
{
3904 my $re = $$self{atom
};
3905 $re->remove_leading_ws();
3908 sub has_trailing_ws
{
3911 $$self{atom
}->has_trailing_ws($before);
3915 { package RE_bindnamed
; use base
"REbase";
3916 sub clean
{ my $self = shift;
3917 $self->SUPER::clean
;
3918 delete $self->{var
};
3922 my $var = $$self{var
};
3923 # XXX STD for gimme5 bug-compatibility, names push inside quantifiers
3924 $::BINDINGS
{$var} += $::PLURALITY
;
3925 if ($$self{atom
}->isa('RE_quantified_atom')) {
3926 local $::BINDINSIDE
= $var;
3927 return $$self{atom
}->walk;
3929 my $re = $$self{atom
}->walk;
3930 $self->bind($re, $var);
3933 sub kids
{ my $self = shift; \
$self->{atom
} }
3935 sub remove_leading_ws
{
3937 my $re = $$self{atom
};
3938 $re->remove_leading_ws();
3941 sub has_trailing_ws
{
3944 $$self{atom
}->has_trailing_ws($before);
3948 # DEEP is the lowest level of desugaring used by viv, but it still keeps a tree
3949 # structure. Not all DEEP nodes are interchangable; some represent expression
3950 # bits, others statements with no sensible return value.
3955 sub maybacktrack
{ 1 }
3957 sub uncut
{ my $self = shift; $self, ($self->maybacktrack ?
'' : 'r') }
3959 # p5 should return (is a block?), text; takes arguments sh (can shadow $C?)
3960 # and ov (can overwrite $C?); non-block returns may not shadow
3961 sub p5expr
{ my $self = shift;
3962 my ($isbl, $text) = $self->p5(@_, sh
=> 1);
3963 $isbl ?
("do {\n" . ::indent
($text) . "\n}") : $text;
3966 sub p5block
{ my $self = shift;
3967 my ($isbl, $text) = $self->p5(@_);
3968 $isbl ?
$text : ($text . "\n");
3971 # psq returns the same as p5 for now
3972 sub psqexpr
{ my $self = shift;
3973 my ($isbl, $text) = $self->psq(@_, sh
=> 1);
3974 $isbl ?
("do {\n" . ::indent
($text) . "\n}") : $text;
3978 { package DEEP
::raw
; our @ISA = 'DEEPexpr';
3981 bless { text
=> $text, @_ }, "DEEP::raw";
3986 return !$self->{precut
};
3989 sub p5
{ my $self = shift;
3990 $self->{isblock
}, $self->{text
};
3993 sub psq
{ my $self = shift;
3994 $self->{isblock
}, $self->{text
};
3998 { package DEEP
::cut
; our @ISA = 'DEEPexpr';
4001 if (!$child->maybacktrack) {
4004 if ($child->isa('DEEP::bind')) {
4005 return DEEP
::bind(DEEP
::cut
($child->{child
}), @
{$child->{names
}});
4007 bless { child
=> $child }, "DEEP::cut";
4010 sub p5
{ my $self = shift;
4011 1, "if (my (\$C) = (" . ::hang
($self->{child
}->p5expr, " ") . ")) { (\$C) } else { () }\n";
4014 sub maybacktrack
{ 0 }
4018 my ($child_uncut) = $self->{child
}->uncut;
4023 { package DEEP
::bind; our @ISA = 'DEEPexpr';
4027 if ($child->isa('DEEP::bind')) {
4028 push @names, @
{$child->{names
}};
4029 $child = $child->{child
};
4031 bless { child
=> $child, names
=> \
@names }, "DEEP::bind";
4034 sub maybacktrack
{ $_[0]{child
}->maybacktrack }
4036 sub p5
{ my $self = shift;
4037 my ($chinner, $r) = $self->{child
}->uncut;
4038 0, "\$C->_SUBSUME$r([" .
4039 join(',', map {"'$_'"} @
{$self->{names
}}) .
4040 "], sub {\n" . ::indent
("my \$C = shift;\n" .
4041 $chinner->p5block(cl
=> 1, sh
=> 1)) . "})";
4045 { package DEEP
::ratchet
; our @ISA = 'DEEPexpr';
4049 if (::DARE_TO_OPTIMIZE
) {
4050 if ($child->isa('DEEP::ratchet')) {
4051 push @before, @
{$child->{before
}};
4052 $child = $child->{child
};
4054 my ($chinner, $chr) = $child->uncut;
4055 if ($chr && $chinner != $child) {
4056 push @before, $chinner;
4057 $child = DEEP
::raw
('$C', precut
=> 1);
4060 bless { child
=> $child, before
=> \
@before }, "DEEP::ratchet";
4063 sub maybacktrack
{ $_[0]{child
}->maybacktrack }
4065 sub p5
{ my $self = shift; my %a = @_;
4066 if (@
{$self->{before
}} == 1) {
4067 my $pre = $self->{before
}[0];
4068 return 1, "if (my (\$C) = (" . ::hang
($pre->p5expr, " " x
8). ")) {\n" .
4069 ::indent
($self->{child
}->p5block) . "} else { () }\n";
4071 my $conditional = join ::hang
("\nand ", " "),
4072 map { "(\$C) = (" . ::hang
($_->p5expr, " " x
8) . ")" }
4075 my $guts = ($conditional ?
4076 "if ($conditional) {\n" .
4077 ::indent
($self->{child
}->p5block) . "} else { () }\n"
4078 : $self->{child
}->p5block(cl
=> 1, sh
=> 1));
4080 $guts = "my \$C = \$C;\n" . $guts unless $a{cl
};
4081 $guts = "do {\n" . ::indent
($guts) . "};\n" unless $a{sh
};
4085 # NOT a regex bit, but a value
4086 { package DEEP
::chunk
; our @ISA = 'DEEPexpr';
4089 bless { child
=> $child, decl
=> \
@_ }, "DEEP::chunk";
4094 0, "sub {\n" . ::indent
(
4096 join("", map { $_->p5block } @
{ $self->{decl
} }) .
4097 $self->{child
}->p5block(cl
=> 1, sh
=> 1)) . "}";
4101 { package DEEP
::p5regex
; our @ISA = 'DEEPexpr';
4104 bless { text
=> $text, has_meta
=> 1, @_ }, "DEEP::p5regex";
4109 0, $self->{has_meta
} ?
4110 "\$C->_PATTERN(qr/\\G" . $self->{text} . "/)" :
4111 "\$C->_EXACT(\"" . $self->{text
} . "\")";
4117 $self->{needs_cut
} ?
"(?>" . $self->{text
} . ")"
4118 : ($btoo && $self->{needs_bracket
}
4119 ?
"(?:" . $self->{text
} . ")"
4123 sub maybacktrack
{ 0 }
4126 { package DEEP
::call
; our @ISA = 'DEEPexpr';
4128 my ($name, @args) = @_;
4129 bless { name
=> $name, args
=> \
@args }, "DEEP::call";
4133 'note', => "System.Console.Error.WriteLine"
4136 sub psq
{ my $self = shift;
4137 my $n = $self->{name
};
4138 my $np = $psq_map{$n};
4140 my $n2 = $psq_map{$n} // $n;
4141 if ($n2 =~ /infix:<(.*)>/) {
4143 $np = sub { my ($a1, $a2) = @_;
4144 "(" . $a1->psqexpr . $op . $a2->psqexpr . ")"; };
4146 elsif ($n2 =~ /prefix:<(.*)>/) {
4148 $np = sub { my ($a) = @_;
4149 "(" . $op . $a->psqexpr . ")"; };
4151 elsif ($n2 =~ /postfix:<(.*)>/) {
4153 $np = sub { my ($a) = @_;
4154 "(" . $a->psqexpr . $op . ")"; };
4157 $np = sub { $n2 . "(" . join(", ",
4158 map { $_->psqexpr } @_) . ")" };
4162 return 0, $np->(@
{$self->{args
}});
4167 if ($OPT_compile_setting) {
4168 STD
->parsefile($OPT_compile_setting, setting
=> "NULL");
4172 HelpMessage
() unless @ARGV || $PROG;
4175 my $raw = retrieve
($_[0]);
4176 $ORIG = $raw->{ORIG
};
4178 $STD::ALL
= $raw->{STABS
};
4179 for my $cl (keys %{$raw->{GENCLASS
}}) {
4180 Actions
::gen_class
($cl, $raw->{GENCLASS
}->{$cl});
4183 elsif (@ARGV and -f
$ARGV[0]) {
4184 $r = STD
->parsefile($ARGV[0], text_return
=> \
$ORIG,
4185 actions
=> 'Actions')->{'_ast'};
4194 $r = STD
->parse($PROG, actions
=> 'Actions')->{'_ast'};
4196 unless ($OPT_thaw) {
4201 $r->{stabs
} = $STD::ALL
;
4203 if ($OPT_output eq 'yaml') {
4205 # $x =~ s/\n.*: \[\]$//mg;
4208 elsif ($OPT_output eq 'concise') {
4209 spew concise
($r, 80);
4211 elsif ($OPT_output eq 'p6') {
4214 elsif ($OPT_output eq 'psq') {
4217 elsif ($OPT_output eq 'p5') {
4218 spew fixpod
($r->p5);
4220 elsif ($OPT_output eq 'none') {
4221 say "@ARGV syntax OK";
4223 elsif ($OPT_output eq 'store') {
4226 my $data = { AST
=> $r, GENCLASS
=> \
%Actions::GENCLASS
,
4227 ORIG
=> $ORIG, STABS
=> $STD::ALL
};
4228 defined($OPT_output_file) ? store
($data, $OPT_output_file)
4229 : Storable
::store_fd
($data, \
*STDOUT
);
4232 die "Unknown output mode";
4238 # vim: ts=8 sw=4 noexpandtab smarttab