#!/usr/local/bin/perl -ws

# Copyright 1998-1999, Paul Johnson (pjcj@transeda.com)

# This software is free.  It is licensed under the same terms as Perl itself.

# The latest version of this software should be available from my homepage:
# http://www.transeda.com/pjcj

# Version 1.04 - 29th May 1999

use strict;

require 5.004;

use diagnostics;

use Data::Dumper;

use lib ".";
use Parse::RecDescent;

use Gedcom 1.04;

use vars qw( $VERSION $Prefix);
$VERSION = "1.04";

sub _indent
{
  join "", map { ref $_ ? _indent(@$_) : $_ } @_
}

sub indent
{
# print STDERR "indenting @_\n";
  my $i = _indent(@_);
  $i =~ s/^/  /gm;
  $i
}

$Prefix = <<'EOH';
#!/usr/local/bin/perl -w

# This program was generated by lines2perl, which is part of Gedcom.pm.
# Gedcom.pm is Copyright 1998-1999, Paul Johnson (pjcj@transeda.com)
# Version 1.04 - 29th May 1999

# Gedcom.pm is free.  It is licensed under the same terms as Perl itself.

# The latest version of Gedcom.pm should be available from my homepage:
# http://www.transeda.com/pjcj

use strict;

require 5.004;

use diagnostics;

use Gedcom 1.04;

sub _e { print $_[0] if defined $_[0] && length $_[0] }

main();

EOH

my $Grammar = <<'EOG';

program              : (procedure_definition | statement)(s)
                       { print $::Prefix, join("", @{$item[1]}), "\n" }
                     | <error>

statement            : if_statement
                     | while_statement
                     | forlist_statement
                     | include_statement
                       { "$item[1];\n" }
                     | global_statement
                       { "$item[1];\n" }
                     | list_statement
                       { "$item[1];\n" }
                     | table_statement
                       { "$item[1];\n" }
                     | set_statement
                       { "$item[1];\n" }
                     | continue_statement
                       { "$item[1];\n" }
                     | break_statement
                       { "$item[1];\n" }
                     | return_statement
                       { "$item[1];\n" }
                     | builtin_procedure
                       { "$item[1];\n" }
                     | constant
                       { "print $item[1];\n" }
                     | printable_expression
                       { "_e($item[1]);\n" }

expression           : printable_expression
                     | constant
                     | <error>

printable_expression : call_statement
                     | builtin_function
                     | scalar

procedure_definition : ("proc" | "func") <commit> name "(" scalars(?) ")"
                         "{" statement(s) "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         my $args = @{$item[5]} ? $item[5][0] =~ tr/$/$/ : 0;
                         "sub $item[3] (" . '$' x $args  . ")\n" .
                         "{\n" .
                         ($args
                            ? ("  my($item[5][0]) = \@_;\n")
                            : "") .
                         ::indent($item[8]) .
                         ($item[1] eq "proc" ? "  undef\n" : "") .
                         "}\n\n"
                       }

block                : "{" statement(s) "}"
                       { "{\n" . ::indent($item[2]) . "}\n" }

condition_and_block  : "(" scalar_assignment(?) expression ")" block
                       {
                         # warn "item is ", ::Dumper \@item;
                         "(@{$item[2]}$item[3])\n$item[5]"
                       }

if_statement         : "if" condition_and_block
                       elsif_statement(s?)
                       else_statement(?)
                       {
                         # warn "item is ", ::Dumper \@item;
                         # local $"; # this line breaks the parser...
                         "if $item[2]" . join "", @{$item[3]}, @{$item[4]}
                       }

elsif_statement      : "elsif" condition_and_block
                       {
                         # warn "item is ", ::Dumper \@item;
                         "elsif $item[2]"
                       }

else_statement       : "else" block
                       {
                         # warn "item is ", ::Dumper \@item;
                         "else\n$item[2]"
                       }

while_statement      : "while" condition_and_block
                       {
                         # warn "item is ", ::Dumper \@item;
                         "while $item[2]"
                       }

forlist_statement    : "forlist" "(" name "," scalar "," scalar ")"
                         "{" statement(s) "}"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "$item[7] = 0;\n" .
                         "for $item[5] (\@$item[3])\n" .
                         "{\n" .
                         "  $item[7]++;\n" .
                         ::indent($item[10]) .
                         "}\n"
                       }

scalar_assignment    : scalar ","
                       { "$item[1] = " }

include_statement    : "include" "(" expression ")"
                       { "do $item[3]" }

global_statement     : "global" "(" scalar ")"
                       { "my $item[3]" }

set_statement        : "set" "(" scalar "," expression ")"
                       { "$item[3] = $item[5]" }

continue_statement   : "continue" "(" ")"
                       { "continue" }

break_statement      : "break" "(" ")"
                       { "last" }

return_statement     : "return" expression(?)
                       { "return" . (@{$item[2]} ? " @{$item[2]}" : "") }

list_statement       : "list" "(" name ")"
                       { "my \@$item[3]" }

