#! /usr/bin/perl -w
#
# compile.pl - compile a Jako source file Parrot assembly file.
#
# Jako is a *very* simple language with just enough complexity to allow the
# implementation of little programs with while loops.
#
#   * Global data only
#   * No user subroutine definitions
#
# by Gregor N. Purdy <gregor@focusresearch.com>
#
# Copyright (C) 2001 Gregor N. Purdy. All rights reserved.
# This program is free software. It is subject to the same license
# as Perl itself.
#
# $Id: jakoc,v 1.9 2001/10/05 16:54:46 gregor Exp $
#

use strict;

use Carp;

use Data::Dumper;
$Data::Dumper::Useqq  = 1;
$Data::Dumper::Terse  = 1;
$Data::Dumper::Indent = 0;


#
# Global variables:
#

my $line;    # Current source line number

my %ident;   # Identifiers

my %regs = ( # Registers
  I => [ undef ], # $regs{I}[0] reserved for integral  temporaries
  N => [ undef ], # $regs{N}[0] reserved for numeric   temporaries
  P => [ undef ], # $regs{P}[0] reserved for polytypic temporaries
  S => [ undef ], # $regs{S}[0] reserved for string    temporaries
);

my %types = (
 'I' => 'int',
 'N' => 'num',
 'P' => 'poly',
 'S' => 'str',
);

my $block_count = 0;
my @block_stack = ();

my %subs;

my %void_functions = (

);

my %assign_funcs = (
  acos   => [ 'N',    1, '[IN]'     ],
  and    => [ 'I',    2, 'II'       ],
  asec   => [ 'N',    1, '[IN]'     ],
  asin   => [ 'N',    1, '[IN]'     ],
  atan   => [ 'N',    1, '[IN]'     ],
  atan2  => [ 'N',    2, '[IN][IN]' ],
  cos    => [ 'N',    1, '[IN]'     ],
  cosh   => [ 'N',    1, '[IN]'     ],
  exp    => [ 'N',    1, '[IN]'     ],
  ln     => [ 'N',    1, '[IN]'     ],
  log10  => [ 'N',    1, '[IN]'     ],
  log2   => [ 'N',    1, '[IN]'     ],
  not    => [ 'I',    1, 'I'        ],
  or     => [ 'I',    2, 'II'       ],
  pow    => [ 'N',    2, '[IN][IN]' ],
  sec    => [ 'N',    1, '[IN]'     ],
  sech   => [ 'N',    1, '[IN]'     ],
  sin    => [ 'N',    1, '[IN]'     ],
  sinh   => [ 'N',    1, '[IN]'     ],
  substr => [ 'S',    3, 'SII'      ],
  tan    => [ 'N',    1, '[IN]'     ],
  tanh   => [ 'N',    1, '[IN]'     ],
  time   => [ '[IN]', 0             ],
  xor    => [ 'I',    2, 'II'       ],
);


#
# Regular Expressions:
#

