File Coverage

blib/lib/Text/Xslate/Compiler.pm
Criterion Covered Total %
statement 702 728 96.4
branch 219 256 85.5
condition 67 89 75.2
subroutine 63 63 100.0
pod 0 9 0.0
total 1051 1145 91.7


line stmt bran cond sub pod time code
1             package Text::Xslate::Compiler;
2 172     172   111834 use Mouse;
  172         221506  
  172         837  
3 172     172   44978 use Mouse::Util::TypeConstraints;
  172         290  
  172         881  
4              
5 172     172   10929 use Scalar::Util ();
  172         234  
  172         1955  
6 172     172   551 use Carp ();
  172         197  
  172         2082  
7              
8 172     172   65848 use Text::Xslate::Parser;
  172         10692  
  172         6048  
9 172         31183 use Text::Xslate::Util qw(
10             $DEBUG
11             value_to_literal
12             is_int any_in
13             make_error
14             p
15 172     172   831 );
  172         195  
16              
17             #use constant _VERBOSE => scalar($DEBUG =~ /\b verbose \b/xms);
18             use constant {
19 172         1125756 _DUMP_ASM => scalar($DEBUG =~ /\b dump=asm \b/xms),
20             _DUMP_AST => scalar($DEBUG =~ /\b dump=ast \b/xms),
21             _DUMP_GEN => scalar($DEBUG =~ /\b dump=gen \b/xms),
22             _DUMP_CAS => scalar($DEBUG =~ /\b dump=cascade \b/xms),
23              
24             _OP_NAME => 0,
25             _OP_ARG => 1,
26             _OP_LINE => 2,
27             _OP_FILE => 3,
28             _OP_LABEL => 4,
29             _OP_COMMENT => 5,
30              
31             _FOR_LOOP => 1,
32             _WHILE_LOOP => 2,
33 172     172   798 };
  172         215  