table_statement      : "table" "(" name ")"
                       { "my \%$item[3]" }

name                 : /(?!\d)\w+/

scalar               : name
                       { "\$$item[1]" }

scalars              : scalar ("," scalar)(s?)
                       { join ", ", $item[1], @{$item[2]} }

expressions          : expression ("," expression)(s?)
                       { [$item[1], @{$item[2]}] }

expressions2         : expression ("," expression)(s)
                       { [$item[1], @{$item[2]}] }

call_statement       : "call" name "(" expressions(?) ")"
                       {
                         # warn "item is ", ::Dumper \@item;
                         "$item[2](" . join(", ", map {@$_} @{$item[4]}) . ")"
                       }

builtin_function     : add_function
                     | sub_function
                     | mul_function
                     | div_function
                     | mod_function
                     | exp_function
                     | neg_function
                     | and_function
                     | or_function
                     | not_function
                     | eq_function
                     | ne_function
                     | lt_function
                     | le_function
                     | gt_function
                     | ge_function
                     | empty_function
                     | length_function
                     | dequeue_function
                     | pop_function
                     | getel_function
                     | lookup_function

builtin_procedure    : incr_procedure
                     | decr_procedure
                     | enqueue_procedure
                     | requeue_procedure
                     | push_procedure
                     | setel_procedure
                     | insert_procedure

add_function         : "add" "(" expressions2 ")"
                       { "(" . join(" + ", @{$item[3]}) . ")" }

sub_function         : "sub" "(" expression "," expression ")"
                       { "($item[3] - $item[5])" }

mul_function         : "mul" "(" expressions2 ")"
                       { "(" . join(" * ", @{$item[3]}) . ")" }

div_function         : "div" "(" expression "," expression ")"
                       { "($item[3] / $item[5])" }

mod_function         : "mod" "(" expression "," expression ")"
                       { "($item[3] % $item[5])" }

exp_function         : "exp" "(" expression "," expression ")"
                       { "($item[3] ** $item[5])" }

neg_function         : "neg" "(" expression ")"
                       { "(- $item[3])" }

and_function         : "and" "(" expressions2 ")"
                       { "(" . join(" && ", @{$item[3]}) . ")" }

or_function          : "or" "(" expressions2 ")"
                       { "(" . join(" || ", @{$item[3]}) . ")" }

not_function         : "not" "(" expression ")"
                       { "(! $item[3])" }

eq_function          : "eq" "(" expression "," expression ")"
                       { "($item[3] == $item[5])" }

ne_function          : "ne" "(" expression "," expression ")"
                       { "($item[3] != $item[5])" }

lt_function          : "lt" "(" expression "," expression ")"
                       { "($item[3] < $item[5])" }

le_function          : "le" "(" expression "," expression ")"
                       { "($item[3] <= $item[5])" }

gt_function          : "gt" "(" expression "," expression ")"
                       { "($item[3] > $item[5])" }

ge_function          : "ge" "(" expression "," expression ")"
                       { "($item[3] >= $item[5])" }

empty_function       : "empty" "(" name ")"
                       { "(\@$item[3] ? 0 : 1)" }

length_function       : "length" "(" name ")"
                       { "(int \@$item[3])" }

dequeue_function     : "dequeue" "(" name ")"
                       { "(shift \@$item[3])" }

pop_function         : "pop" "(" name ")"
                       { "(pop \@$item[3])" }

getel_function       : "getel" "(" name "," expression ")"
                       { "\$$item[3]" . "[$item[5] - 1]" }

lookup_function      : "lookup" "(" name "," expression ")"
                       { "\$$item[3]" . "{$item[5]}" }

incr_procedure       : "incr" "(" scalar ")"
                       { "$item[3]++" }

decr_procedure       : "decr" "(" scalar ")"
                       { "$item[3]--" }

enqueue_procedure    : "enqueue" "(" name "," expression ")"
                       { "push \@$item[3], $item[5]" }

requeue_procedure    : "requeue" "(" name "," expression ")"
                       { "unshift \@$item[3], $item[5]" }

push_procedure       : "push" "(" name "," expression ")"
                       { "push \@$item[3], $item[5]" }

setel_procedure      : "setel" "(" name "," expression "," expression ")"
                       { "\$$item[3]" . "[$item[5] - 1] = $item[7]" }

insert_procedure     : "insert" "(" name "," expression "," expression ")"
                       { "\$$item[3]" . "{$item[5]} = $item[7]" }

constant             : /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/
                     | /"[^"]*"/
                     | /'[^']*'/
                     | "nl" "(" ")"
                       { '"\n"' }
                     | "sp" "(" ")"
                       { '" "' }
                     | "qt" "(" ")"
                       { q('"') }

EOG

# $::RD_TRACE = 1;
# $::RD_HINT  = 1;

my $parse = Parse::RecDescent->new($Grammar);

undef $/;

my $input = <>;

# print STDERR "input is $input";

$parse->program($input) or die;