my $t_ident   = qr{[A-Za-z][A-Za-z0-9_]*};
my $t_integer = qr{-?\d+};
my $t_string  = qr{\"[^\\\"]*(?:\\.[^\\\"]*)*\"};
my $t_number  = qr{-?\d+\.\d+};


#
# push_label()
#
# Used to push a label onto a stack of labels that will get
# printed at the beginning of the next emit_code() call.
#
# Actually, pushes as many labels as there are arguments.
#

my @label_stack = ( );

sub push_label
{
  push @label_stack, grep { defined $_ and $_ ne '' } @_;
}


#
# push_comment()
#
# Used to push a comment onto a stack of comments that will get
# printed at the beginning of the next emit_code() call.
#
# Actually, pushes as many comments as there are arguments.
#

my @comment_stack = ( );

sub push_comment
{
  push @comment_stack, grep { defined $_ and $_ ne '' } @_;
}


#
# push_source()
#
# Used to push source code comments. This allows them to be
# indented.
#

sub push_source
{
  my $block_indent = '  ' x scalar(@block_stack);
  push_comment map { $block_indent . $_ } @_;
}


#
# emit_code()
#
# emit_code LABEL
# emit_code LABEL OP
# emit_code LABEL OP ARGS
# emit_code LABEL OP ARGS COMMENT
#
# Label can be undef.
#

my $last_op = 'noop';

sub emit_code
{
  my ($op, $args, $comment) = @_;

  #
  # Incorporate any comments into the comment stack:
  #

  push_comment($comment) if defined $comment and $comment ne '';
  $comment = undef;

  #
  # Complain about any undefined arguments:
  #

  if (defined $args and grep { !defined $_ } @$args) {
    confess "jakoc: Internal error: Undefined arguments to emit_code()!";
    return;
  }

  #
  # Print out all but the last comment, each on a line by itself:
  #
  # NOTE: As of 2001-09-20, the assembler doesn't handle lines with
  # only a label and a comment. So, we write these out separately.
  #

  $comment = pop @comment_stack if @comment_stack;

  foreach my $comment (@comment_stack) {
    printf "%-16s %-8s %-25s # %s\n", '', '', '', $comment;
  }

  @comment_stack = ( );

  #
  # Print out all but the last label, each on a line by itself:
  #

  my $label = pop @label_stack if @label_stack;

  foreach my $label (@label_stack) {
    print "$label:\n";
  }

  @label_stack = ( );

  #
  # Print out the label for the actual code line (if any):
  #

  if (defined $label and $label ne '') {
    printf "%-16s ", "$label:";
  } else {
    printf "%-16s ", '';
  }

  #
  # Print out the op mnemonic, if any:
  #

  if (defined $op) {
    printf "%-8s", $op;
    $last_op = $op;
  } else {
    printf "%-8s", '';
  }

  #
  # Print out the arguments, if any:
  #

  if (defined $args and @$args) {
    printf " %-25s", join(", ", @$args);
  } else {
    printf " %-25s", '';
  }

  #
  # Print out the comment, if any:
  #

  if (defined $comment) {
    printf(" # %s", $comment) if defined $comment;
  }

  #
  # End the line like a good text generator:
  #

  print "\n";
}


#
# int_q()
#

sub int_q
{
  my ($value) = @_;
  return $value =~ m/^-?\d+$/;
}


#
# num_q()
#

sub num_q
{
  my ($value) = @_;
  return $value =~ m/^-?\d+\.\d+$/;
}


#
# int_or_num_q()
#

sub int_or_num_q
{
  my ($value) = @_;
  return $value =~ m/^-?\d+(\.\d+)?$/;
}


#
# reg_q()
#

sub reg_q
{
  my ($value) = @_;
  return $value =~ m/^[INPS]\d+$/;
}


#
# int_reg_q()
#

sub int_reg_q
{
  my ($value) = @_;
  return $value =~ m/^I\d+$/;
}


#
# num_reg_q()
#

sub num_reg_q
{
  my ($value) = @_;
  return $value =~ m/^N\d+$/;
}


#
# poly_reg_q()
#

sub poly_reg_q
{
  my ($value) = @_;
  return $value =~ m/^P\d+$/;
}


#
# str_reg_q()
#

sub str_reg_q
{
  my ($value) = @_;
  return $value =~ m/^S\d+$/;
}


#
# op_comp()
#
# There are three kinds of entries in the %comp_ops hash:
#
#   * Perl expressions to optimize all-constant ops to branches.
#
#   * Entries to map source tokens to the op name. This is used
#     in parsing conditionals.
#
#   * Entries to determine the opposite comparison operator if
#     we need to reverse the sense of the operator as it appears
#     in the source.
#
# TODO: Handle numeric comparisons, too!
#

my %comp_ops = (
  'eq' => sub { $_[0] == $_[1] },
  'ne' => sub { $_[0] != $_[1] },
  'le' => sub { $_[0] <= $_[1] },
  'lt' => sub { $_[0] <  $_[1] },
  'ge' => sub { $_[0] >= $_[1] },
  'gt' => sub { $_[0] >  $_[1] },

  '==' => 'eq',
  '!=' => 'ne',
  '<=' => 'le',
  '<'  => 'lt',
  '>=' => 'ge',
  '>'  => 'gt',

  '!eq' => 'ne',
  '!ne' => 'eq',
  '!le' => 'gt',
  '!lt' => 'ge',
  '!ge' => 'lt',
  '!gt' => 'le',
);

sub op_comp
{
  my ($type, $op, $a, $b, $true, $false) = @_;

  $op = $comp_ops{$op} unless ref $comp_ops{$op}; # Map, e.g., '>=' to 'ge'

  #
  # OPTIMIZE const-const comparisons to unconditional branches:
  #

  if (int_or_num_q($a) and int_or_num_q($b)) {
    if (&{$comp_ops{$op}}($a, $b)) {
      emit_code('branch', [$true]);
    } else {
      emit_code('branch', [$false]);
    }

    return;
  }

  #
  # CONVERT const-reg comparisons to reg-const comparisons:
  #
  # We do this by reversing the operand order and inverting the comparison.
  #

  if (int_or_num_q($a) and reg_q($b)) {
    ($a, $op, $b) = ($b, $comp_ops{"!$op"}, $a);
  }

=no
  #
  # CONVERT const-reg and reg-const comparisons to reg-reg comparisons:
  #

  if (int_q($a)) {
    emit_code('set', [int_reg_q($b) ? 'I0' : 'N0', $a]);
    $a = 'I0';
  } elsif (num_q($a)) {
    emit_code('set', ['N0', $a]);
    $a = 'N0';
  } elsif (!reg_q($a)) {
    printf STDERR "jakoc: Syntax error in comparison on line %d!\n", $line;
  }

  if (int_q($b)) {
    emit_code('set', [int_reg_q($a) ? 'I0' : 'N0', $b]);
    $b = 'I0';
  } elsif (num_q($b)) {
    emit_code('set', ['N0', $b]);
    $b = 'N0';
  } elsif (!reg_q($b)) {
    printf STDERR "jakoc: Syntax error in comparison on line %d!\n", $line;
  }
=cut

  #
  # CONVERT num-int and int-num comparisons to num-num comparisons:
  #

  if (int_or_num_q($b)) {
    #
    # reg-const comparisons:
    #
    # NOTE: We count on the assembler to promote the integer constant
    # in the case of num-reg-to-int-const comparisons.
    #

    if (substr($a, 0, 1) eq 'I' and num_q($b)) {
      emit_code('iton', ['N0', $a]);
      $a = 'N0';
    }
  } else {
    #
    # reg-reg comparisons:
    #

    if (substr($a, 0, 1) ne substr($b, 0, 1)) {
      if ($a =~ m/^I/) {
        emit_code('iton', ['N0', $a]);
        $a = 'N0';
      } elsif ($b =~ m/^I/) {
        emit_code('iton', ['N0', $b]);
        $b = 'N0';
      } else {
        confess "jakoc: Internal compiler error. Expected to have to use iton op.";
      }
    }
  }

  #
  # EMIT code:
  #

  if (defined $true) {
    emit_code($op, [$a, $b, $true]);
    if (defined $false) {
      emit_code('branch', [$false]);
    }
  } else {
    if (defined $false) {
      op_comp($type, $comp_ops{"!$op"}, $a, $b, $false, $true);
    } else {
      confess "jakoc: Internal compiler error: op_comp called without any destinations!";
    }
  }
}


#
# op_eq()
#
# Handle a 'eq' op. This includes pseudo-ops for cases that aren't covered in
# by Parrot, such as comparing a register to constant.
#
# eq_i_i    # TRUE op
# eq_i_ic   # PSEUDO op
# eq_ic_i   # PSEUDO op
# eq_ic_ic  # OPTIMIZED to non-conditional branch
#
# TODO: Handle numeric and string comparisons
#

sub op_eq
{
  my ($label, $a, $b, $le, $gt) = @_;
  push_label($label);
  op_comp(undef, 'eq', $a, $b, $le, $gt);
}


#
# op_ne()
#
# Handle a 'ne' op. This includes pseudo-ops for cases that aren't covered in
# by Parrot, such as comparing a register to constant.
#
# ne_i_i    # TRUE op
# ne_i_ic   # PSEUDO op
# ne_ic_i   # PSEUDO op
# ne_ic_ic  # OPTIMIZED to non-conditional branch
#
# TODO: Handle numeric and string comparisons
#

sub op_ne
{
  my ($label, $a, $b, $le, $gt) = @_;
  push_label($label);
  op_comp(undef, 'ne', $a, $b, $le, $gt);
}


#
# op_le()
#
# Handle a 'le' op. This includes pseudo-ops for cases that aren't covered in
# by Parrot, such as comparing a register to constant.
#
# le_i_i    # TRUE op
# le_i_ic   # PSEUDO op
# le_ic_i   # PSEUDO op
# le_ic_ic  # OPTIMIZED to non-conditional branch
#
# TODO: Handle numeric and string comparisons
#

sub op_le
{
  my ($label, $a, $b, $le, $gt) = @_;
  push_label($label);
  op_comp(undef, 'le', $a, $b, $le, $gt);
}


#
# op_lt()
#
# Handle a 'lt' op. This includes pseudo-ops for cases that aren't covered in
# by Parrot, such as comparing a register to constant.
#
# lt_i_i    # TRUE op
# lt_i_ic   # PSEUDO op
# lt_ic_i   # PSEUDO op
# lt_ic_ic  # OPTIMIZED to non-conditional branch
#
# TODO: Handle numeric and string comparisons
#

sub op_lt
{
  my ($label, $a, $b, $le, $gt) = @_;
  push_label($label);
  op_comp(undef, 'lt', $a, $b, $le, $gt);
}


#
# op_ge()
#
# Handle a 'ge' op. This includes pseudo-ops for cases that aren't covered in
# by Parrot, such as comparing a register to constant.
#
# ge_i_i    # TRUE op
# ge_i_ic   # PSEUDO op
# ge_ic_i   # PSEUDO op
# ge_ic_ic  # OPTIMIZED to non-conditional branch
#
# TODO: Handle numeric and string comparisons
#

sub op_ge
{
  my ($label, $a, $b, $le, $gt) = @_;
  push_label($label);
  op_comp(undef, 'ge', $a, $b, $le, $gt);
}


#
# op_gt()
#
# Handle a 'gt' op. This includes pseudo-ops for cases that aren't covered in
# by Parrot, such as comparing a register to constant.
#
# gt_i_i    # TRUE op
# gt_i_ic   # PSEUDO op
# gt_ic_i   # PSEUDO op
# gt_ic_ic  # OPTIMIZED to non-conditional branch
#
# TODO: Handle numeric and string comparisons
#

sub op_gt
{
  my ($label, $a, $b, $le, $gt) = @_;
  push_label($label);
  op_comp(undef, 'gt', $a, $b, $le, $gt);
}


#
# declare_var()
#

sub declare_var
{
  my ($name, $type) = @_;

#  printf(STDERR "jakoc: debug: Declaring variable '%s' of type '%s'...\n", $name, $type);

  if ($ident{$name}) {
    printf STDERR "jakoc: Redeclaration of identifier '%s' on line %d. Previous declaration on line %d.\n",
      $name, $line, $ident{$name}{LINE};
    return 0;
  } else {
    my $num = scalar @{$regs{$type}};

    $ident{$name}{LINE}  = $line;
    $ident{$name}{TYPE}  = $type;
    $ident{$name}{NUM}   = $num;
    $ident{$name}{REG}   = "$type$num";
    $ident{$name}{VALUE} = "$type$num";

    $regs{$type}[$num]{LINE} = $line;
    $regs{$type}[$num]{NAME} = $name;

    push_source "var $types{$type} $name;";

    return 1;
  }
}


#
# declare_const()
#

sub declare_const
{
  my ($name, $type, $value) = @_;

#  printf(STDERR "jakoc: debug: Declaring constant '%s' of type '%s'...\n", $name, $type);

  if ($ident{$name}) {
    printf STDERR "jakoc: Redeclaration of identifier '%s' on line %d. Previous declaration on line %d.\n",
      $name, $line, $ident{$name}{LINE};
    return 0;
  } else {
    $ident{$name}{LINE}  = $line;
    $ident{$name}{TYPE}  = $type;
    $ident{$name}{NUM}   = undef;
    $ident{$name}{REG}   = undef;
    $ident{$name}{VALUE} = $value;

    my $type_name = $types{$type};

    confess "jakoc: Internal error: Constant declaration involves undefined type code!"
      unless defined $type;

    confess "jakoc: Internal error: Constant declaration involves undefined type name!"
      unless defined $type_name;

    confess "jakoc: Internal error: Constant declaration involves undefined constant name!"
      unless defined $name;

    confess "jakoc: Internal error: Constant declaration involves undefined value!"
      unless defined $value;

    push_source "const $type_name $name = $value;";

    return 1;
  }
}


#
# assign_var()
#

sub assign_var
{
  my ($name, $type, $value) = @_;

  #
  # Reject cases where LHS isn't a variable:
  #

  if (!$ident{$name}) {
    printf(STDERR "jakoc: Assignment to undefined variable '%s' on line %d.\n",
      $name, $line);
    return;
  }

  if (!defined $ident{$name}{REG}) {
    printf(STDERR "jakoc: Cannot assign to constant '%s' on line %d.\n", $name, $line);
    return;
  }

  #
  # Remember the source code:
  #

  push_source "$name = $value";

  #
  # Handle var-const (for manifest constants) assignments:
  #
  # int_var = 1;
  # num_var = 2.0;
  # str_var = "foo";
  #

  if ($ident{$name}{TYPE} eq $type) {
    emit_code('set', [$ident{$name}{VALUE}, $value]);
    return;
  }

  #
  # Catch incompatible assigns:
  #

  if ($type ne '*') {
    printf(STDERR "jakoc: Assignment of '%s' variable from '%s' value not allowed on line %d.\n", 
      $ident{$name}{TYPE}, $type, $line);
  }

  #
  # If what remains is not an identifier we've seen, we've got trouble:
  #

  if (!$ident{$value}) {
    printf(STDERR "jakoc: Assignment from undefined variable '%s' on line %d.\n",
      $value, $line);
  }

  #
  # Emit code if the types are the same:
  #

  if ($ident{$name}{TYPE} eq $ident{$value}{TYPE}) {
    emit_code('set', [$ident{$name}{VALUE}, $ident{$value}{VALUE}]);
    return;
  }

  #
  # Handle conversion cases:
  #

  if ($ident{$name}{TYPE} eq "N" and $ident{$value}{TYPE} eq "I") {
    emit_code('iton', ["$ident{$name}{VALUE}, $ident{$value}{VALUE}"]);
  } elsif ($ident{$name}{TYPE} eq "I" and $ident{$value}{TYPE} eq "N") {
    emit_code('ntoi', ["$ident{$name}{VALUE}, $ident{$value}{VALUE}"]);
  } else {
    printf(STDERR "jakoc: Cannot assign type '%s' to type '%s' on line %d.\n", 
      $ident{$value}{TYPE}, $ident{$name}{TYPE}, $line);
  }

  return;
}


#
# map_args()
#

sub map_args
{
  my (@args) = @_;
  my @result;

  foreach my $arg (@args) {
    die "map_args(): Undefined argument in array!\n" unless defined $arg;

    $arg =~ s/^\s+//;
    $arg =~ s/\s+$//;

    if ($ident{$arg}) {
      confess "jakoc: Internal compiler error: Unable to fetch value for identifier '$arg'!"
        unless defined $ident{$arg}{VALUE};
      push @result, $ident{$arg}{VALUE};
    } elsif ($arg =~ m/^"/) {
      push @result, $arg;
    } elsif (int_q($arg)) {
      push @result, $arg;
    } elsif (num_q($arg)) {
      push @result, $arg;
    } else {
      printf(STDERR "jakoc: Unrecognized argument '%s' on line %d.\n", $arg, $line);
      push @result, "<err>";
    }
  }

  return @result;
}


#
# void_func()
#

sub void_func
{
  my ($name, @args) = @_;

  push_source "$name(...);";

  if ($name eq 'print') {
    @args = map_args(@args);
    foreach my $arg (@args) {
      emit_code($name, [$arg]);
    }
  } elsif ($name eq 'time') {
    if ($ident{$name}{TYPE} =~ m/^[IN]$/) {
      emit_code($name, [$ident{$name}{VALUE}]);
    } else {
      printf(STDERR "jakoc: Function 'time' returns only 'num' or 'int'  on line %d.\n", $name, $line);
    }
  } elsif ($subs{$name}) {
    emit_code "set", [ "I31", "[ $name - @ - 3 ]" ];
    emit_code "jump", [ "I31" ];
  } else {
    printf(STDERR "jakoc: Call to unrecognized function '%s' on line %d.\n", $name, $line);
  }
}


#
# assign_func()
#

sub assign_func
{
  my ($dest, $name, @args) = @_;

  if ($assign_funcs{$name}) {
    push_source "$dest = $name(" . join(", ", @args) . ");";
    @args = map_args($dest, @args);
    emit_code($name, [@args]);
  } else {
    printf(STDERR "jakoc: Unrecognized function '%s' on line %d.\n", $name, $line);
  }
}


#
# begin_cond_block()
#

sub begin_cond_block
{
  my ($name, $type, $cond) = @_;

#  my $next   = $block_types{$type}{NEXT};
#  my $redo   = $block_types{$type}{REDO};
#  my $last   = $block_types{$type}{LAST};

  if ($cond =~ m/^(\S+)\s*(==|!=|<=|<|>=|>)\s*(.*)$/) {
    push_source "$name: $type ($1 $2 $3) {";

    push_label "${name}_" . uc $type;

    if ($type eq 'while') {
      push_label "${name}_NEXT";
    } elsif ($type eq 'if') {
      push_label "${name}_TEST";
    } else {
      die;
    }

    if ($type eq 'while') {
      op_comp($type, $2, map_args($1, $3), undef, "${name}_LAST");
    } elsif ($type eq 'if') {
      op_comp($type, $2, map_args($1, $3), undef, "${name}_ELSE");
    }

    push_label "${name}_REDO";
  } else {
    printf(STDERR "jakoc: Syntax error. Unrecognized condition in '%s' on line %d.\n", $type, $line);
  }
}


#
# begin_sub_block()
#

sub begin_sub_block
{
  my ($name) = @_;

  emit_code; # Flush anything pending.

  push_source "sub $name {";
  push_label "${name}_BEFORE";
  emit_code 'branch', [ "${name}_AFTER" ];

  push_label $name;
  push_label "${name}_ENTER";

  $subs{$name} = $line;
}


#
# begin_block()
#
# TODO: bare, until, unless, elsif
#

my %block_types = (
  'while'    => { PREFIX => "_W", NEXT => 'CONT', REDO => 'REDO', LAST => 'LAST' },
  'if'       => { PREFIX => "_I", NEXT => 'TEST', REDO => 'THEN', LAST => 'ELSE' },
  'sub'      => { PREFIX => "_S", NEXT => 'TEST', REDO => 'THEN', LAST => 'ELSE' }, # TODO: fix these
);

my %block_names = ( );

sub begin_block
{
  my ($name, $type, $cond) = @_;
  $block_count++;

  my $prefix;

  if (defined $name) {
    if ($block_names{$name}) {
      printf STDERR "jakoc: Loop named '%s' already defined at line %d (previously defined at line %d)!\n",
        $name, $line, $block_names{$name};
    }

    $prefix = $name;
  } else {
    $prefix = "$block_types{$type}{PREFIX}$block_count";
    $name   = $prefix;
  }

  $block_names{$name} = $line;

  if ($type eq 'if') {
    begin_cond_block($name, $type, $cond);
  } elsif ($type eq 'while') {
    begin_cond_block($name, $type, $cond);
  } elsif ($type eq 'sub') {
    begin_sub_block($name);
  } else {
    confess "jakoc: Internal error: Unknown block type '$type' in begin_block()!\n";
  }

  push @block_stack, { TYPE => $type, NEXT => $line, PREFIX => $prefix };
}


#
# end_block()
#
# TODO: else (and elsif?) blocks.
#

sub end_block
{
  my ($continue) = @_;

  unless (@block_stack) {
    printf(STDERR "jakoc: Syntax error. Closing brace without open block on line %d.\n", $line);
    return;
  }

  my $block  = pop @block_stack;
  my $prefix = $block->{PREFIX};

  if ($block->{TYPE} eq 'while') {
    if (defined $continue) {
      if (defined $block->{CONT}) {
        printf(STDERR "jakoc: Syntax error. No more than one continue block allowed on line %d.\n", $line);
      } else {
        $block->{CONT} = $line;
      }

      push_label "${prefix}_CONT";
      push_source "} continue {";
      push @block_stack, $block; # Push it back on for a minute...
    } else {
      push_source "}";
      push_label "${prefix}_CONT" unless defined $block->{CONT};
      emit_code('branch', ["${prefix}_NEXT"]);
      push_label "${prefix}_LAST";
    }
  } elsif ($block->{TYPE} eq 'if') {
    push_source "}";
    emit_code();
    push_label "${prefix}_ELSE";
  } elsif ($block->{TYPE} eq 'sub') {
    push_source "}";
    emit_code;
    push_label "${prefix}_LEAVE";
    emit_code "set", [ "I0", "I31" ];
    emit_code "set", [ "I31", 0 ];
    emit_code "sub", [ "I31", "I31", "I0" ];
    emit_code "inc", [ "I31", "[ ${prefix} - @ - 1 ]" ];
    emit_code "jump", [ "I31" ];
    push_label "${prefix}_AFTER";
    emit_code;
  } else {
    confess "jakoc: Internal compiler error. End of unknown block type " . $block->{TYPE} . "!";
  }
}


#
# do_loop_control()
#

sub do_loop_control
{
  my ($control_op, $loop_label) = @_;

  foreach (reverse @block_stack) {
    my $type   = $_->{TYPE};
    my $prefix = $_->{PREFIX};

    next unless $type eq 'while';
    next unless !defined($loop_label) or $prefix eq $loop_label;

    my $which = $block_types{$type}{uc $control_op};

    push_source "$control_op ${prefix}";

    if (defined $_->{CONT} and $control_op eq 'next') {
      $which = $block_types{$type}{NEXT};                   # Hard-coded to NEXT in continue { ... }
      emit_code('branch', ["${prefix}_$which"]);
    } else {
      emit_code('branch', ["${prefix}_$which"]);
    }

    return;
  }

  if (defined $loop_label) {
    printf STDERR "jakoc: No loop '%s' in loop control on line %d!\n", $loop_label, $line;
  } else {
    printf STDERR "jakoc: No loop active in loop control on line %d!\n", $line;
  }

  emit_code('err');
}


#
# do_add()
#

sub do_add
{
  my ($dest, $a, $b) = @_;

  push_source "$dest = $a + $b;";

  ($dest, $a, $b) = map_args($dest, $a, $b);

  if (int_or_num_q($a)) {
    if (int_or_num_q($b)) {
      my $temp = $a + $b;
      $temp .= ".0" if (num_q($a) or num_q($b)) and not $temp =~ m/\./;
      emit_code('set', [$dest, $temp]);
    } elsif (reg_q($b)) {
      if ($dest eq $b) {
        emit_code('inc', [$dest, $a]);
      } else {
        my $temp = int_q($a) ? 'I0' : 'N0';
        emit_code('set', [$temp, $a]);
        emit_code('add', [$dest, $temp, $b]);
      }
    } else {
      printf(STDERR "jakoc: Syntax error in addition on line %d!\n", $line);
    }
  } elsif (reg_q($a)) {
    if (int_or_num_q($b)) {
      if ($dest eq $a) {
        emit_code('inc', [$dest, $b]);
      } else {
        my $temp = int_q($b) ? 'I0' : 'N0';
        emit_code('set', [$temp, $b]);
        emit_code('add', [$dest, $a, $temp]);
      }
    } elsif (reg_q($b)) {
      emit_code('add', [$dest, $a, $b]);
    } else {
      printf(STDERR "jakoc: Syntax error in addition on line %d!\n", $line);
    }
  } else {
    printf(STDERR "jakoc: Syntax error in addition on line %d!\n", $line);
  }
}


#
# do_inc()
#

sub do_inc
{
  my ($dest, $amount) = @_;

  if (defined $amount) {
    push_source "$dest += $amount;";
    ($dest, $amount) = map_args($dest, $amount);
    emit_code('inc', [$dest, $amount]);
  } else {
    push_source "$dest++;";
    ($dest, $amount) = map_args($dest);
    emit_code('inc', [$dest]);
  }
}


#
# do_sub()
#

sub do_sub
{
  my ($dest, $a, $b) = @_;

  push_source "$dest = $a - $b;";

  ($dest, $a, $b) = map_args($dest, $a, $b);

  if (int_or_num_q($a)) {
    if (int_or_num_q($b)) {
      my $temp = $a - $b;
      $temp .= ".0" if (num_q($a) or num_q($b)) and not $temp =~ m/\./;
      emit_code('set', [$dest, $temp]);
    } elsif (reg_q($b)) {
      if ($dest eq $b) {
        emit_code('dec', [$dest, $a]);
      } else {
        my $temp = int_q($a) ? 'I0' : 'N0';
        emit_code('set', [$temp, $a]);
        emit_code('sub', [$dest, $temp, $b]);
      }
    } else {
      printf(STDERR "jakoc: Syntax error in subtraction on line %d!\n", $line);
    }
  } elsif (reg_q($a)) {
    if (int_or_num_q($b)) {
      if ($dest eq $a) {
        emit_code('dec', [$dest, $b]);
      } else {
        my $temp = int_q($b) ? 'I0' : 'N0';
        emit_code('set', [$temp, $b]);
        emit_code('sub', [$dest, $a, $temp]);
      }
    } elsif (reg_q($b)) {
      emit_code('sub', [$dest, $a, $b]);
    } else {
      printf(STDERR "jakoc: Syntax error in subtraction on line %d!\n", $line);
    }
  } else {
    printf(STDERR "jakoc: Syntax error in subtraction on line %d!\n", $line);
  }
}


#
# do_dec()
#

sub do_dec
{
  my ($dest, $amount) = @_;

  if (defined $amount) {
    push_source "$dest -= $amount;";
    ($dest, $amount) = map_args($dest, $amount);
    emit_code('dec', [$dest, $amount]);
  } else {
    push_source "$dest--;";
    ($dest, $amount) = map_args($dest);
    emit_code('dec', [$dest]);
  }
}


#
# do_mul()
#

sub do_mul
{
  my ($dest, $a, $b) = @_;

  push_source "$dest = $a * $b;";

  ($dest, $a, $b) = map_args($dest, $a, $b);

  if (int_or_num_q($a)) {
    if (int_or_num_q($b)) {
      my $temp = $a * $b;
      $temp .= ".0" if (num_q($a) or num_q($b)) and not $temp =~ m/\./;
      emit_code('set', [$dest, $temp]);
    } elsif (reg_q($b)) {
      my $temp = int_q($a) ? 'I0' : 'N0';
      emit_code('set', [$temp, $a]);
      emit_code('mul', [$dest, $temp, $b]);
    } else {
      printf(STDERR "jakoc: Syntax error in multiplication on line %d!\n", $line);
    }
  } elsif (reg_q($a)) {
    if (int_or_num_q($b)) {
      my $temp = int_q($b) ? 'I0' : 'N0';
      emit_code('set', [$temp, $b]);
      emit_code('mul', [$dest, $a, $temp]);
    } elsif (reg_q($b)) {
      emit_code('mul', [$dest, $a, $b]);
    } else {
      printf(STDERR "jakoc: Syntax error in multiplication on line %d!\n", $line);
    }
  } else {
    printf(STDERR "jakoc: Syntax error in multiplication on line %d!\n", $line);
  }
}


#
# do_div()
#

sub do_div
{
  my ($dest, $a, $b) = @_;

  push_source "$dest = $a / $b;";

  ($dest, $a, $b) = map_args($dest, $a, $b);

  if (int_or_num_q($a)) {
    if (int_or_num_q($b)) {
      my $temp = $a / $b;
      $temp .= ".0" if (num_q($a) or num_q($b)) and not $temp =~ m/\./;
      emit_code('set', [$dest, $temp]);
    } elsif (reg_q($b)) {
      my $temp = int_q($a) ? 'I0' : 'N0';
      emit_code('set', [$temp, $a]);
      emit_code('div', [$dest, $temp, $b]);
    } else {
      printf(STDERR "jakoc: Syntax error in division on line %d!\n", $line);
    }
  } elsif (reg_q($a)) {
    if (int_or_num_q($b)) {
      my $temp = int_q($b) ? 'I0' : 'N0';
      emit_code('set', [$temp, $b]);
      emit_code('div', [$dest, $a, $temp]);
    } elsif (reg_q($b)) {
      emit_code('div', [$dest, $a, $b]);
    } else {
      printf(STDERR "jakoc: Syntax error in division on line %d!\n", $line);
    }
  } else {
    printf(STDERR "jakoc: Syntax error in division on line %d!\n", $line);
  }
}


#
# do_mod()
#
# a =  b % c
# a =  b % 4
# a = 17 % c
# a = 17 % 4
#

sub do_mod
{
  my ($dest, $a, $b) = @_;

  push_source "$dest = $a % $b;";

  ($dest, $a, $b) = map_args($dest, $a, $b);

  if (int_q($a)) {
    if (int_q($b)) {
      emit_code('set', [$dest, $a % $b]);
    } elsif (reg_q($b)) {
      my $temp = 'I0';
      emit_code('set', [$temp, $a]);
      emit_code('mod', [$dest, $temp, $b]);
    } else {
      printf(STDERR "jakoc: Syntax error in modulo on line %d!\n", $line);
    }
  } elsif (reg_q($a)) {
    if (int_q($b)) {
      my $temp = 'I0';
      emit_code('set', [$temp, $b]);
      emit_code('mod', [$dest, $a, $temp]);
    } elsif (reg_q($b)) {
      emit_code('mod', [$dest, $a, $b]);
    } else {
      printf(STDERR "jakoc: Syntax error in modulo on line %d!\n", $line);
    }
  } else {
    printf(STDERR "jakoc: Syntax error in modulo on line %d!\n", $line);
  }
}


#
# do_shift()
#

sub do_shift
{
  my ($dir, $dest, $a, $amount) = map_args(@_);
  emit_code("sh$dir", [$dest, $a, $amount]);
}


#
# interpolate_string()
#
# Converts a single string argument:
#
#     "Foo $a ${b}ar\n"
#
# to multiple arguments:
#
#     "Foo ", a, " ", b, "ar ", b, "\n"
#
# to effect string interpolation.
#

sub interpolate_string
{
  my ($string) = @_;

  return $string unless $string =~ m/[^\\]\$/;

  $string =~ s/([^\\])\$((([A-Za-z][A-Za-z0-9_]*)\b)|({[A-Za-z][A-Za-z0-9_]*}))/$1", $2, "/g;

  return parse_args($string);
}


#
# parse_args()
#

sub parse_args
{
  my ($args) = @_;
  my @args;

  while ($args ne '') {
    $args =~ s/^\s+//;

    if ($args =~ m/^(\"[^\\\"]*(?:\\.[^\\\"]*)*\")\s*(,\s*(.*))?$/) {
      $args = $3 || '';
      push @args, interpolate_string($1);
    } elsif ($args =~ m/^([^,]+)\s*(,\s*(.*))?$/) {
      push @args, $1;
      $args = $3 || '';
    } else {
      printf(STDERR "jakoc: Syntax error. Cannot parse argument list '$args' on line %d.\n", $line);
      return ();
    }
  }

  return @args;
}


#
# MAIN PROGRAM:
#

print "###############################################################################\n";
print "# This Parrot assembler file was produced by the Jako compiler.               #\n";
print "# Initial comments from the source code are reproduced below.                 #\n";
print "###############################################################################\n";
print "\n";

my $code_lines = 0;

while(<>) {
  $line++;

  if (m/^\s*#/) { print unless $code_lines; next; } # Pass initial comment-only lines through intact.
  if (m/^\s*$/) { print unless $code_lines; next; } # Pass initial whitespace-only lines through intact.

  chomp;                         # Trim trailing newline
  s/^\s*//;                      # Trim leading whitespace
  s/\s*$//;                      # Trim trailing whitespace
  last if (/^__END__$/);         # Done after __END__ token

  $code_lines++;

  s/\s*;\s*$//; # Remove trailing semicolons

  #
  # Labels:
  #
  # NOTE: While we have this simple parser, we only allow the labels on
  # lines by themselves (aside from loop labels).
  #

  if (m|^([A-Za-z][A-Za-z0-9_]*)\s*:$|) {
    push_label($1);
    next;
  }

  #
  # Variable declarations:
  #
  # var int      foo;
  # var integer  foo;
  # var int      foo = 5;
  # var integer  foo = 5;
  #
  # var num      bar;
  # var number   bar;
  # var num      bar = 3.14;
  # var number   bar = 3.14;
  #
  # var str      splee;
  # var string   splee;
  # var str      splee = "Howdy";
  # var string   splee = "Howdy";
  #

  if ((m/^var\s+(i)nt(eger)?\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(-?\d+))?$/) ||
      (m/^var\s+(n)um(ber)?\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(-?\d+(\.\d+)))?$/) ||
      (m/^var\s+(s)tr(ing)?\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(\"[^\\\"]*(?:\\.[^\\\"]*)*\"))?$/)
  ) { 
    declare_var($3, uc($1));
    assign_var($3, uc($1), $5) if defined $5;
    next;
  }

  #
  # Variable declarations:
  #
  # var int      foo, bar;
  # var integer  foo, bar;
  # var int      foo, bar = 5;
  # var integer  foo, bar = 5;
  #
  # var num      bar, splee;
  # var number   bar, splee;
  # var num      bar, splee = 3.14;
  # var number   bar, splee = 3.14;
  #
  # var str      splee, quux;
  # var string   splee, quux;
  # var str      splee, quux = "Howdy";
  # var string   splee, quux = "Howdy";
  #

  if ((m/^var\s+(i)nt(eger)?\s+(([A-Za-z][A-Za-z0-9_]*)(\s*,\s*[A-Za-z][A-Za-z0-9_]*)+)(\s*=\s*(-?\d+))?$/) ||
      (m/^var\s+(n)um(ber)?\s+(([A-Za-z][A-Za-z0-9_]*)(\s*,\s*[A-Za-z][A-Za-z0-9_]*)+)(\s*=\s*(-?\d+(\.\d+)))?$/) ||
      (m/^var\s+(s)tr(ing)?\s+(([A-Za-z][A-Za-z0-9_]*)(\s*,\s*[A-Za-z][A-Za-z0-9_]*)+)(\s*=\s*(\"[^\\\"]*(?:\\.[^\\\"]*)*\"))?$/)

#  if ((m/^var\s+(i)nt(eger)?\s+(($t_ident)(\s*,$t_ident*)+)(\s*=\s*($t_integer))?$/) ||
#      (m/^var\s+(n)um(ber)?\s+(($t_ident)(\s*,$t_ident*)+)(\s*=\s*($t_number))?$/) ||
#      (m/^var\s+(s)tr(ing)?\s+(($t_ident)(\s*,$t_ident*)+)(\s*=\s*($t_string))?$/)

  ) {
    foreach my $var (split(/\s*,\s*/, $3)) {
      declare_var($var, uc($1));
      assign_var($var, uc($1), $7) if defined $7;
    }
    next;
  }

  #
  # Variable declarations:
  #
  # var poly     quux;
  # var polytype quux;
  #

  if (m/^var\s+poly(type)?\s+([A-Za-z][A-Za-z0-9_]*)$/) {
    declare_var($2, 'P');
    next;
  }

  #
  # Constant declarations:
  #
  # const int      foo = 5;
  # const integer  foo = 5;
  #
  # const num      bar = 3.14;
  # const number   bar = 3.14;
  #
  # const str      splee = "Howdy";
  # const string   splee = "Howdy";
  #

  if ((m/^const\s+(i)nt(eger)?\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(-?\d+))$/) ||
      (m/^const\s+(n)um(ber)?\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(-?\d+(\.\d+)))$/) ||
      (m/^const\s+(s)tr(ing)?\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(\"[^\\\"]*(?:\\.[^\\\"]*)*\"))$/)) { 
    declare_const($3, uc($1), $5);
    next;
  }

  #
  # Variable Assignments:
  #
  # a = 5;
  # a = 3.14;
  # a = "Howdy";
  # a = b;
  #
 
  if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*(-?\d+)$/) {
    assign_var($1, 'I', $2);
    next;
  }
 
  if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*(-?\d+\.\d+)$/) {
    assign_var($1, 'N', $2);
    next;
  }

  if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*(\"[^\\\"]*(?:\\.[^\\\"]*)*\")$/) {
    assign_var($1, 'S', $2);
    next;
  }

  if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*([A-Za-z][A-Za-z0-9_]*)$/) {
    assign_var($1, '*', $2);
    next;
  }

  #
  # Multiple Variable Assignments:
  #
  # a = b = 5;
  # a = b = 3.14;
  # a = b = "Howdy";
  # a = b = c;
  #
 
  if (m/^(([A-Za-z][A-Za-z0-9_]*)(\s*=\s*[A-Za-z][A-Za-z0-9_]*)+)\s*=\s*(-?\d+)$/) {
    foreach my $var (split(/\s*=\s*/, $1)) {
      assign_var($var, 'I', $4);
    }
    next;
  }
 
  if (m/^(([A-Za-z][A-Za-z0-9_]*)(\s*=\s*[A-Za-z][A-Za-z0-9_]*)+)\s*=\s*(-?\d+\.\d+)$/) {
    foreach my $var (split(/\s*=\s*/, $1)) {
      assign_var($var, 'N', $4);
    }
    next;
  }

  if (m/^(([A-Za-z][A-Za-z0-9_]*)(\s*=\s*[A-Za-z][A-Za-z0-9_]*)+)\s*=\s*(\"[^\\\"]*(?:\\.[^\\\"]*)*\")$/) {
    foreach my $var (split(/\s*=\s*/, $1)) {
      assign_var($var, 'S', $4);
    }
    next;
  }

  if (m/^(([A-Za-z][A-Za-z0-9_]*)(\s*=\s*[A-Za-z][A-Za-z0-9_]*)+)\s*=\s*([A-Za-z][A-Za-z0-9_]*)$/) {
    foreach my $var (split(/\s*=\s*/, $1)) {
      assign_var($var, '*', $4);
    }
    next;
  }

  #
  # Function Calls:
  #
  #     foo(...);
  # a = foo(...);
  #
 
  if (m/^([A-Za-z][A-Za-z0-9_]*)\((.*)\)$/) {
    void_func($1, parse_args($2));
    next;
  }

  if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*([A-Za-z][A-Za-z0-9_]*)\((.*)\)$/) {
    assign_func($1, $2, split(/\s*,\s*/, $3));
    next;
  }

  #
  # Conditionals:
  #
  #   if     (...) {
  #   unless (...) {
  #
  # } elsif  (...) {
  #

  if (m/^(if|unless)\s*\(\s*(.*)\s*\)\s*{$/) {
    begin_block(undef, $1, $2);
    next;
  }

  if (m/^}\s*(elsif)\s*\(\s*(.*)\s*\)\s*{$/) {
    begin_block(undef, $1, $2);
    # TODO
    next;
  }

  #
  # Loops:
  #
  # LABEL: until (...) {
  #        until (...) {
  #
  # LABEL: while (...) {
  #        while (...) {
  #

  if (m/^(([A-Za-z][A-Za-z0-9_]*)\s*:\s*)?(until|while)\s*\(\s*(.*)\s*\)\s*{$/) {
    begin_block($2, $3, $4);
    next;
  }

  #
  # Bare Blocks:
  #
  # LABEL: {
  #
  # {
  #

  if (m/^(([A-Za-z][A-Za-z0-9_]*)\s*:\s*)?{$/) {
    begin_block($2, 'bare', undef);
    next;
  }

  #
  # Subroutines:
  #
  # sub NAME {
  #

  if (m/^sub\s+([A-Za-z][A-Za-z0-9_]*)\s*{$/) {
    begin_block($1, 'sub', undef);
    next;
  }

  #
  # Block Termination:
  #
  # }
  # } continue {
  # } else {
  #

  if (m/^}(\s*(continue|else)\s*{)?$/) {
    end_block($2);
    next;
  }

  #
  # Loop Control Statements:
  #
  # next
  # next LOOPNAME
  #
  # last
  # last LOOPNAME
  #
  # redo
  # redo LOOPNAME
  #
  # NOTE: A LOOPNAME is just the label used when introducing a LOOP.
  #

  if (m/^(next|last|redo)(\s+([A-Za-z][A-Za-z0-9_]*))?$/) {
    do_loop_control($1, $3);
    next;
  }

  #
  # Goto Statements:
  #
  # goto LABEL
  # goto LABEL if (...)
  # goto LABEL unless (...)
  #

  if (m/^goto\s+([A-Za-z][A-Za-z0-9_]*)(\s+(if|unless)\s+\((\S+)\s*(==|!=|<=|<|>=|>)\s*(\S+)\s*\))?$/) {
    if (defined $4) {
      if ($3 eq 'if') {
        push_source "goto $1 if ($4 $5 $6);";
        op_comp 'if', $5, map_args($4, $6), $1, undef;
      } else {
        push_source "goto $1 unless ($4 $5 $6);";
        op_comp 'unless', $5, map_args($4, $6), undef, $1;
      }
    } else {
      push_source "goto $1;";
      emit_code('branch', [$1]);
    }
    next;
  }

  #
  # Additive Operators:
  #
  # a = b    + c;     # add_[in]
  # a = b    + 5;     # add_i_ic (psuedo-op)
  # a = b    + 3.14;  # add_n_nc (psuedo-op)
  # a = 5    + b;     # add_ic_i (pseudo-op)
  # a = 3.14 + b;     # add_nc_n (pseudo-op)
  # a = 5    + 2;     # set_i (COMPILE-TIME EVALUATION)
  # a = 3.14 + 0.16;  # set_n (COMPILE-TIME EVALUATION)
  # a = 5    + 0.16;  # set_n (COMPILE-TIME EVALUATION)
  # a = 3.14 + 2;     # set_n (COMPILE-TIME EVALUATION)
  #
  # a += b;           # add_[in]
  # a += 5;           # add_i_ic (pseudo-op)
  # a += 3.14;        # add_n_nc (pseudo-op)
  #
  # a++;              # inc_[in]
  #

  if (m!^([A-Za-z][A-Za-z0-9_]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))\s*[+]\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))$!) {
    #
    # Regexp Captures:
    #
    #  1. LHS sum (variable name)
    #  2. RHS left addend
    #  3. RHS left addend (variable name)
    #  4. RHS left addend (number)
    #  5. RHS left addend (number's decimal places) -- used for grouping, not capture
    #  6. RHS right addend
    #  7. RHS right addend (variable name)
    #  8. RHS right addend (number)
    #  9. RHS right addend (number's decimal places) -- used for grouping, not capture
    #

    if (defined $3 or defined $7) {
      do_add($1, $2, $6);
    } elsif (defined $4 and defined $8) {
      assign_var($1, (defined $5 or defined $9 ? 'N' : 'I'), $4 + $8);
    } else {
      printf(STDERR "jakoc: Syntax error in addition on line %d: '%s'\n", $line, $_);
    }
    next;
  }

  if (m!^([A-Za-z][A-Za-z0-9_]*)\s*[+]=\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))$!) {
    #
    # Regexp Captures:
    #
    #  1. LHS sum (variable name)
    #  2. RHS incremend
    #  3. RHS incremend (variable name)
    #  4. RHS incremend (number)
    #  5. RHS incremend (number's decimal places) -- used for grouping, not capture
    #

    if (defined $3) {
      do_add($1, $1, $2);
    } else {
      do_inc($1, $2);
    }
    next;
  }

  if (m/^([A-Za-z][A-Za-z0-9_]*)\s*[+][+]$/) {
    do_inc($1);
    next;
  }

  #
  # Subtractive Operators:
  #
  # a = b    - c;     # sub_[in]
  # a = b    - 5;     # sub_i_ic (pseudo-op)
  # a = b    - 3.14;  # sub_n_nc (pseudo-op)
  # a = 5    - b;     # sub_ic_i (pseudo-op)
  # a = 3.14 - b;     # sub_nc_n (pseudo-op)
  # a = 5    - 2;     # set_i (COMPILE-TIME EVALUATION)
  # a = 3.14 - 0.16;  # set_n (COMPILE-TIME EVALUATION)
  # a = 5    - 0.16;  # set_n (COMPILE-TIME EVALUATION)
  # a = 3.14 - 2;     # set_n (COMPILE-TIME EVALUATION)
  #
  # a -= b;           # dec_{i_i,n_n} (pseudo-op)
  # a -= 5;           # sub_i_ic (pseudo-op)
  # a -= 3.14;        # sub_n_nc (pseudo-op)
  #
  # a--;              # dec_[in]
  #

  if (m!^([A-Za-z][A-Za-z0-9_]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))\s*[-]\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))$!) {
    #
    # Regexp Captures:
    #
    #  1. LHS difference (variable name)
    #  2. RHS minuend
    #  3. RHS minuend (variable name)
    #  4. RHS minuend (number)
    #  5. RHS minuend (number's decimal places) -- used for grouping, not capture
    #  6. RHS subtrahend
    #  7. RHS subtrahend (variable name)
    #  8. RHS subtrahend (number)
    #  9. RHS subtrahend (number's decimal places) -- used for grouping, not capture
    #

    if (defined $3 or defined $7) {
      do_sub($1, $2, $6);
    } elsif (defined $4 and defined $8) {
      assign_var($1, (defined $5 or defined $9 ? 'N' : 'I'), $4 - $8);
    } else {
      printf(STDERR "jakoc: Syntax error in subtraction on line %d: '%s'\n", $line, $_);
    }
    next;
  }

  if (m!^([A-Za-z][A-Za-z0-9_]*)\s*[-]=\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))$!) {
    if (defined $3) {
      do_sub($1, $1, $2);
    } else {
      do_dec($1, $2);
    }
    next;
  }

  if (m!^([A-Za-z][A-Za-z0-9_]*)\s*[-][-]$!) {
    do_dec($1);
    next;
  }

  #
  # Multiplicative Operators:
  #
  # a = b    * c;     # mul_[in]
  # a = b    * 5;     # mul_i_ic (psuedo-op)
  # a = b    * 3.14;  # mul_n_nc (psuedo-op)
  # a = 5    * b;     # mul_ic_i (pseudo-op)
  # a = 3.14 * b;     # mul_nc_n (pseudo-op)
  # a = 5    * 2;     # set_i (COMPILE-TIME EVALUATION)
  # a = 3.14 * 0.16;  # set_n (COMPILE-TIME EVALUATION)
  # a = 5    * 0.16;  # set_n (COMPILE-TIME EVALUATION)
  # a = 3.14 * 2;     # set_n (COMPILE-TIME EVALUATION)
  #
  # a *= b;           # mul_[in]
  # a *= 5;           # mul_i_ic (pseudo-op)
  # a *= 3.14;        # mul_n_nc (pseudo-op)
  #

  if (m!^([A-Za-z][A-Za-z0-9_]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))\s*[*]\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))$!) {
    #
    # Regexp Captures:
    #
    #  1. LHS product (variable name)
    #  2. RHS multiplicand
    #  3. RHS multiplicand (variable name)
    #  4. RHS multiplicand (number)
    #  5. RHS multiplicand (number's decimal places) -- used for grouping, not capture
    #  6. RHS multiplier
    #  7. RHS multiplier (variable name)
    #  8. RHS multiplier (number)
    #  9. RHS multiplier (number's decimal places) -- used for grouping, not capture
    #

    if (defined $3 or defined $7) {
      do_mul($1, $2, $6);
    } elsif (defined $4 and defined $8) {
      assign_var($1, (defined $5 or defined $9 ? 'N' : 'I'), $4 * $8);
    } else {
      printf(STDERR "jakoc: Syntax error in multiplication on line %d: '%s'\n", $line, $_);
    }
    next;
  }

  if (m!^([A-Za-z][A-Za-z0-9_]*)\s*[*]=\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))$!) {
    do_mul($1, $1, $2);
    next;
  }

  #
  # Divisive Operators:
  #
  # a = b    / c;     # div_[in]
  # a = b    / 5;     # div_i_ic (psuedo-op)
  # a = b    / 3.14;  # div_n_nc (psuedo-op)
  # a = 5    / b;     # div_ic_i (pseudo-op)
  # a = 3.14 / b;     # div_nc_n (pseudo-op)
  # a = 5    / 2;     # set_i (COMPILE-TIME EVALUATION)
  # a = 3.14 / 0.16;  # set_n (COMPILE-TIME EVALUATION)
  # a = 5    / 0.16;  # set_n (COMPILE-TIME EVALUATION)
  # a = 3.14 / 2;     # set_n (COMPILE-TIME EVALUATION)
  #
  # a /= b;           # div_[in]
  # a /= 5;           # div_i_ic (pseudo-op)
  # a /= 3.14;        # div_n_nc (pseudo-op)
  #

  if (m!^([A-Za-z][A-Za-z0-9_]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))\s*[/]\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))$!) {
    #
    # Regexp Captures:
    #
    #  1. LHS quotient (variable name)
    #  2. RHS dividend
    #  3. RHS dividend (variable name)
    #  4. RHS dividend (number)
    #  5. RHS dividend (number's decimal places) -- used for grouping, not capture
    #  6. RHS divisor
    #  7. RHS divisor (variable name)
    #  8. RHS divisor (number)
    #  9. RHS divisor (number's decimal places) -- used for grouping, not capture
    #

    push_source "$1 = $2 / $6";

    if (defined $3 or defined $7) {
      do_div($1, $2, $6);
    } elsif (defined $4 and defined $8) {
      assign_var($1, (defined $5 or defined $9 ? 'N' : 'I'), $4 / $8);
    } else {
      printf(STDERR "jakoc: Syntax error in division on line %d: '%s'\n", $line, $_);
    }

    next;
  }

  if (m!^([A-Za-z][A-Za-z0-9_]*)\s*[\/]=\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+(\.\d+)?))$!) {
    do_div($1, $1, $2);
    next;
  }

  #
  # Modular Arithmetic Operators:
  #
  # NOTE: No decimal numbers.
  #
  # a = b % c;
  # a = b % 4;
  # a = 9 % b;
  # a = 9 % 4;
  #
  # a %= b;
  # a %= 4;
  #
  # TODO: Numbers in mod (follow Calendrical calculations definition? Knuth definition?)
  # TODO: Does Parrot follow C or mathematical definition?
  #

  if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+))\s*[%]\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+))$/) {
    push_source "$1 = $2 \% $5";
    do_mod($1, $2, $5);
    next;
  }

  if (m/^([A-Za-z][A-Za-z0-9_]*)\s*[%]=\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+))$/) {
    push_source "$1 \%= $2";
    do_mod($1, $1, $2);
    next;
  }

  #
  # Bitwise Operators:
  #
  # a = b << 4;
  # a <<= 4;
  #
  # TODO: Can't really support shift amount as arg until sh[lr]_i_i ops are implemented.
  #
  # TODO: Should we really be allowing the shift contant to be negative?
  #

  if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*([A-Za-z][A-Za-z0-9_]*)\s*(<<|>>)\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+))$/) {
    do_shift($3 eq '<<' ? 'l' : 'r', $1, $2, $4);
    next;
  }

  if (m/^([A-Za-z][A-Za-z0-9_]*)\s*((<<|>>)=)\s*(([A-Za-z][A-Za-z0-9_]*)|(-?\d+))$/) {
    do_shift($4 eq '<<' ? 'l' : 'r', $1, $2, $5);
    next;
  }

  #
  # Miscellany:
  #

  if (m/^end$/) {
    emit_code('end');
    next;
  }

  print STDERR "jakoc: Syntax error (unparsable line) on line $line: '$_'.\n";
}

emit_code('end') unless $last_op eq 'end';

exit 0;

#
# End of file.
#