34              
35              
36             our $OPTIMIZE = scalar(($DEBUG =~ /\b optimize=(\d+) \b/xms)[0]);
37             if(not defined $OPTIMIZE) {
38             $OPTIMIZE = 1; # enable optimization by default
39             }
40              
41             our @CARP_NOT = qw(Text::Xslate Text::Xslate::Parser);
42              
43             {
44             package Text::Xslate;
45             our %OPS; # to avoid 'once' warnings;
46             }
47              
48             my %binary = (
49             '==' => 'eq',
50             '!=' => 'ne',
51             '<' => 'lt',
52             '<=' => 'le',
53             '>' => 'gt',
54             '>=' => 'ge',
55              
56             '~~' => 'match',
57              
58             '<=>' => 'ncmp',
59             'cmp' => 'scmp',
60              
61             '+' => 'add',
62             '-' => 'sub',
63             '*' => 'mul',
64             '/' => 'div',
65             '%' => 'mod',
66              
67             '~' => 'concat',
68             'x' => 'repeat',
69              
70             '+|' => 'bitor',
71             '+&' => 'bitand',
72             '+^' => 'bitxor',
73              
74             'min' => 'lt', # a < b ? a : b
75             'max' => 'gt', # a > b ? a : b
76              
77             '[' => 'fetch_field',
78             );
79             my %logical_binary = (
80             '&&' => 'and',
81             '||' => 'or',
82             '//' => 'dor',
83             );
84              
85             my %unary = (
86             '!' => 'not',
87             '+' => 'noop',
88             '-' => 'minus',
89             '+^' => 'bitneg',
90              
91             'max_index' => 'max_index', # for loop context vars
92             );
93              
94             my %goto_family = map { $_ => undef } qw(
95             for_iter
96             and
97             dand
98             or
99             dor
100             goto
101             );
102              
103             my %builtin = (
104             'html_escape' => ['builtin_html_escape',
105             \&Text::Xslate::Util::html_escape],
106             'uri_escape' => ['builtin_uri_escape',
107             \&Text::Xslate::Util::uri_escape],
108             'mark_raw' => ['builtin_mark_raw',
109             \&Text::Xslate::Util::mark_raw],
110             'unmark_raw' => ['builtin_unmark_raw',
111             \&Text::Xslate::Util::unmark_raw],
112              
113             'raw' => ['builtin_mark_raw',
114             \&Text::Xslate::Util::mark_raw],
115              
116             'html' => ['builtin_html_escape',
117             \&Text::Xslate::Util::html_escape],
118             'uri' => ['builtin_uri_escape',
119             \&Text::Xslate::Util::uri_escape],
120              
121             'is_array_ref' => ['builtin_is_array_ref',
122             \&Text::Xslate::Util::is_array_ref],
123             'is_hash_ref' => ['builtin_is_hash_ref',
124             \&Text::Xslate::Util::is_hash_ref],
125             );
126              
127             has lvar_id => ( # local variable id
128             is => 'rw',
129             isa => 'Int',
130              
131             init_arg => undef,
132             );
133              
134             has lvar => ( # local variable id table
135             is => 'rw',
136             isa => 'HashRef[Int]',
137              
138             init_arg => undef,
139             );
140              
141             has const => (
142             is => 'rw',
143             isa => 'ArrayRef',
144              
145             init_arg => undef,
146             );
147              
148             has macro_table => (
149             is => 'rw',
150             isa => 'HashRef',
151              
152             predicate => 'has_macro_table',
153             init_arg => undef,
154             );
155              
156             has engine => ( # Xslate engine
157             is => 'ro',
158             isa => 'Object',
159             required => 0,
160             weak_ref => 1,
161             );
162              
163             has dependencies => (
164             is => 'ro',
165             isa => 'ArrayRef',
166             init_arg => undef,
167             );
168              
169             has type => (
170             is => 'rw',
171             isa => enum([qw(html xml text)]),
172             default => 'html',
173             );
174              
175             has syntax => (
176             is => 'rw',
177              
178             default => 'Kolon',
179             );
180              
181             has parser_option => (
182             is => 'rw',
183             isa => 'HashRef',
184              
185             default => sub { {} },
186             );
187              
188             has parser => (
189             is => 'rw',
190             isa => 'Object', # Text::Xslate::Parser
191              
192             handles => [qw(define_function)],
193              
194             lazy => 1,
195             builder => '_build_parser',
196             init_arg => undef,
197             );
198              
199             has input_layer => (
200             is => 'ro',
201             default => ':utf8',
202             );
203              
204             sub _build_parser {
205 238     238   5280 my($self) = @_;
206 238         1583 my $syntax = $self->syntax;
207 238 100       1720 if(ref($syntax)) {
208 1         4 return $syntax;
209             }
210             else {
211 237         2391 my $parser_class = Mouse::Util::load_first_existing_class(
212             "Text::Xslate::Syntax::" . $syntax,
213             $syntax,
214             );
215             return $parser_class->new(
216 237         21687 %{$self->parser_option},
  237         5365  
217             engine => $self->engine,
218             compiler => $self,
219             );
220             }
221             }
222              
223             has cascade => (
224             is => 'rw',
225             init_arg => undef,
226             );
227              
228             has [qw(header footer macro)] => (
229             is => 'rw',
230             isa => 'ArrayRef',
231             );
232              
233             has current_file => (
234             is => 'rw',
235              
236             init_arg => undef,
237             );
238              
239             has file => (
240             is => 'rw',
241              
242             init_arg => undef,
243             );
244              
245             has overridden_builtin => (
246             is => 'ro',
247             isa => 'HashRef',
248              
249             default => sub { +{} },
250             );
251              
252             sub lvar_use {
253 1476     1476 0 1350 my($self, $n) = @_;
254              
255 1476         3456 return $self->lvar_id + $n;
256             }
257              
258             sub filename {
259 48281     48281 0 36744 my($self) = @_;
260 48281         55719 my $file = $self->file;
261 48281 100       76005 return ref($file) ? '' : $file;
262             }
263              
264             sub compile {
265 3460     3460 0 13776 my($self, $input, %args) = @_;
266              
267             # each compiling process is independent
268 3460         7663 local $self->{macro_table} = {};
269 3460         5175 local $self->{lvar_id } = 0;
270 3460         4893 local $self->{lvar} = {};
271 3460         5735 local $self->{const} = [];
272 3460         4667 local $self->{in_loop} = 0;
273 3460         4868 local $self->{dependencies} = [];
274 3460         4390 local $self->{cascade};
275 3460         5158 local $self->{header} = $self->{header};
276 3460         4908 local $self->{footer} = $self->{footer};
277 3460         4287 local $self->{macro} = $self->{macro};
278 3460         4963 local $self->{current_file} = ''; # for opinfo
279 3460   100     10139 local $self->{file} = $args{file} || \$input;
280              
281 3460 100       11384 if(my $engine = $self->engine) {
282 3455         5959 my $ob = $self->overridden_builtin;
283 3455         6514 Internals::SvREADONLY($ob, 0);
284 3455         9666 foreach my $name(keys %builtin) {
285 31095         32696 my $f = $engine->{function}{$name};
286 31095         44302 $ob->{$name} = ( $builtin{$name}[1] != $f ) + 0;
287             }
288 3455         8066 Internals::SvREADONLY($ob, 1);
289             }
290              
291 3460         6586 my $parser = $self->parser;
292              
293 3460         4898 my $header = delete $self->{header};
294 3460         4156 my $footer = delete $self->{footer};
295 3460         4030 my $macro = delete $self->{macro};
296              
297 3460 100       6421 if(!$args{omit_augment}) {
298 2233 100       4209 if($header) {
299 9         24 substr $input, 0, 0, $self->_cat_files($header);
300             }
301 2233 100       5069 if($footer) {
302 9         17 $input .= $self->_cat_files($footer);
303             }
304             }
305 3460 100       5303 if($macro) {
306 2 50       3 if(!grep { $_ eq $self->current_file } @$macro) {
  2         13  
307 2         6 substr $input, 0, 0, $self->_cat_files($macro);
308             }
309             }
310              
311 3460         3461 my @code; # main code
312             {
313 3460         3565 my $ast = $parser->parse($input, %args);
  3460         11218  
314 3411         4160 print STDERR p($ast) if _DUMP_AST;
315 3411         10721 @code = (
316             $self->opcode(set_opinfo => undef, file => $self->current_file, line => 1),
317             $self->compile_ast($ast),
318             $self->opcode('end'),
319             );
320             }
321              
322 3396         7628 my $cascade = $self->cascade;
323 3396 100       6193 if(defined $cascade) {
324 74         181 $self->_process_cascade($cascade, \%args, \@code);
325             }
326              
327 3391 50       11271 push @code, $self->_flush_macro_table() if $self->has_macro_table;
328              
329 3391 50       5982 if($OPTIMIZE) {
330 3391         10346 $self->_optimize_vmcode(\@code) for 1 .. 3;
331             }
332              
333 3391         3353 print STDERR "// ", $self->filename, "\n",
334             $self->as_assembly(\@code, scalar($DEBUG =~ /\b ix \b/xms))
335             if _DUMP_ASM;
336              
337             {
338 3391         3485 my %uniq;
  3391         3553  
339             push @code,
340 84         202 map { [ depend => $_ ] }
341 3391   66     3701 grep { !ref($_) and !$uniq{$_}++ } @{$self->dependencies};
  101         483  
  3391         10503  
342             }
343              
344 3391         25637 return \@code;
345             }
346              
347             sub opcode { # build an opcode
348 51951     51951 0 67113 my($self, $name, $arg, %args) = @_;
349 51951         44295 my $symbol = $args{symbol};
350 51951         38628 my $file = $args{file};
351 51951         37557 my $label = $args{label};
352 51951 100       68055 if(not defined $file) {
353 47969         51656 $file = $self->filename;
354 47969 100 66     142866 if(defined $file and $file ne $self->current_file) {
355 1954         6478 $self->current_file($file);
356             }
357             else {
358 46015         47476 $file = undef;
359             }
360             }
361             # name, arg, label, line, file, comment
362             return [ $name => $arg,
363             $args{line} || (ref $symbol ? $symbol->line : undef),
364             $file,
365             $label,
366             $args{comment},
367 51951   66     242577 ];
368             }
369              
370             sub push_expr {
371 5906     5906 0 4351 my($self, $node) = @_;
372              
373 5906         8166 my $list_op = $node->arity eq 'range';
374 5906         5705 my @code = ($self->compile_ast($node));
375 5906 100       6908 if(not $list_op) {
376 5899         5813 push @code, $self->opcode('push');
377             }
378 5906         8692 return @code;
379             }
380              
381              
382             sub _cat_files {
383 20     20   21 my($self, $files) = @_;
384 20   33     54 my $engine = $self->engine || $self->_error("No Xslate engine which header/footer requires");
385 20         22 my $s = '';
386 20         14 foreach my $file(@{$files}) {
  20         25  
387 26         68 my $fullpath = $engine->find_file($file)->{fullpath};
388 26         124 $s .= $engine->slurp_template( $self->input_layer, $fullpath );
389 26         59 $self->requires($fullpath);
390             }
391 20         60 return $s;
392             }
393              
394             our $_lv = -1;
395              
396             sub compile_ast {
397 17927     17927 0 15533 my($self, $ast) = @_;
398 17927 100       23772 return if not defined $ast;
399              
400 17782         11955 local $_lv = $_lv + 1 if _DUMP_GEN;
401              
402 17782         12569 my @code;
403 17782 100       27669 foreach my $node(ref($ast) eq 'ARRAY' ? @{$ast} : $ast) {
  4609         8655  
404 28329 50       59010 Scalar::Util::blessed($node) or Carp::confess("[BUG] Not a node object: " . p($node));
405              
406 28329         23207 printf STDERR "%s"."generate %s (%s)\n", "." x $_lv, $node->arity, $node->id if _DUMP_GEN;
407              
408 28329   33     89225 my $generator = $self->can('_generate_' . $node->arity)
409             || Carp::confess("[BUG] Unexpected node: " . p($node));
410              
411 28329         38101 push @code, $self->$generator($node);
412             }
413              
414 17748         37231 return @code;
415             }
416              
417             sub _process_cascade {
418 74     74   88 my($self, $cascade, $args, $main_code) = @_;
419 74         65 printf STDERR "# cascade %s %s", $self->file, $cascade->dump if _DUMP_CAS;
420 74   33     196 my $engine = $self->engine
421             || $self->_error("Cannot cascade templates without Xslate engine", $cascade);
422              
423 74         63 my($base_file, $base_code);
424 74         133 my $base = $cascade->first;
425             my @components = $cascade->second
426 74 100       184 ? (map{ $self->_bare_to_file($_) } @{$cascade->second})
  13         26  
  11         22  
427             : ();
428 74         125 my $vars = $cascade->third;
429              
430 74 100       117 if(defined $base) { # pure cascade
431 67         165 $base_file = $self->_bare_to_file($base);
432 66         320 $base_code = $engine->load_file($base_file);
433 64         176 $self->requires( $engine->find_file($base_file)->{fullpath} );
434             }
435             else { # overlay
436 7         9 $base_file = $args->{file}; # only for error messages
437 7         99 $base_code = $main_code;
438              
439 7 50       16 if(defined $args->{fullpath}) {
440 0         0 $self->requires( $args->{fullpath} );
441             }
442              
443 7         5 push @{$main_code}, $self->_flush_macro_table();
  7         17  
444             }
445              
446 71         176 foreach my $cfile(@components) {
447 13         32 my $code = $engine->load_file($cfile);
448 13         35 my $fullpath = $engine->find_file($cfile)->{fullpath};
449              
450 13         40 my $mtable = $self->macro_table;
451 13         11 my $macro;
452 13         11 foreach my $c(@{$code}) {
  13         20  
453             # $c = [name, arg, line, file, symbol ]
454              
455             # retrieve macros from assembly code
456 158 100       232 if($c->[_OP_NAME] eq 'macro_begin' .. $c->[_OP_NAME] eq 'macro_end') {
    50          
457 100 100       246 if($c->[_OP_NAME] eq 'macro_begin') {
    50          
    50          
    100          
458 23         22 $macro = [];
459 23         55 $macro = {
460             name => $c->[_OP_ARG],
461             line => $c->[_OP_LINE],
462             file => $c->[_OP_FILE],
463             body => [],
464             };
465 23   50     20 push @{ $mtable->{$c->[_OP_ARG]} ||= [] }, $macro;
  23         101  
466             }
467             elsif($c->[_OP_NAME] eq 'macro_nargs') {
468 0         0 $macro->{nargs} = $c->[_OP_ARG];
469             }
470             elsif($c->[_OP_NAME] eq 'macro_outer') {
471 0         0 $macro->{outer} = $c->[_OP_ARG];
472             }
473             elsif($c->[_OP_NAME] eq 'macro_end') {
474             # noop
475             }
476             else {
477 54         33 push @{$macro->{body}}, $c;
  54         62  
478             }
479             }
480             elsif($c->[_OP_NAME] eq 'depend') {
481 0         0 $self->requires($c->[_OP_ARG]);
482             }
483             }
484 13         25 $self->requires($fullpath);
485 13         21 $self->_process_cascade_file($cfile, $base_code);
486             }
487              
488 71 100       129 if(defined $base) { # pure cascade
489 64         138 $self->_process_cascade_file($base_file, $base_code);
490 62 100       98 if(defined $vars) {
491 13         10 unshift @{$base_code}, $self->_localize_vars($vars);
  13         26  
492             }
493              
494 62         58 foreach my $c(@{$main_code}) {
  62         104  
495 168 50 66     430 if($c->[_OP_NAME] eq 'print_raw_s'
496             && $c->[_OP_ARG] =~ m{ [^ \t\r\n] }xms) {
497 0         0 Carp::carp("Xslate: Useless use of text '$c->[1]'");
498             }
499             }
500 62         57 @{$main_code} = @{$base_code};
  62         280  
  62         78  
501             }
502             else { # overlay
503 7         11 return;
504             }
505             }
506              
507             sub _process_cascade_file {
508 77     77   87 my($self, $file, $base_code) = @_;
509 77         73 printf STDERR "# cascade file %s\n", p($file) if _DUMP_CAS;
510 77         120 my $mtable = $self->macro_table;
511              
512 77         93 for(my $i = 0; $i < @{$base_code}; $i++) {
  820         1034  
513 745         502 my $c = $base_code->[$i];
514 745 100       887 if($c->[_OP_NAME] ne 'macro_begin') {
515 676         492 next;
516             }
517              
518             # macro
519 69         84 my $name = $c->[_OP_ARG];
520 69         143 $name =~ s/\@.+$//;
521 69         101 printf STDERR "# macro %s\n", $name if _DUMP_CAS;
522              
523 69 100       141 if(exists $mtable->{$name}) {
524 2         3 my $m = $mtable->{$name};
525 2 50       9 if(ref($m) ne 'HASH') {
526 0         0 $self->_error('[BUG] Unexpected macro structure: '
527             . p($m) );
528             }
529              
530             $self->_error(
531             "Redefinition of macro/block $name in " . $file
532             . " (you must use block modifiers to override macros/blocks)",
533             $m->{line}
534 2         9 );
535             }
536              
537 67         154 my $before = delete $mtable->{$name . '@before'};
538 67         103 my $around = delete $mtable->{$name . '@around'};
539 67         100 my $after = delete $mtable->{$name . '@after'};
540              
541 67 100       122 if(defined $before) {
542 25         20 my $n = scalar @{$base_code};
  25         28  
543 25         17 foreach my $m(@{$before}) {
  25         29  
544 25         20 splice @{$base_code}, $i+1, 0, @{$m->{body}};
  25         28  
  25         60  
545             }
546 25         19 $i += scalar(@{$base_code}) - $n;
  25         39  
547             }
548              
549 67         66 my $macro_start = $i+1;
550 67         370 $i++ while($base_code->[$i][_OP_NAME] ne 'macro_end'); # move to the end
551              
552 67 100       106 if(defined $around) {
553 21         23 my @original = splice @{$base_code}, $macro_start, ($i - $macro_start);
  21         62  
554 21         20 $i = $macro_start;
555              
556 21         21 my @body;
557 21         21 foreach my $m(@{$around}) {
  21         36  
558 21         16 push @body, @{$m->{body}};
  21         51  
559             }
560 21         57 for(my $j = 0; $j < @body; $j++) {
561 142 100       271 if($body[$j][_OP_NAME] eq 'super') {
562 7         17 splice @body, $j, 1, @original;
563             }
564             }
565 21         23 splice @{$base_code}, $macro_start, 0, @body;
  21         51  
566              
567 21         43 $i += scalar(@body);
568             }
569              
570 67 100       154 if(defined $after) {
571 24         19 foreach my $m(@{$after}) {
  24         30  
572 24         17 splice @{$base_code}, $i, 0, @{$m->{body}};
  24         26  
  24         89  
573             }
574             }
575             }
576 75         129 return;
577             }
578              
579              
580             sub _flush_macro_table {
581 3398     3398   3866 my($self) = @_;
582 3398         5470 my $mtable = $self->macro_table;
583 3398         3498 my @code;
584 3398         3537 foreach my $macros(values %{$mtable}) {
  3398         9312  
585 259 100       525 foreach my $macro(ref($macros) eq 'ARRAY' ? @{$macros} : $macros) {
  29         33  
586             push @code,
587             $self->opcode( macro_begin => $macro->{name},
588             file => $macro->{file},
589 259         532 line => $macro->{line} );
590              
591             push @code, $self->opcode( macro_nargs => $macro->{nargs} )
592 259 100       612 if $macro->{nargs};
593              
594             push @code, $self->opcode( macro_outer => $macro->{outer} )
595 259 100       458 if $macro->{outer};
596              
597 259         216 push @code, @{ $macro->{body} }, $self->opcode('macro_end');
  259         448  
598             }
599             }
600 3398         3811 %{$mtable} = ();
  3398         6005  
601 3398         6153 return @code;
602             }
603              
604             sub _generate_name {
605 450     450   591 my($self, $node) = @_;
606              
607 450         1934 my $id = $node->value; # may be aliased
608 450 100       1215 if(defined(my $lvar_id = $self->lvar->{$id})) { # constants
609 71         126 my $code = $self->const->[$lvar_id];
610 71 100       96 if(defined $code) {
611             # because the constant value is very simple,
612             # its definition is optimized away.
613             # only its value remains.
614 23         19 return @{$code};
  23         51  
615             }
616             else {
617 48         73 return $self->opcode( load_lvar => $lvar_id, symbol => $node );
618             }
619             }
620              
621 379         822 return $self->opcode( fetch_symbol => $id, line => $node->line );
622             }
623              
624             sub _generate_operator {
625 1     1   2 my($self, $node) = @_;
626             # This method is called when an operators is used as an expression,
627             # e.g. <: + :>, so simply throws the error
628 1         2 $self->_error("Invalid expression", $node);
629             }
630              
631             sub _can_optimize_print {
632 2401     2401   3532 my($self, $name, $node) = @_;
633              
634 2401 50       4621 return 0 if !$OPTIMIZE;
635 2401 50 66     5329 return 0 if !($name eq 'print' or $name eq 'print_raw');
636              
637 2401         4216 my $maybe_name = $node->first;
638             return $node->arity eq 'call'
639             && $maybe_name->arity eq 'name'
640             && @{$node->second} == 1 # args of the filter
641             && any_in($maybe_name->id, qw(raw mark_raw html))
642 2401   100     10173 && !$self->overridden_builtin->{$maybe_name->id};
643             }
644              
645             # also deal with smart escaping
646             sub _generate_print {
647 12663     12663   12645 my($self, $node) = @_;
648              
649 12663         10725 my @code;
650              
651 12663         18094 my $proc = $node->id;
652 12663 100 100     28635 if($proc eq 'print' and $self->type eq 'text') {
653 28         31 $proc = 'print_raw';
654             }
655              
656 12663         11071 foreach my $arg(@{ $node->first }){
  12663         25435  
657 12694 100 66     63422 if( $proc eq 'print' && $self->overridden_builtin->{html_escape} ) {
    100 100        
    100          
658             # default behaviour of print() is overridden
659 5         9 push @code,
660             $self->opcode('pushmark'),
661             $self->compile_ast($arg),
662             $self->opcode('push'),
663             $self->opcode('fetch_symbol' => 'html_escape'),
664             $self->opcode('funcall'),
665             $self->opcode('print_raw');
666             }
667             elsif(exists $Text::Xslate::OPS{$proc . '_s'}
668             && $arg->arity eq 'literal'){
669 10288         27205 push @code,
670             $self->opcode( $proc . '_s' => $arg->value,
671             line => $arg->line );
672             }
673             elsif($self->_can_optimize_print($proc, $arg)){
674 27         48 my $filter = $arg->first;
675 27         46 my $filter_name = $filter->id;
676 27 100       58 my $command = $builtin{ $filter_name }[0] eq 'builtin_mark_raw'
677             ? 'print_raw' # mark_raw, raw
678             : 'print'; # html
679              
680 27         70 push @code,
681             $self->compile_ast($arg->second->[0]),
682             $self->opcode(
683             $command => undef,
684             symbol => $filter );
685              
686             }
687             else {
688 2374         4823 push @code,
689             $self->compile_ast($arg),
690             $self->opcode( $proc => undef, line => $node->line );
691             }
692             }
693              
694 12654 50       20308 if(!@code) {
695 0         0 $self->_error("$node requires at least one argument", $node);
696             }
697 12654         24775 return @code;
698             }
699              
700             sub _generate_include {
701 1253     1253   1011 my($self, $node) = @_;
702              
703 1253         1509 my $file = $node->first;
704 1253 100       2618 my @code = (
705             ( ref($file) eq 'ARRAY'
706             ? $self->opcode( literal => $self->_bare_to_file($file) )
707             : $self->compile_ast($file) ),
708             $self->opcode( $node->id => undef, line => $node->line ),
709             );
710              
711 1253 100       2819 if(defined(my $vars = $node->second)) {
712 17         34 @code = ($self->opcode('enter'),
713             $self->_localize_vars($vars),
714             @code,
715             $self->opcode('leave'),
716             );
717             }
718 1252         2249 return @code;
719             }
720              
721             sub _bare_to_file {
722 83     83   90 my($self, $file) = @_;
723 83 100       199 if(ref($file) eq 'ARRAY') { # myapp::foo
    100          
724 68         72 return join('/', map { $_->value } @{$file}) . $self->{engine}->{suffix};
  120         617  
  68         84  
725             }
726             elsif($file->arity eq 'literal') {
727 14         33 return $file->value;
728             }
729             else {
730 1         16 $self->_error("Expected a name or string literal", $file);
731             }
732             }
733              
734             sub _generate_cascade {
735 74     74   85 my($self, $node) = @_;
736 74 50       194 if(defined $self->cascade) {
737 0         0 $self->_error("Cannot cascade twice in a template", $node);
738             }
739 74         116 $self->cascade( $node );
740 74         97 return;
741             }
742              
743             # XXX: need more consideration
744             sub _compile_loop_block {
745 196     196   202 my($self, $block) = @_;
746 196         298 my @block_code = $self->compile_ast($block);
747              
748 196         280 foreach my $op(@block_code) {
749 1620 100       2449 if(any_in( $op->[_OP_NAME], qw(pushmark loop_control))) {
750             # pushmark ... funcall (or something) may create mortal SVs
751             # so surround the block with ENTER and LEAVE
752 25         51 unshift @block_code, $self->opcode('enter');
753 25         53 push @block_code, $self->opcode('leave');
754 25         34 last;
755             }
756             }
757              
758 196         495 foreach my $i(1 .. (@block_code-1)) {
759 1640         1058 my $op = $block_code[$i];
760 1640 100       2269 if($op->[_OP_NAME] eq 'loop_control') {
761 10         8 my $type = $op->[_OP_ARG];
762 10         10 $op->[_OP_NAME] = 'goto';
763              
764 10         9 $op->[_OP_ARG] = (@block_code - $i);
765              
766 10 100       19 $op->[_OP_ARG] += 1 if $type eq 'last';
767             }
768             }
769              
770 196         506 return @block_code;
771             }
772              
773             sub _generate_for {
774 171     171   194 my($self, $node) = @_;
775 171         290 my $expr = $node->first;
776 171         287 my $vars = $node->second;
777 171         259 my $block = $node->third;
778              
779 171 50       145 if(@{$vars} != 1) {
  171         352  
780 0         0 $self->_error("A for-loop requires single variable for each item", $node);
781             }
782 171         159 local $self->{lvar} = { %{$self->lvar} }; # new scope
  171         636  
783 171         181 local $self->{const} = [ @{$self->const} ]; # new scope
  171         435  
784 171         224 local $self->{in_loop} = _FOR_LOOP;
785              
786 171         309 my @code = $self->compile_ast($expr);
787              
788 171         175 my($iter_var) = @{$vars};
  171         210  
789 171         365 my $lvar_id = $self->lvar_id;
790 171         390 my $lvar_name = $iter_var->id;
791              
792 171         489 $self->lvar->{$lvar_name} = $lvar_id;
793 171         296 $self->lvar->{'($_)'} = $lvar_id;
794              
795 171         287 push @code, $self->opcode( for_start => $lvar_id, symbol => $iter_var );
796              
797             # a for statement uses three local variables (container, iterator, and item)
798 171         289 local $self->{lvar_id} = $self->lvar_use(3);
799              
800 171         367 my @block_code = $self->_compile_loop_block($block);
801 171         369 push @code,
802             $self->opcode( literal_i => $lvar_id, symbol => $iter_var ),
803             $self->opcode( for_iter => scalar(@block_code) + 2 ),
804             @block_code,
805             $self->opcode( goto => -(scalar(@block_code) + 2), comment => "end for" );
806              
807 171         1132 return @code;
808             }
809              
810             sub _generate_for_else {
811 8     8   9 my($self, $node) = @_;
812              
813 8         11 my $for_block = $node->first;
814 8         8 my $else_block = $node->second;
815              
816 8         15 my @code = (
817             $self->compile_ast($for_block),
818             );
819              
820             # 'for' block sets __a with true if the loop count > 0
821 8         13 my @else = $self->compile_ast($else_block);
822 8         16 push @code, (
823             $self->opcode( or => scalar(@else) + 1, comment => 'for-else' ),
824             @else,
825             );
826              
827 8         27 return @code;
828             }
829              
830             sub _generate_while {
831 25     25   32 my($self, $node) = @_;
832 25         46 my $expr = $node->first;
833 25         45 my $vars = $node->second;
834 25         40 my $block = $node->third;
835              
836 25 50       20 if(@{$vars} > 1) {
  25         76  
837 0         0 $self->_error("A while-loop requires one or zero variable for each items", $node);
838             }
839              
840 25         52 (my $cond_op, undef, $expr) = $self->_prepare_cond_expr($expr);
841              
842             # TODO: combine all the loop contexts into single one
843 25         31 local $self->{lvar} = { %{$self->lvar} }; # new scope
  25         103  
844 25         23 local $self->{const} = [ @{$self->const} ]; # new scope
  25         59  
845 25         33 local $self->{in_loop} = _WHILE_LOOP;
846              
847 25         44 my @code = $self->compile_ast($expr);
848              
849 25         29 my($iter_var) = @{$vars};
  25         33  
850 25         30 my($lvar_id, $lvar_name);
851              
852 25 100       126 if(@{$vars}) {
  25         45  
853 10         50 $lvar_id = $self->lvar_id;
854 10         16 $lvar_name = $iter_var->id;
855 10         22 $self->lvar->{$lvar_name} = $lvar_id;
856 10         16 push @code, $self->opcode( save_to_lvar => $lvar_id, symbol => $iter_var );
857             }
858              
859 25         26 local $self->{lvar_id} = $self->lvar_use(scalar @{$vars});
  25         47  
860 25         62 my @block_code = $self->_compile_loop_block($block);
861 25         58 return @code,
862             $self->opcode( $cond_op => scalar(@block_code) + 2, symbol => $node ),
863             @block_code,
864             $self->opcode( goto => -(scalar(@block_code) + scalar(@code) + 1), comment => "end while" );
865              
866 0         0 return @code;
867             }
868              
869             sub _generate_loop_control {
870 12     12   10 my($self, $node) = @_;
871 12         21 my $type = $node->id;
872              
873 12 50       19 any_in($type, qw(last next))
874             or $self->_error("[BUG] Unknown loop control statement '$type'");
875              
876 12 100       28 if(not $self->{in_loop}) {
877 2         8 $self->_error("Use of loop control statement ($type) outside of loops");
878             }
879              
880 10         5 my @cleanup;
881 10 100 100     30 if( $self->{in_loop} == _FOR_LOOP && $type eq 'last' ) {
882 2         5 my $lvar_id = $self->lvar->{'($_)'};
883 2 50       5 defined($lvar_id)
884             or $self->_error('[BUG] Undefined loop iterator');
885              
886 2         5 @cleanup = (
887             $self->opcode( 'nil', undef,
888             comment => 'to clean the loop context' ),
889             $self->opcode( save_to_lvar => $lvar_id + 0), # item
890             $self->opcode( save_to_lvar => $lvar_id + 1), # iterator
891             $self->opcode( save_to_lvar => $lvar_id + 2), # body
892             $self->opcode( literal_i => 1 ), # for 'for-else'
893             );
894             }
895              
896 10         15 return $self->opcode('leave'),
897             @cleanup,
898             $self->opcode('loop_control' => $type, comment => $type);
899             }
900              
901             sub _generate_proc { # definition of macro, block, before, around, after
902 312     312   311 my($self, $node) = @_;
903 312         502 my $type = $node->id;
904 312         616 my $name = $node->first->id;
905 312         256 my @args = map{ $_->id } @{$node->second};
  114         282  
  312         688  
906 312         510 my $block = $node->third;
907              
908 312         232 local $self->{lvar} = { %{$self->lvar} }; # new scope
  312         1050  
909 312         279 local $self->{const} = [ @{$self->const} ]; # new scope
  312         656  
910              
911 312         465 my $lvar_used = $self->lvar_id;
912 312         235 my $arg_ix = 0;
913 312         414 foreach my $arg(@args) {
914             # to fetch ST(ix)
915             # Note that arg_ix must be start from 1
916 114         293 $self->lvar->{$arg} = $lvar_used + $arg_ix++;
917             }
918              
919 312         501 local $self->{lvar_id} = $self->lvar_use($arg_ix);
920              
921 312         551 my $opinfo = $self->opcode(set_opinfo => undef, file => $self->filename, line => $node->line);
922 312         633 my %macro = (
923             name => $name,
924             nargs => $arg_ix,
925             body => [ $opinfo, $self->compile_ast($block) ],
926             line => $opinfo->[2],
927             file => $opinfo->[3],
928             outer => $lvar_used,
929             );
930              
931 312 100       937 if(any_in($type, qw(macro block))) {
932 236 100       692 if(exists $self->macro_table->{$name}) {
933 2         5 my $m = $self->macro_table->{$name};
934 2 50       7 if(p(\%macro) ne p($m)) {
935 2         170 $self->_error("Redefinition of $type $name is forbidden", $node);
936             }
937             }
938 234         598 $self->macro_table->{$name} = \%macro;
939             }
940             else {
941 76         269 my $fq_name = sprintf '%s@%s', $name, $type;
942 76         97 $macro{name} = $fq_name;
943 76   50     58 push @{ $self->macro_table->{ $fq_name } ||= [] }, \%macro;
  76         424  
944             }
945 310         914 return;
946             }
947              
948             sub _generate_lambda {
949 39     39   41 my($self, $node) = @_;
950              
951 39         54 my $macro = $node->first;
952 39         49 $self->compile_ast($macro);
953 39         125 return $self->opcode( fetch_symbol => $macro->first->id, line => $node->line );
954             }
955              
956             sub _prepare_cond_expr {
957 419     419   363 my($self, $expr) = @_;
958 419         378 my $t = "and";
959 419         343 my $f = "or";
960              
961 419         1087 while($expr->id eq '!') {
962 31         53 $expr = $expr->first;
963 31         92 ($t, $f) = ($f, $t);
964             }
965              
966 419 100 100     1490 if($expr->is_logical and any_in($expr->id, qw(== !=))) {
967 167         276 my $rhs = $expr->second;
968 167 100       444 if($rhs->arity eq "nil") {
969             # add prefix 'd' (i.e. "and" to "dand", "or" to "dor")
970 39         64 substr $t, 0, 0, 'd';
971 39         43 substr $f, 0, 0, 'd';
972              
973 39 100       126 if($expr->id eq "==") {
974 18         30 ($t, $f) = ($f, $t);
975             }
976 39         73 $expr = $expr->first;
977             }
978             }
979              
980 419         721 return($t, $f, $expr);
981             }
982              
983             sub _generate_if {
984 394     394   410 my($self, $node) = @_;
985 394         588 my $first = $node->first;
986 394         543 my $second = $node->second;
987 394         530 my $third = $node->third;
988              
989 394         625 my($cond_true, $cond_false, $expr) = $self->_prepare_cond_expr($first);
990              
991 394         375 local $self->{lvar} = { %{$self->lvar} }; # new scope
  394         1354  
992 394         405 local $self->{const} = [ @{$self->const} ]; # new scope
  394         868  
993 394         733 my @cond = $self->compile_ast($expr);
994              
995 394         529 my @then = do {
996 394         531 local $self->{lvar} = { %{$self->lvar} }; # new scope
  394         1224  
997 394         454 local $self->{const} = [ @{$self->const} ]; # new scope
  394         759  
998 394         663 $self->compile_ast($second);
999             };
1000              
1001 394         352 my @else = do {
1002 394         289 local $self->{lvar} = { %{$self->lvar} }; # new scope
  394         974  
1003 394         339 local $self->{const} = [ @{$self->const} ]; # new scope
  394         720  
1004 394         568 $self->compile_ast($third);
1005             };
1006              
1007 394 50       657 if($OPTIMIZE) {
1008 394 100       605 if($self->_code_is_literal(@cond)) {
1009 101         129 my $value = $cond[0][_OP_ARG];
1010 101 100       215 if($cond_true eq 'and' ? $value : !$value) {
    100          
1011 75         290 return @then;
1012             }
1013             else {
1014 26         116 return @else;
1015             }
1016             }
1017             }
1018              
1019 293 100 100     1380 if( (@then and @else) or !$OPTIMIZE) {
    100 66        
1020             return(
1021 217         662 @cond,
1022             $self->opcode( $cond_true => scalar(@then) + 2, comment => $node->id . ' (then)' ),
1023             @then,
1024             $self->opcode( goto => scalar(@else) + 1, comment => $node->id . ' (else)' ),
1025             @else,
1026             );
1027             }
1028             elsif(!@else) { # no @else
1029             return(
1030 72         243 @cond,
1031             $self->opcode( $cond_true => scalar(@then) + 1, comment => $node->id . ' (then/no-else)' ),
1032             @then,
1033             );
1034             }
1035             else { # no @then
1036             return(
1037 4         15 @cond,
1038             $self->opcode( $cond_false => scalar(@else) + 1, comment => $node->id . ' (else/no-then)'),
1039             @else,
1040             );
1041             }
1042             }
1043              
1044             sub _generate_given {
1045 39     39   39 my($self, $node) = @_;
1046 39         55 my $expr = $node->first;
1047 39         45 my $vars = $node->second;
1048 39         43 my $block = $node->third;
1049              
1050 39 50       31 if(@{$vars} > 1) {
  39         61  
1051 0         0 $self->_error("A given block requires one or zero variables", $node);
1052             }
1053 39         28 local $self->{lvar} = { %{$self->lvar} }; # new scope
  39         126  
1054 39         35 local $self->{const} = [ @{$self->const} ]; # new scope
  39         73  
1055              
1056 39         80 my @code = $self->compile_ast($expr);
1057              
1058 39         39 my($lvar) = @{$vars};
  39         39  
1059 39         57 my $lvar_id = $self->lvar_id;
1060 39         57 my $lvar_name = $lvar->id;
1061              
1062 39         70 $self->lvar->{$lvar_name} = $lvar_id;
1063              
1064 39         50 local $self->{lvar_id} = $self->lvar_use(1); # topic variable
1065 39         52 push @code, $self->opcode( save_to_lvar => $lvar_id, symbol => $lvar ),
1066             $self->compile_ast($block);
1067              
1068 39         151 return @code;
1069             }
1070              
1071             sub _generate_variable {
1072 3188     3188   3793 my($self, $node) = @_;
1073              
1074 3188 100       19627 if(defined(my $lvar_id = $self->lvar->{$node->value})) {
1075 420         636 return $self->opcode( load_lvar => $lvar_id, symbol => $node );
1076             }
1077             else {
1078 2768         5036 my $name = $self->_variable_to_value($node);
1079 2768 100       6043 if($name =~ /~/) {
1080 8         33 $self->_error("Undefined iterator variable $node", $node);
1081             }
1082 2760         6374 return $self->opcode( fetch_s => $name, line => $node->line );
1083             }
1084             }
1085              
1086             sub _generate_super {
1087 7     7   7 my($self, $node) = @_;
1088              
1089 7         12 return return $self->opcode( super => undef, symbol => $node );
1090             }
1091              
1092             sub _generate_literal {
1093 7301     7301   5571 my($self, $node) = @_;
1094 7301         11189 return $self->opcode( literal => $node->value );
1095             }
1096              
1097             sub _generate_nil {
1098 69     69   78 my($self) = @_;
1099 69         117 return $self->opcode('nil');
1100             }
1101              
1102             sub _generate_vars {
1103 6     6   8 my($self) = @_;
1104 6         12 return $self->opcode('vars');
1105             }
1106              
1107             sub _generate_composer {
1108 133     133   134 my($self, $node) = @_;
1109              
1110 133         212 my $list = $node->first;
1111 133 100       339 my $type = $node->id eq '{' ? 'make_hash' : 'make_array';
1112              
1113             return
1114             $self->opcode( pushmark => undef, comment => $type ),
1115 133         211 (map{ $self->push_expr($_) } @{$list}),
  5266         5345  
  133         249  
1116             $self->opcode($type),
1117             ;
1118             }
1119              
1120             sub _generate_unary {
1121 33     33   39 my($self, $node) = @_;
1122              
1123 33         58 my $id = $node->id;
1124 33 50       66 if(exists $unary{$id}) {
1125 33         86 my @operand = $self->compile_ast($node->first);
1126             my @code = (
1127             @operand,
1128 33         66 $self->opcode( $unary{$id} )
1129             );
1130 33 100 66     154 if( $OPTIMIZE and $self->_code_is_literal(@operand) ) {
1131 17         30 $self->_fold_constants(\@code);
1132             }
1133 33         104 return @code;
1134             }
1135             else {
1136 0         0 $self->_error("Unary operator $id is not implemented", $node);
1137             }
1138             }
1139              
1140             sub _generate_field {
1141 312     312   399 my($self, $node) = @_;
1142              
1143 312         697 my @lhs = $self->compile_ast($node->first);
1144 304         515 my $field = $node->second;
1145              
1146             # $foo.field
1147             # $foo["field"]
1148 304 100       893 if($field->arity eq "literal") {
1149             return
1150 250         1008 @lhs,
1151             $self->opcode( fetch_field_s => $field->value );
1152             }
1153             # $foo[expression]
1154             else {
1155 54         87 local $self->{lvar_id} = $self->lvar_use(1);
1156 54         82 my @rhs = $self->compile_ast($field);
1157 54 100 66     166 if($OPTIMIZE and $self->_code_is_literal(@rhs)) {
1158             return
1159 14         26 @lhs,
1160             $self->opcode( fetch_field_s => $rhs[0][1] );
1161             }
1162             return
1163 40         106 @lhs,
1164             $self->opcode( save_to_lvar => $self->lvar_id ),
1165             @rhs,
1166             $self->opcode( load_lvar_to_sb => $self->lvar_id ),
1167             $self->opcode( 'fetch_field' ),
1168             ;
1169             }
1170              
1171             }
1172              
1173             sub _generate_binary {
1174 941     941   852 my($self, $node) = @_;
1175              
1176 941         1851 my @lhs = $self->compile_ast($node->first);
1177              
1178 939         1507 my $id = $node->id;
1179 939 100       1606 if(exists $binary{$id}) {
    50          
1180 716         979 local $self->{lvar_id} = $self->lvar_use(1);
1181 716         1354 my @rhs = $self->compile_ast($node->second);
1182             my @code = (
1183             @lhs,
1184             $self->opcode( save_to_lvar => $self->lvar_id ),
1185             @rhs,
1186             $self->opcode( load_lvar_to_sb => $self->lvar_id ),
1187 716         1477 $self->opcode( $binary{$id} ),
1188             );
1189              
1190 716 100       1676 if(any_in($id, qw(min max))) {
1191 26         44 local $self->{lvar_id} = $self->lvar_use(1);
1192 26         53 splice @code, -1, 0,
1193             $self->opcode(save_to_lvar => $self->lvar_id ); # save lhs
1194 26         52 push @code,
1195             $self->opcode( or => +2 , symbol => $node ),
1196             $self->opcode( load_lvar_to_sb => $self->lvar_id ), # on true
1197             # fall through
1198             $self->opcode( 'move_from_sb' ), # on false
1199             }
1200              
1201 716 50       1085 if($OPTIMIZE) {
1202 716 100 100     1169 if( $self->_code_is_literal(@lhs) and $self->_code_is_literal(@rhs) ){
1203 123         205 $self->_fold_constants(\@code);
1204             }
1205             }
1206 716         2189 return @code;
1207             }
1208             elsif(exists $logical_binary{$id}) {
1209 223         446 my @rhs = $self->compile_ast($node->second);
1210             return
1211             @lhs,
1212 223         475 $self->opcode( $logical_binary{$id} => scalar(@rhs) + 1, symbol => $node ),
1213             @rhs;
1214             }
1215              
1216 0         0 $self->_error("Binary operator $id is not implemented", $node);
1217             }
1218              
1219             sub _generate_range {
1220 7     7   5 my($self, $node) = @_;
1221              
1222 7 50       12 $self->can_be_in_list_context
1223             or $self->_error("Range operator must be in list context");
1224              
1225 7         17 my @lhs = $self->compile_ast($node->first);
1226              
1227 7         11 local $self->{lvar_id} = $self->lvar_use(1);
1228 7         15 my @rhs = $self->compile_ast($node->second);
1229             return(
1230 7         16 @lhs,
1231             $self->opcode( save_to_lvar => $self->lvar_id ),
1232             @rhs,
1233             $self->opcode( load_lvar_to_sb => $self->lvar_id ),
1234             $self->opcode( 'range' ),
1235             );
1236             }
1237              
1238             sub _generate_methodcall {
1239 230     230   216 my($self, $node) = @_;
1240              
1241 230         395 my $args = $node->third;
1242 230         1068 my $method = $node->second->value;
1243             return (
1244             $self->opcode( pushmark => undef, comment => $method ),
1245             $self->push_expr($node->first),
1246 230         349 (map { $self->push_expr($_) } @{$args}),
  137         176  
  230         411  
1247             $self->opcode( methodcall_s => $method, line => $node->line ),
1248             );
1249             }
1250              
1251             sub _generate_call {
1252 458     458   600 my($self, $node) = @_;
1253 458         681 my $callable = $node->first; # function or macro
1254 458         629 my $args = $node->second;
1255              
1256 458 100 100     1487 if(my $intern = $builtin{$callable->id} and !$self->overridden_builtin->{$callable->id}) {
1257 54 50       34 if(@{$args} != 1) {
  54         105  
1258 0         0 $self->_error("Wrong number of arguments for $callable", $node);
1259             }
1260              
1261 54         105 return $self->compile_ast($args->[0]),
1262             [ $intern->[0] => undef, $node->line ];
1263             }
1264              
1265             return(
1266             $self->opcode( pushmark => undef, comment => $callable->id ),
1267 404         877 (map { $self->push_expr($_) } @{$args}),
  273         401  
  404         686  
1268             $self->compile_ast($callable),
1269             $self->opcode( 'funcall' )
1270             );
1271             }
1272              
1273             # $~iterator
1274             sub _generate_iterator {
1275 43     43   46 my($self, $node) = @_;
1276              
1277 43         68 my $item_var = $node->first;
1278 43         164 my $lvar_id = $self->lvar->{$item_var};
1279 43 50       78 if(!defined($lvar_id)) {
1280 0         0 $self->_error("Refer to iterator $node, but $item_var is not defined",
1281             $node);
1282             }
1283              
1284 43         84 return $self->opcode(
1285             load_lvar => $lvar_id + 1,
1286             symbol => $node,
1287             );
1288             }
1289              
1290             # $~iterator.body
1291             sub _generate_iterator_body {
1292 16     16   19 my($self, $node) = @_;
1293              
1294 16         29 my $item_var = $node->first;
1295 16         44 my $lvar_id = $self->lvar->{$item_var};
1296 16 50       35 if(!defined($lvar_id)) {
1297 0         0 $self->_error("Refer to iterator $node.body, but $item_var is not defined",
1298             $node);
1299             }
1300              
1301 16         34 return $self->opcode(
1302             load_lvar => $lvar_id + 2,
1303             symbol => $node,
1304             );
1305             }
1306              
1307             sub _generate_assign {
1308 59     59   66 my($self, $node) = @_;
1309 59         96 my $lhs = $node->first;
1310 59         154 my $rhs = $node->second;
1311 59         99 my $is_decl = $node->third;
1312              
1313 59         94 my $lvar = $self->lvar;
1314 59         100 my $lvar_name = $lhs->id;
1315              
1316 59 50       151 if($node->id ne "=") {
1317 0         0 $self->_error("Assignment ($node) is not supported", $node);
1318             }
1319              
1320 59         157 my @expr = $self->compile_ast($rhs);
1321              
1322 59 100       303 if($is_decl) {
1323 47         149 $lvar->{$lvar_name} = $self->lvar_id;
1324 47         96 $self->{lvar_id} = $self->lvar_use(1); # don't use local()
1325             }
1326              
1327 59 100 66     331 if(!exists $lvar->{$lvar_name} or $lhs->arity ne "variable") {
1328 1         32 $self->_error("Cannot modify $lhs, which is not a lexical variable", $node);
1329             }
1330              
1331             return
1332             @expr,
1333 58         185 $self->opcode( save_to_lvar => $lvar->{$lvar_name}, symbol => $lhs, comment => $node->id);
1334             }
1335              
1336             sub _generate_constant {
1337 73     73   73 my($self, $node) = @_;
1338 73         107 my $lhs = $node->first;
1339 73         253 my $rhs = $node->second;
1340              
1341 73         115 my @expr = $self->compile_ast($rhs);
1342              
1343 73         127 my $lvar = $self->lvar;
1344 73         115 my $lvar_id = $self->lvar_id;
1345 73         118 my $lvar_name = $lhs->id;
1346 73         108 $lvar->{$lvar_name} = $lvar_id;
1347 73         112 $self->{lvar_id} = $self->lvar_use(1); # don't use local()
1348              
1349 73 50       126 if($OPTIMIZE) {
1350 73 100 100     224 if(@expr == 1
1351             && any_in($expr[0][_OP_NAME], qw(literal load_lvar))) {
1352 33         57 $expr[0][_OP_COMMENT] = "constant $lvar_name";
1353 33         73 $self->const->[$lvar_id] = \@expr;
1354 33         71 return @expr; # no real definition
1355             }
1356             }
1357              
1358             return
1359 40         101 @expr,
1360             $self->opcode( save_to_lvar => $lvar_id, symbol => $lhs, comment => $node->id);
1361             }
1362              
1363             sub _localize_vars {
1364 31     31   36 my($self, $vars) = @_;
1365 31         25 my @localize;
1366 31         22 my @pairs = @{$vars};
  31         43  
1367              
1368 31 100       72 if( (@pairs % 2) != 0 ) {
1369 8 100       12 if(@pairs == 1) {
1370 7         13 return $self->compile_ast(@pairs),
1371             $self->opcode( 'localize_vars' );
1372             }
1373             else {
1374 1         2 $self->_error("You must pass pairs of expressions to include");
1375             }
1376             }
1377              
1378 23         58 while(my($key, $expr) = splice @pairs, 0, 2) {
1379 28 50       85 if(!any_in($key->arity, qw(literal variable))) {
1380 0         0 $self->_error("You must pass a simple name to localize variables", $key);
1381             }
1382 28         44 push @localize,
1383             $self->compile_ast($expr),
1384             $self->opcode( localize_s => $key->value, symbol => $key );
1385             }
1386 23         53 return @localize;
1387             }
1388              
1389             sub _variable_to_value {
1390 2768     2768   3246 my($self, $arg) = @_;
1391              
1392 2768         4601 my $name = $arg->value;
1393 2768         8115 $name =~ s/\$//;
1394 2768         6199 return $name;
1395             }
1396              
1397             sub requires {
1398 103     103 0 171 my($self, @files) = @_;
1399 103         97 push @{ $self->dependencies }, @files;
  103         289  
1400 103         164 return;
1401             }
1402              
1403             sub can_be_in_list_context {
1404 7     7 0 5 my $i = 2;
1405 7         30 while(my $funcname = (caller ++$i)[3]) {
1406 14 100       63 if($funcname =~ /::_generate_(\w+) \z/xms) {
1407 7         16 return any_in($1, qw(
1408             methodcall
1409             call
1410             composer
1411             ));
1412             }
1413             }
1414 0         0 return 0;
1415             }
1416              
1417             # optimizatin stuff
1418              
1419             sub _code_is_literal {
1420 1355     1355   1745 my($self, @code) = @_;
1421 1355   66     6704 return @code == 1
1422             && ( $code[0][_OP_NAME] eq 'literal'
1423             || $code[0][_OP_NAME] eq 'literal_i');
1424             }
1425              
1426             sub _fold_constants {
1427 140     140   129 my($self, $code) = @_;
1428 140 50       362 my $engine = $self->engine or return 0;
1429              
1430 140         243 local $engine->{warn_handler} = \&Carp::croak;
1431 140         167 local $engine->{die_handler} = \&Carp::croak;
1432 140         188 local $engine->{verbose} = 1;
1433              
1434 140         171 my $result = eval {
1435 140         95 my @tmp_code = (@{$code}, $self->opcode('print_raw'), $self->opcode('end'));
  140         244  
1436 140         1837 $engine->_assemble(\@tmp_code, '', undef, undef, undef);
1437 140         2022 $engine->render('');
1438             };
1439 140 50       267 if($@) {
1440 0         0 Carp::carp("[BUG] Constant folding failed (ignored): $@");
1441 0         0 return 0;
1442             }
1443              
1444 140         263 @{$code} = ($self->opcode( literal => $result, comment => "optimized by constant folding"));
  140         326  
1445 140         303 return 1;
1446             }
1447              
1448              
1449             sub _noop {
1450 6230     6230   4368 my($self, $op) = @_;
1451 6230         3542 @{$op} = @{ $self->opcode( noop => undef, comment => "ex-$op->[0]") };
  6230         11500  
  6230         9040  
1452 6230         6991 return;
1453             }
1454              
1455             sub _optimize_vmcode {
1456 10173     10173   11287 my($self, $c) = @_;
1457              
1458             # calculate goto addresses
1459             # eg:
1460             #
1461             # goto +3
1462             # foo
1463             # noop
1464             # bar // goto destination
1465             #
1466             # to be:
1467             #
1468             # goto +2
1469             # foo
1470             # bar // goto destination
1471              
1472 10173         9245 my @goto_addr;
1473 10173         10670 for(my $i = 0; $i < @{$c}; $i++) {
  135712         194874  
1474 125539 100       196803 if(exists $goto_family{ $c->[$i][_OP_NAME] }) {
1475 3471         2553 my $addr = $c->[$i][_OP_ARG]; # relational addr
1476              
1477             # mark ragens that goto family have its effects
1478 3471 100       6626 my @range = $addr > 0
1479             ? ($i .. ($i+$addr-1)) # positive
1480             : (($i+$addr) .. $i); # negative
1481              
1482 3471         3472 foreach my $j(@range) {
1483 21782   100     12222 push @{$goto_addr[$j] ||= []}, $c->[$i];
  21782         45812  
1484             }
1485             }
1486             }
1487              
1488 10173         10994 for(my $i = 0; $i < @{$c}; $i++) {
  135712         200781  
1489 125539         104827 my $name = $c->[$i][_OP_NAME];
1490 125539 100       268114 if($name eq 'print_raw_s') {
    100          
    100          
    100          
1491             # merge a chain of print_raw_s into single command
1492 14415         16385 my $j = $i + 1; # from the next op
1493 14415   66     15192 while($j < @{$c}
  20051   100     87625  
1494             && $c->[$j][_OP_NAME] eq 'print_raw_s'
1495 5806 100       13253 && "@{$goto_addr[$i] || []}" eq "@{$goto_addr[$j] || []}") {
  5806 100       18778  
1496              
1497 5636         7590 $c->[$i][_OP_ARG] .= $c->[$j][_OP_ARG];
1498              
1499 5636         5687 $self->_noop($c->[$j]);
1500 5636         3510 $j++;
1501             }
1502             }
1503             elsif($name eq 'save_to_lvar') {
1504             # use registers, instead of local variables
1505             #
1506             # given:
1507             # save_to_lvar $n
1508             #
1509             # load_lvar_to_sb $n
1510             # convert into:
1511             # move_to_sb
1512             #
1513 1236         977 my $it = $c->[$i];
1514 1236         1320 my $nn = $c->[$i+2]; # next next
1515 1236 100 66     5001 if(defined($nn)
      66        
1516             && $nn->[_OP_NAME] eq 'load_lvar_to_sb'
1517             && $nn->[_OP_ARG] == $it->[_OP_ARG]) {
1518 594         418 @{$it} = @{$self->opcode( move_to_sb => undef, comment => "ex-$it->[0]" )};
  594         1283  
  594         1301  
1519              
1520 594         1289 $self->_noop($nn);
1521             }
1522             }
1523             elsif($name eq 'literal') {
1524 19339 100       25875 if(is_int($c->[$i][_OP_ARG])) {
1525 916         1086 $c->[$i][_OP_NAME] = 'literal_i';
1526 916         1624 $c->[$i][_OP_ARG] = int($c->[$i][_OP_ARG]); # force int
1527             }
1528             }
1529             elsif($name eq 'fetch_field') {
1530 138         144 my $prev = $c->[$i-1];
1531 138 50       265 if($prev->[_OP_NAME] =~ /^literal/) { # literal or literal_i
1532 0         0 $c->[$i][_OP_NAME] = 'fetch_field_s';
1533 0         0 $c->[$i][_OP_ARG] = $prev->[_OP_ARG]; # arg
1534              
1535 0         0 $self->_noop($prev);
1536             }
1537             }
1538             }
1539              
1540             # remove noop
1541 10173         11318 for(my $i = 0; $i < @{$c}; $i++) {
  130122         186946  
1542 119949 100       183877 if($c->[$i][_OP_NAME] eq 'noop') {
1543 5590 100       6087 if(defined $goto_addr[$i]) {
1544 388         304 foreach my $goto(@{ $goto_addr[$i] }) {
  388         518  
1545             # reduce its absolute value
1546 596 100       911 $goto->[1] > 0
1547             ? $goto->[1]-- # positive
1548             : $goto->[1]++; # negative
1549             }
1550             }
1551 5590         3235 splice @{$c}, $i, 1;
  5590         6044  
1552             # adjust @goto_addr, but it may be empty
1553 5590 100       9720 splice @goto_addr, $i, 1 if @goto_addr > $i;
1554             }
1555             }
1556 10173         25453 return;
1557             }
1558              
1559             sub as_assembly {
1560 7     7 0 7 my($self, $code_ref, $addix) = @_;
1561              
1562 7         8 my $asm = "";
1563 7         7 foreach my $ix(0 .. (@{$code_ref}-1)) {
  7         14  
1564 47         23 my($name, $arg, $line, $file, $label, $comment) = @{$code_ref->[$ix]};
  47         63  
1565 47 50       53 $asm .= "$ix:" if $addix; # for debugging
1566              
1567             # "$opname $arg #$line:$file *$symbol // $comment"
1568 47 50       58 ref($name) and die "Oops: " . p($code_ref->[$ix]);
1569 47         30 $asm .= $name;
1570 47 100       55 if(defined $arg) {
1571 11         18 $asm .= " " . value_to_literal($arg);
1572             }
1573 47 100       63 if(defined $line) {
1574 28         26 $asm .= " #$line";
1575 28 100       32 if(defined $file) {
1576 7         16 $asm .= ":" . value_to_literal($file);
1577             }
1578             }
1579 47 50       56 if(defined $label) {
1580 0         0 $asm .= " " . value_to_literal($label);
1581             }
1582 47 100       52 if(defined $comment) {
1583 4         7 $asm .= " // $comment";
1584             }
1585 47         43 $asm .= "\n";
1586             }
1587 7         911 return $asm;
1588             }
1589              
1590             sub _error {
1591 18     18   24 my($self, $message, $node) = @_;
1592              
1593 18 100       55 my $line = ref($node) ? $node->line : $node;
1594 18         80 die $self->make_error($message, $self->file, $line);
1595             }
1596              
1597 172     172   1469 no Mouse;
  172         265  
  172         1029  
1598 172     172   15128 no Mouse::Util::TypeConstraints;
  172         211  
  172         957  
1599              
1600             __PACKAGE__->meta->make_immutable;
1601             __END__