misc/Parser-Mini/pil1_json_emit_pir.pl

   1 =pod
   2
   3 PIL2-JSON Parrot-like code emitter
   4 by fglock
   5
   6   ../../pugs -CPIL2-JSON -e ' say "hello "; say 1 + 1 ' | \
   7     ../../pugs pil2_json_emit_pir.pl
   8
   9   #! /usr/bin/parrot
  10   ... TODO
  11
  12 =cut
  13
  14 use v6-alpha;
  15
  16 # -- Language specific
  17
  18 my $id = "V000";
  19
  20 sub emit_Main ( $global, $main ) {
  21     "#! /usr/bin/parrot\n" ~
  22     $global ~
  23     ".sub \"main\" @ANON\n" ~
  24     $main ~
  25     ".end\n"
  26 }
  27 sub emit_Stmt ( $s ) { $s }
  28 sub emit_Code ( $body, $is_multi, $lvalue, @params, $type ) {
  29     "    # ??? - block \{ \n" ~
  30     $body ~
  31     "    # end block"
  32 }
  33 sub emit_Assign( $to, $from ) { $from ~ ' ' ~ $to ~ " # ??? assign =\n" }
  34 sub emit_Bind( $to, $from )   { $from ~ ' ' ~ $to ~ " # ??? bind :=\n" }
  35 sub emit_Sub ( $name, $body, $is_multi, $lvalue, @params, $type ) {
  36     if @params.elems > 1 {
  37         for 0 .. @params.elems-2 -> $i {
  38             # if there are many invocants, separate them with ',' instead of ':'
  39             if @params[$i+1] ~~ m:perl5 {:$} {
  40                 @params[$i] ~~ s:perl5 {:$}{,};
  41             }
  42         }
  43     }
  44     my $param_list = @params.join(" ");
  45     $param_list ~~ s:perl5 {,$}{};  # remove last ','
  46
  47     ".sub $name\n" ~
  48     "    # TODO - param list (" ~ $param_list ~ ")\n" ~
  49     $body ~
  50     ".end\n"
  51 }
  52 sub emit_App ( $function, @args, $context, $invocant ) {
  53     my $p_fun = $id++;
  54     my $ret =
  55     "    .local pmc $p_fun\n" ~
  56     "    $p_fun = new .PerlUndef\n" ~
  57     "    $p_fun = find_name $function\n";
  58
  59     my @p_args;
  60     my @s1;
  61     my @s2;
  62     for @args -> $val {
  63         my $p_arg = $id++;
  64         push @p_args, $p_arg;
  65         $ret ~=
  66         "    .local pmc $p_arg\n" ~
  67         "    $p_arg = new .PerlUndef\n" ~
  68         "    $p_arg = assign $val\n";
  69         push @s1, '16';
  70         push @s2, $p_arg;
  71     };
  72     my $p_ret = $id++;
  73     $ret ~=
  74     "    .local pmc $p_ret\n" ~
  75     "    $p_ret = new .PerlUndef\n" ~
  76     "    set_args '(" ~ @s1.join(', ') ~ ")', " ~ @s2.join(', ') ~ "\n" ~
  77     "    get_results \"(0)\", $p_ret\n" ~
  78     "    invokecc $p_fun\n";
  79 }
  80 sub emit_Pad ( $scope, @symbols, $statements ) {
  81     "    # TODO - _start_pad \n" ~
  82     @symbols.map:{
  83         emit_Variable($_) ~ " my    # ???\n"
  84     } ~
  85     "$statements\n" ~
  86     "    # TODO - _end_pad\n";
  87 }
  88 sub emit_Variable ( $s is copy ) {
  89     return $s;
  90
  91     # rewrite PIL2 '"&infix:+"' to p6 '&infix:<+>'
  92     # but don't re-quote '&main::zz'
  93     $s ~~ s:perl5 /^"(.*)"$/$0/;
  94     $s ~~ s:perl5 {\&(.+fix:)([^:].*)}{&$0:<$1>};
  95
  96     # XXX fix corner cases like 'infix:<:>' and '&main::infix:<aaa>'
  97     $s ~~ s:perl5 {(fix::<)(.*?)>$}{fix:<$1>};
  98     $s ~~ s:perl5 {fix::$}{fix:<:>};
  99
 100     $s
 101 }
 102 sub emit_Int ( $s ) { $s }
 103 sub emit_Str ( $s ) { $s }
 104 sub emit_Rat ( $a, $b ) { "$a $b / " }
 105 sub emit_parameter(
 106     $name, $is_invocant, $is_lvalue, $is_lazy, $is_named,
 107     $is_optional, $is_writable, $context, $default )
 108 {
 109     #say "(param=$name, $is_invocant, $is_lvalue, $is_lazy, $is_named, ",
 110     #    "$is_optional, $is_writable, <", $context.perl, ">, <$default>)";
 111
 112     # ??? - "paramDefault"
 113     # ??? - what is the syntax for $is_lvalue
 114     # ??? - what is the PIL for 'is copy'
 115
 116     # $context = [["CxtSlurpy", [[["MkType", ["Int"] ]]] ]]
 117     my $is_slurpy = $context[0][0] eq '"CxtSlurpy"';
 118     my $type = emit_Variable( $context[0][1][0][0][1] );
 119
 120     my $s;
 121     $s ~= $type eq 'main' ?? '' !! ($type ~ ' ');
 122     $s ~= $is_slurpy ?? '*' !! '';
 123
 124     $s ~= $is_named    eq 'true'        ?? ':' !! '';
 125     $s ~= emit_Variable( $name );
 126     $s ~= $is_optional eq 'true'        ?? '?' !! '';   # '!' is default
 127     $s ~= ' is rw '   if $is_writable eq 'true';
 128     $s ~= ' is lazy ' if $is_lazy     eq 'true';
 129     $s ~= $is_invocant eq 'true'        ?? ':' !! ',';
 130     return $s;
 131 }
 132 sub emit_parameter_with_default( $param, $default ) {
 133     return $param if $default eq '';
 134     # rewrite '$name,' to '$name = default,'
 135     my ($name, $separator) = $param ~~ m:perl5 {(.*)(.)};
 136
 137     $default ~
 138     $name ~
 139     ' = ' ~
 140     $separator
 141 }
 142
 143 # -- Main program
 144 # this is the same for all languages
 145
 146 push @*INC, './';
 147 require 'pil2_json_emit.pm';
 148
 149 # slurp stdin - xinming++
 150 my $pil2 = ** $*IN.slurp;
 151
 152 my @b = tokenize( $pil2 );
 153 # say "Tokens: ", @b.join('><');
 154
 155 my $ast = parse( << { >>, 'hash', << } >>, @b );
 156 # say $ast.perl;
 157
 158 my $program = traverse_ast( $ast );
 159 say $program;
 160