#! /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.14 2001/12/05 19:38:27 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 => [ { USE => 'temp' } ], # $regs{I}[0] reserved for int  temporaries
  N => [ { USE => 'temp' } ], # $regs{N}[0] reserved for num  temporaries
  P => [ { USE => 'temp' } ], # $regs{P}[0] reserved for poly temporaries
  S => [ { USE => 'temp' } ], # $regs{S}[0] reserved for str  temporaries
);

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


###############################################################################
###############################################################################
##
## The Block Stack
##
##   $block_count         The total number of blocks begun (used for labels)
##   @block_stack         The stack of active blocks. We keep a block on the
##                          stack for the file scope.
##
## NOTE: Do NOT access the block stack directly. Access it via routines in
## this section of code.
##
###############################################################################
###############################################################################


my $block_count = 0;

my @block_stack = ( {
    TYPE   => 'file',
    LINE   => 0,
    IDENT  => { },
});


#
# block_depth()
#
# Block depth zero is when the only block on the block stack is the file
# scope block. Therefore, we return one less than the number of blocks on
# the stack.
#

sub block_depth
{
  return scalar(@block_stack - 1);
}


#
# top_block()
#
# Returns the block on the top of the block stack.
#

sub top_block
{
  return  $block_stack[-1];
}


#
# push_block()
#
# Push a block on the top of the block stack.
#

sub push_block
{
  push @block_stack, shift;
}


#
# pop_block()
#
# Pop the top block off the block stack and return it. Bounds checks the block
# stack to make sure we don't pop off the file scope block.
#

sub pop_block
{
  confess "jakoc: Internal error! Attempt to pop file-scope block off block stack!"
    if @block_stack == 1;

  return pop @block_stack;
}


#
# find_ident()
#
# Scans through the block stack, from the top down, looking for the identifier.
# If it is found, returns a hashref containing the number of levels away the
# identifier is declared and the definition of the identifier.
#

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

  my $count = 0;

  foreach my $block (reverse @block_stack) {
    return { LEVELS => $count, IDENT => $block->{IDENT}{$name} }
      if exists $block->{IDENT}{$name};
    $count++;
  }

  return undef;
}


#
# find_block()
#
# Scans through the block stack, from the top down, looking for a block of
# the appropriate type (and, if label is given, with a matching label. If
# it is found, returns a hashref containing the number of levels away the
# block was found and the block info hashref. If it is not found, then
# undef is returned.
#

sub find_block
{
  my ($type, $label) = @_;

  my $count = 0;

  foreach my $block (reverse @block_stack) {
    next unless $block->{TYPE} eq $type;
    next unless !defined($label) or $block->{PREFIX} eq $label;
 
    return { LEVELS => $count, BLOCK => $block };
  }

  return undef;
}


###############################################################################
###############################################################################
##
## Miscellany
##
###############################################################################
###############################################################################

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:
#
# NOTE: These are not in use right now.
#

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+};


###############################################################################
###############################################################################
##
## Assembly Code Output
##
###############################################################################
###############################################################################


#
# 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 block_depth();
  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";
}


###############################################################################
###############################################################################
##
## Typing Predicates
##
## These are used throughout the code to check the type of an argument.
##
###############################################################################
###############################################################################

#
# 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+)?$/;
}


#
# str_q()
#

sub str_q
{
  my ($value) = @_;
  return $value =~ m/^"/;
}



#
# 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+$/;
}


###############################################################################
###############################################################################
##
## Operation Support
##
###############################################################################
###############################################################################

#
# 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);
}



###############################################################################
###############################################################################
##
## Identifier Declarations
##
###############################################################################
###############################################################################


#
# declare_var()
#
# Assign a register to the identifier within the scope of the current block.
#

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

  #
  # Check for a few bad conditions.
  #
  # NOTE: These are compiler internal consistency checks. They really should not be
  # triggered in normal operation, even with bad source code as input.
  #

  my $type_name = $types{$type};

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

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

  confess "jakoc: Internal error: Variable declaration involves undefined variable name!"
    unless defined $ident;

  #
  # Lookup the identifier:
  #
  # NOTE: This lookup doesn't give the info itself, but rather a hashref with
  # the LEVELS away the definition was found, and IDENT with the actual info
  # about the identifier.
  #

  my $ident_info = find_ident($ident);

  #
  # If the identifier is already defined at this lexical scope, we want to complain
  # about the redefinition. Otherwise, we assume the programmer wanted to shadow the
  # previous definition.
  #

  if (defined $ident_info and $ident_info->{LEVELS} == 0) {
    printf STDERR "jakoc: Redeclaration of identifier '%s' on line %d. Previous declaration on line %d.\n",
      $ident, $line, $ident_info->{IDENT}{LINE};
    return 0;
  }

  #
  # Now that we've decided to actually declare the variable, we will place its
  # definition into the block at the top of the block stack. First, we assign
  # it a register number, then we fill in the IDENT entry within the block,
  # and then we link the register to the identifier and the block.
  #

  my $block = top_block();

  my $reg_num = scalar @{$regs{$type}};

  $block->{IDENT}{$ident}{LINE}  = $line;
  $block->{IDENT}{$ident}{TYPE}  = $type;
  $block->{IDENT}{$ident}{NUM}   = $reg_num;
  $block->{IDENT}{$ident}{REG}   = "$type$reg_num";
  $block->{IDENT}{$ident}{VALUE} = "$type$reg_num";

  $regs{$type}[$reg_num]{LINE}  = $line;
  $regs{$type}[$reg_num]{NAME}  = $ident;
  $regs{$type}[$reg_num]{BLOCK} = $block;

  #
  # Push the source comment about the variable declaration.
  #

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

  return 1;
}


#
# declare_const()
#

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

  #
  # Check for a few bad conditions.
  #
  # NOTE: These are compiler internal consistency checks. They really should not be
  # triggered in normal operation, even with bad source code as input.
  #

  my $type_name = $types{$type};

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

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

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

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

  #
  # Lookup the identifier:
  #
  # NOTE: This lookup doesn't give the info itself, but rather a hashref with
  # the LEVELS away the definition was found, and IDENT with the actual info
  # about the identifier.
  #

  my $ident_info = find_ident($ident);

  #
  # If the identifier is already defined at this lexical scope, we want to complain
  # about the redefinition. Otherwise, we assume the programmer wanted to shadow the
  # previous definition.
  #

  if (defined $ident_info and $ident_info->{LEVELS} == 0) {
    printf STDERR "jakoc: Redeclaration of identifier '%s' on line %d. Previous declaration on line %d.\n",
      $ident, $line, $ident_info->{IDENT}{LINE};
    return 0;
  }

  #
  # Now that we've decided to actually declare the constant, we will place its
  # definition into the block at the top of the block stack. We fill in the
  # IDENT entry within the block.
  #

  my $block = top_block();

  $block->{IDENT}{$ident}{LINE}  = $line;
  $block->{IDENT}{$ident}{TYPE}  = $type;
  $block->{IDENT}{$ident}{NUM}   = undef;
  $block->{IDENT}{$ident}{REG}   = undef;
  $block->{IDENT}{$ident}{VALUE} = $value;

  #
  # Push the source comment about the constant definition.
  #

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

  return 1;
}


###############################################################################
###############################################################################
##
## Variable Assignments
##
###############################################################################
###############################################################################


#
# assign_var()
#

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

  #
  # Lookup the identifier:
  #
  # NOTE: This lookup doesn't give the info itself, but rather a hashref with
  # the LEVELS away the definition was found, and IDENT with the actual info
  # about the identifier.
  #

  my $ident_info = find_ident($ident);

  #
  # Reject cases where LHS isn't a variable (either it is undeclared or a constant):
  #

  unless (defined $ident_info) {
    printf(STDERR "jakoc: Assignment to undeclared variable '%s' on line %d.\n",
      $ident, $line);
    return;
  }

  $ident_info = $ident_info->{IDENT};

  #
  # Now that we've confirmed we could find the identifier, we make sure it is
  # bound to a variable, not a constant.
  #

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

  #
  # Remember the source code:
  #

  push_source "$ident = $value";

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

  if ($ident_info->{TYPE} eq $type) {
    emit_code('set', [$ident_info->{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_info->{TYPE}, $type, $line);
  }

  #
  # If what remains is not an identifier we've seen, we've got trouble:
  #
  # NOTE: This lookup doesn't give the info itself, but rather a hashref with
  # the LEVELS away the definition was found, and IDENT with the actual info
  # about the identifier.
  #

  my $value_ident_info = find_ident($value);

  if (! defined $value_ident_info) {
    printf(STDERR "jakoc: Assignment from undeclared identifier  '%s' on line %d.\n",
      $value, $line);
  }

  $value_ident_info = $value_ident_info->{IDENT};

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

  if ($ident_info->{TYPE} eq $value_ident_info->{TYPE}) {
    emit_code('set', [$ident_info->{VALUE}, $value_ident_info->{VALUE}]);
    return;
  }

  #
  # Handle conversion cases:
  #

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

  return;
}


###############################################################################
###############################################################################
##
## Argument Handling
##
###############################################################################
###############################################################################


#
# map_args()
#

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

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

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

    #
    # Attempt to find the argument as an identifier.
    #
    # NOTE: This lookup doesn't give the info itself, but rather a hashref with
    # the LEVELS away the definition was found, and IDENT with the actual info
    # about the identifier.
    #
    # TODO: This isn't the most efficient way to do this. We really should do
    # some pattern matches first, and *then* the lookup.
    #

    my $arg_ident_info = find_ident($arg);

    if (defined $arg_ident_info) {
      $arg_ident_info = $arg_ident_info->{IDENT};

      confess "jakoc: Internal compiler error: Unable to fetch value for identifier '$arg'!"
        unless defined $arg_ident_info->{VALUE};
      push @result, $arg_ident_info->{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;
}


###############################################################################
###############################################################################
##
## Function Calls
##
###############################################################################
###############################################################################


#
# void_func()
#

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

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

  (@args) = map_args(@args);

  if ($name eq 'print') {
    foreach my $arg (@args) {
      emit_code('print', [$arg]);
    }
  } elsif ($name eq 'sleep') {
    emit_code('sleep', [ shift @args ]); # TODO: Really need to complain if > 1 arg.
  } elsif (exists $subs{$name}) {
    #
    # First, we make sure everything is in order for the call:
    #

    printf(STDERR "jakoc: Call to non-void function %s in void context on line %d!\n", $name, $line)
      if defined $subs{$name}{RETURN};

    #
    # Now, we have to push (save) the arguments onto the stack in reverse
    # order. That way they can be pulled off by the subroutine in declaration
    # order, which will be convenient later for handling variable argument
    # subroutines.
    #
    # Arguments that are already in registers are easy. Constant arguments
    # have to be placed in the appropriate zero (temporary) register and then
    # saved.
    #

    foreach my $arg (reverse @args) {
      if (reg_q($arg)) {
        emit_code('save', [ $arg ]);
      } elsif (int_q($arg)) {
        emit_code('save', [ $arg ]);
      } elsif (num_q($arg)) {
        emit_code('save', [ $arg ]);
      } elsif (str_q($arg)) {
        emit_code('save', [ $arg ]);
      } else {
        confess "jakoc: Internal error. Unrecognized argument '$arg' when preparing call to subroutine '$name'!";
      }
    }

    emit_code 'save', [  scalar(@args) ]; # Push the arg count.

    emit_code "bsr", [ $name ];

    emit_code 'restore', [ 'I0' ]; # Pop off the result count.
  } else {
    printf(STDERR "jakoc: Call to unrecognized void function '%s' on line %d (Not in {%s}).\n",
      $name, $line, join(", ", sort keys %subs));
  }
}


#
# assign_func()
#

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

  push_source "$dest = $name(" . join(", ", @args) . ");";

  ($dest, @args) = map_args($dest, @args);

  if ($assign_funcs{$name}) {
    emit_code($name, [$dest, @args]);
  } elsif (exists $subs{$name}) {
    #
    # First, we make sure everything is in order for the call:
    #

    printf(STDERR "jakoc: Call to void function %s in non-void context on line %d!\n", $name, $line)
      unless defined $subs{$name}{RETURN};

    printf(STDERR "jakoc: Type mismatch in destination type and call to %s on line %d!\n", $name, $line)
      if uc substr($dest, 0, 1) ne uc $subs{$name}{RETURN};

    #
    # Now, we have to push (save) the arguments onto the stack in reverse
    # order. That way they can be pulled off by the subroutine in declaration
    # order, which will be convenient later for handling variable argument
    # subroutines.
    #
    # Arguments that are already in registers are easy. Constant arguments
    # have to be placed in the appropriate zero (temporary) register and then
    # saved.
    #

    foreach my $arg (reverse @args) {
      if (reg_q($arg)) {
        emit_code('save', [ $arg ]);
      } elsif (int_q($arg)) {
        emit_code('save', [ $arg ]);
      } elsif (num_q($arg)) {
        emit_code('save', [ $arg ]);
      } elsif (str_q($arg)) {
        emit_code('save', [ $arg ]);
      } else {
        confess "jakoc: Internal error. Unrecognized argument '$arg' when preparing call to subroutine '$name'!";
      }
    }

    emit_code('save', [ scalar(@args) ]); # Save the arg count.

    #
    # Now, we can jump to the subroutine's entry point:
    #

    emit_code('bsr', [ $name ]);

    #
    # Our calling convention dictates that upon return from the subroutine,
    # the result will be on the top of the stack.
    #

    emit_code('restore', [ 'I0' ]);     # Pop off the result count
    emit_code('restore', [ $dest ]);
  } else {
    printf(STDERR "jakoc: Call to unrecognized assign function '%s' on line %d (Not in {%s}).\n",
      $name, $line, join(", ", sort keys %assign_funcs));
  }
}


###############################################################################
###############################################################################
##
## Block Handling
##
###############################################################################
###############################################################################


#
# begin_cond_block()
#

sub begin_cond_block
{
  my ($block, $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 {
      confess;
    }

    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()
#

my %type_name = (
  'i' => 'int',
  'n' => 'num',
  's' => 'str',
);

sub begin_sub_block
{
  my ($block, $name, $return_type, @formal_args) = @_;

  #
  # Flush any pending comments or labels.
  #

  emit_code();

  #
  # Generate the source code comment for the assembly listing.
  #

  my $arg_source = join(', ', map({ join(' ', @$_) } @formal_args));

  if (defined $return_type) {
    push_source "sub $type_name{$return_type} $name ($arg_source) {";
  } else {
    push_source "sub $name ($arg_source) {";
  }

  #
  # Emit code to jump over the subroutine.
  #
  # NOTE: We do this because we don't have a calling convention for starting
  # the program anywhere other than the first byte code op. Therefore, since
  # subroutines have to be defined before being called, the main program
  # will be at the end of the file, and we need to jump over the subroutines
  # to get there.
  #
  # This also implies that we can actually have code interspersed with
  # subroutine definitions just like Perl.
  #

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

  #
  # Here we have the actual subroutine entry point:
  #

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

  #
  # As part of the subroutine calling convention, the subroutine is
  # expected to leave everything except the zero registers as it
  # was found. Therefore, we start out by cloning all the registers.
  # In future, we could be smarter about this based on the registers
  # actually used by the subroutine, but for now this will do.
  #
  # TODO: Enable the 'P' regs when we start doing PMCs.
  #

  emit_code 'clonei', [ ];
  emit_code 'clonen', [ ];
#  emit_code 'clonep', [ ];
  emit_code 'clones', [ ];

  #
  # Record the subroutine information.
  #
  # We track the line number of definition, the return type, and the info
  # about the formal arguments.
  #

  $subs{$name} = {
    LINE   => $line,
    RETURN => $return_type,
    ARGS   => \@formal_args
  };

  $block->{RETURN}    = $return_type;

  #
  # Declare the formal arguments as variables:
  #
  # We need to have registers assigned to the formal arguments just like we do
  # for any other variable, and they need to go out of scope at the end of the
  # subroutine, so we put them through the standard variable declaration
  # procedure.
  #
  # TODO: When we make declared variables auto-initialize to zero, this will
  # be inefficient, since we are going to grab the value from the stack as
  # our next step. So eventually, we'll want an internal way to declare the
  # variable uninitialized without having it auto initialize to zero.
  #

  foreach my $formal_arg (@formal_args) {
    my ($arg_type, $arg_name) = @$formal_arg;

    declare_var($arg_name, uc substr($arg_type, 0, 1));
  }

  #
  # Generate code to load the arguments into their registers:
  #
  # First, we pop the argument count off the top of the stack, then we pop the
  # arguments off the stack.
  #
  # NOTE: We restore them in their order of declaration, which means they must
  # be saved in reverse order. This will come in handy later for being able to
  # handle variable numbers of arguments, since we'll be able to restore an
  # arg count before having to restore the variable args themselves.
  #
  # TODO: Should we bother checking that argc is what we expected?
  #

  emit_code 'restore', [ 'I0' ]; # Pop off the arg count.

  foreach my $formal_arg (@formal_args) {
    my ($arg_type, $arg_name) = @$formal_arg;

    my $ident_info = find_ident($arg_name);
    $ident_info = $ident_info->{IDENT};

    push_comment "(argument " . $arg_name . ")";

    emit_code 'restore', [ $ident_info->{REG} ];
  }
}


#
# begin_block()
#
# return_type is used by subroutines.
#
# 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, $return_type, @formal_args) = @_;
  $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;

  my $block = {
    TYPE   => $type,
    NEXT   => $line,
    PREFIX => $prefix,
    IDENT  => { },
  };

  push_block($block);

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


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

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

  #
  # If we are not currently 'inside' a block, then we've got no business
  # seeing a close-brace.
  #

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

  #
  # Pop the block info off the block stack and cache its prefix for use
  # in what follows. At this point we are no longer 'inside' a block.
  # Although, we may re-enter the block in certain cases (see below).
  #

  my $block  = pop_block();
  my $prefix = $block->{PREFIX};

  #
  # 'while' blocks:
  #
  # When we are ending the 'while' block, we might be beginning the
  # 'continue' block, so we check for that case. The while block and
  # the continue block form one logical block, with the identifiers
  # delcared in the former available in the latter. This means that
  # semantically, the 'continue' block is really like a 'continue'
  # label, since control falls through the 'while' block into the
  # 'continue' block by default, and we get to the 'continue' block
  # via a 'next' statement in the 'while' block's body, which is
  # essentially a 'goto my_continue' statement.
  #
  # NOTE: This is different from some languages. Some languages
  # treat the continue block as a truly separate block, and the
  # identifiers declared in the 'while' portion are *not* available
  # in the 'continue' portion.
  #

  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($block);        # Push it back on for a minute...
      undef $block;              # ... and forget about it.
    } else {
      push_source "}";
      push_label "${prefix}_CONT" unless defined $block->{CONT};
      emit_code('branch', ["${prefix}_NEXT"]);
      push_label "${prefix}_LAST";
    }
  }

  #
  # 'if' blocks:
  #
  # Continuation of 'if' blocks happens by $continue being 'else'. In that
  # case, we push the block back on the stack.
  #

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

      emit_code("branch", [ "${prefix}_LAST" ]); # Jump over the 'else'.
      push_label "${prefix}_ELSE";
      push_source "} else {";

      #
      # We push the block back onto the block stack, since we are
      # ending up still in a block.
      #
      # NOTE: We are not doing 'undef $block' here because we want
      # the code below to undeclare the variables from the 'if' block.
      #
      # TODO: Should we really be allocating a whole new block? Its
      # nice to reuse this one (and we set ELSE in it to know we
      # can't have *another* else continuation).
      #

      push_block($block);
    } else {
      push_source "}";
      emit_code();
      push_label "${prefix}_ELSE" unless defined $block->{ELSE};
      push_label "${prefix}_LAST";
    }
  }

  #
  # Handle the ending of subroutine blocks:
  #

  elsif ($block->{TYPE} eq 'sub') {
    push_source "}";
    push_label "${prefix}_LEAVE";

    #
    # On subroutine entry, we cloned the incoming registers.
    # Now, we push the result count, restore the incoming regs
    # and return to our caller.
    #
    # TODO: Enable the 'P' regs when we start dealing with PMCs.
    #
    # TODO: Complain if we haven't seen 'return' statement in a
    # subroutine that returns results (else we are going to be
    # very unhappy later...)
    #

    emit_code "save", [ defined($block->{RETURN}) ? 1 : 0 ]; # Push the result count.

    emit_code 'popi', [ ];
    emit_code 'popn', [ ];
#    emit_code 'popp', [ ];
    emit_code 'pops', [ ];

    #
    # Now, actually return.
    #

    emit_code "ret", [ ];

    push_label "${prefix}_AFTER";
    emit_code;
  }

  #
  # If there is any other kind of block, we have an internal compiler error.
  #

  else {
    confess "jakoc: Internal compiler error. End of unknown block type " . $block->{TYPE} . "!";
  }

  #
  # If $block is still defined, then we didn't push it back on the block
  # stack and we need to 'undeclare' the variables in the block, since
  # they are going out of scope.
  #

  if (defined $block) {
    foreach my $ident (keys %{$block->{IDENT}}) {
      my $ident_info = $block->{IDENT}{$ident};

      if (defined $ident_info->{NUM}) {
        undef $regs{$ident_info->{TYPE}}[$ident_info->{NUM}];
      }
    }

    $regs{'I'} = [ grep { defined } @{$regs{I}} ];
    $regs{'N'} = [ grep { defined } @{$regs{N}} ];
#    $regs{'P'} = [ grep { defined } @{$regs{P}} ];
    $regs{'S'} = [ grep { defined } @{$regs{S}} ];

    #
    # Erase all the identifiers. Since the block might have been pushed
    # back onto the block stack, we need to forget our block-specific
    # identifiers.
    #

    $block->{IDENT} = { };
  }
}


###############################################################################
###############################################################################
##
## Flow Control Statements
##
###############################################################################
###############################################################################


#
# do_loop_control()
#

sub do_loop_control
{
  my ($control_op, $loop_label, $cond, $left, $test, $right) = @_;

  my $type = 'while';

  #
  # Locate the block we'll be applying the control statement to:
  #

  my $block = find_block($type, $loop_label);

  unless (defined $block) {
    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');
  }

  $block = $block->{BLOCK};

  #
  # Generate the code:
  #

  my $prefix = $block->{PREFIX};
  my $which  = $block_types{$type}{uc $control_op};

  if (defined $cond) {
    push_source "$control_op ${prefix} $cond ($left $test $right)";
  } else {
    push_source "$control_op ${prefix}";
  }

  if (defined $block->{CONT} and $control_op eq 'next') {
    $which = $block_types{$type}{NEXT};      # Hard-coded to NEXT in continue { ... }
  }

  my $label = "${prefix}_$which";

  if (!defined $cond) {
    emit_code('branch', [ $label ]);
  } else {
    op_comp $cond, $test, map_args($left, $right), $label, undef;
  }
}


#
# do_return()
#

sub do_return
{
  my ($arg_type, $arg) = @_;

  if (defined $arg) {
    push_source "return $arg";
  } else {
    push_source "return";
  }

  ($arg) = map_args($arg);

  #
  # Find the enclosing subroutine block:
  #

  my $block = find_block('sub');

  unless (defined $block) {
    emit_code('<err>', []);
    printf STDERR "jakoc: 'return' outside of subroutine on line %d!\n", $line;
    return;
  }

  $block = $block->{BLOCK};

  #
  # Generate code:
  #

  my $prefix = $block->{PREFIX};
  my $return = $block->{RETURN};

  if (defined $return and not defined $arg_type) {
    printf STDERR "jakoc: 'return' without argument in subroutine that returns a value on line %d!\n", $line;
    return;
  }

  if (not defined $return and defined $arg_type) {
    printf STDERR "jakoc: 'return' with argument in subroutine that does not return a value on line %d!\n", $line;
    return;
  }

  #
  # Determine the type of the return value.
  #

  if (defined $arg_type and $arg_type eq '*') {
    if ($arg =~ m/^([INPS])\d+$/) {
      $arg_type = $1;
    } elsif ($arg =~ m/^-?\d+$/) {
      $arg_type = 'i';
    } elsif ($arg =~ m/^->\d+\.\d+$/) {
      $arg_type = 'n';
    } elsif ($arg =~ m/^"$/) {
      $arg_type = 's';
    } else {
      confess "Couldn't determine argument type!";
    }
  }

  #
  # Make sure what we are returning is of the appropriate type.
  #

  if (defined $return and defined $arg_type and uc $return ne uc $arg_type) {
    printf STDERR "jakoc: 'return' with argument of incorrect type ('%s') on line %d (expected '%s')!\n",
      $arg_type, $line, $return;
    last;
  }

  #
  # According to our calling conventions, the return value ends up on the
  # stack, below the return address so the caller can restore it off.
  #

  if (defined $return) {
    emit_code('save', [ $arg ]); # Push the result. Result count comes later.
  }

  #
  # The *_LEAVE label for the subroutine is where the assembly code to
  # actually complete the return portion of the calling convention lives.
  #

  emit_code('branch', ["${prefix}_LEAVE"]);
}


###############################################################################
###############################################################################
##
## Arithmetic Operations
##
###############################################################################
###############################################################################


#
# 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_bit_and()
#

sub do_bit_and
{
  my ($dest, $a, $b) = map_args(@_);
  emit_code("and", [$dest, $a, $b]);
}


#
# do_bit_or()
#

sub do_bit_or
{
  my ($dest, $a, $b) = map_args(@_);
  emit_code("or", [$dest, $a, $b]);
}


#
# do_shift()
#

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


###############################################################################
###############################################################################
##
## Argument Handling
##
###############################################################################
###############################################################################


#
# 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
##
## This is where the parsing happens. We can through the lines of source code
## one line at a time, recognizing certain patterns and using them to drive
## calls to the support routines above. This makes the syntax for Jako pretty
## rigid right now.
##
## TODO: Have a real parser so we can be a more free-form language.
##
###############################################################################
###############################################################################

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 int foo = 5;
  #
  # var num bar;
  # var num bar = 3.14;
  #
  # var str splee;
  # var str splee = "Howdy";
  #

  if ((m/^var\s+(i)nt\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*((-?\d+)|(0b[01]+)|(0[0-7]+)|(0x[0-9a-f]+)))?$/) ||
      (m/^var\s+(n)um\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(-?\d+(\.\d+)))?$/) ||
      (m/^var\s+(s)tr\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(\"[^\\\"]*(?:\\.[^\\\"]*)*\"))?$/)
  ) { 
    declare_var($2, uc($1));
    assign_var($2, uc($1), $4) if defined $4;
    next;
  }

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

  if ((m/^var\s+(i)nt\s+(([A-Za-z][A-Za-z0-9_]*)(\s*,\s*[A-Za-z][A-Za-z0-9_]*)+)(\s*=\s*((-?\d+)|(0b[01]+)|(0[0-7]+)|(0x[0-9a-f]+)))?$/) ||
      (m/^var\s+(n)um\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\s+(([A-Za-z][A-Za-z0-9_]*)(\s*,\s*[A-Za-z][A-Za-z0-9_]*)+)(\s*=\s*(\"[^\\\"]*(?:\\.[^\\\"]*)*\"))?$/)
  ) {
    foreach my $var (split(/\s*,\s*/, $2)) {
      declare_var($var, uc($1));
      assign_var($var, uc($1), $6) if defined $6;
    }
    next;
  }

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

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

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

  if ((m/^const\s+(i)nt\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*((-?\d+)|(0b[01]+)|(0[0-7]+)|(0x[0-9a-f]+)))?$/) ||
      (m/^const\s+(n)um\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(-?\d+(\.\d+)))$/) ||
      (m/^const\s+(s)tr\s+([A-Za-z][A-Za-z0-9_]*)(\s*=\s*(\"[^\\\"]*(?:\\.[^\\\"]*)*\"))$/)) { 
    declare_const($2, uc($1), $4);
    next;
  }

  #
  # Variable Assignments:
  #
  # a = 5;
  # a = 3.14;
  # a = "Howdy";
  # a = b;
  #
 
  if (m/^([A-Za-z][A-Za-z0-9_]*)\s*=\s*((-?\d+)|(0b[01]+)|(0[0-7]+)|(0x[0-9a-f]+))$/) {
    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+)|(0b[01]+)|(0[0-7]+)|(0x[0-9a-f]+))$/) {
    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 (...) {
  # sub int NAME (...) {
  # sub num NAME (...) {
  # sub str NAME (...) {
  #

  if (m/^sub\s+((int|num|str)\s+)?([A-Za-z][A-Za-z0-9_]*)\s*\((.*)\)\s*{$/) {
    my $block_label = $3;
    my $block_type  = 'sub';
    my $return_type = defined($2) ? substr($2, 0, 1) : undef;
    my @formal_args = map { [ split(/\s+/, $_) ] } split(/\s*,\s*/, $4);

    begin_block($block_label, $block_type, undef, $return_type, @formal_args);

    next;
  }

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

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

  #
  # Loop Control Statements:
  #
  # next
  # next          if (...)
  # next          unless (...)
  # next LOOPNAME
  # next LOOPNAME if (...)
  # next LOOPNAME unless (...)
  #
  # last
  # last          if (...)
  # last          unless (...)
  # last LOOPNAME
  # last LOOPNAME if (...)
  # last LOOPNAME unless (...)
  #
  # redo
  # redo          if (...)
  # redo          unless (...)
  # redo LOOPNAME
  # redo LOOPNAME if (...)
  # redo LOOPNAME unless (...)
  #
  # 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_]*))?(\s+(if|unless)\s+\((\S+)\s*(==|!=|<=|<|>=|>)\s*(\S+)\s*\))?$/) {
    do_loop_control($1, $3, $5, $6, $7, $8);
    next;
  }

  #
  # Subroutine Return Statements:
  #
  # return
  # return 0
  # return 0.0
  # return "foo"
  # return bar
  #

  if (m/^return\s+((-?\d+)|(0b[01]+)|(0[0-7]+)|(0x[0-9a-f]+))$/) {
    do_return('i', $1);
    next;
  }
 
  if (m/^return\s+(-?\d+\.\d+)$/) {
    do_return('n', $1);
    next;
  }

  if (m/^return\s+(\"[^\\\"]*(?:\\.[^\\\"]*)*\")$/) {
    do_return('s', $1);
    next;
  }

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

  if (m/^return$/) {
    do_return();
    next;
  }

  if (m/^(return)(\s+([A-Za-z][A-Za-z0-9_]*)(\s+(if|unless)\s+\((\S+)\s*(==|!=|<=|<|>=|>)\s*(\S+)\s*\))?)?$/) {
    do_return('i', $3, $5, $6, $7, $8);
    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 augend
    #  3. RHS augend (variable name)
    #  4. RHS augend (number)
    #  5. RHS augend (number's decimal places) -- used for grouping, not capture
    #  6. RHS addend
    #  7. RHS addend (variable name)
    #  8. RHS addend (number)
    #  9. RHS 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;
  # a = b & c;
  # a = b | c;
  #
  # 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;
  }

  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+)|(0b[01]+)|(0[0-7]+)|(0x[0-9a-f]+)))$/) {
    push_source "$1 = $2 \& $5";
    do_bit_and($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_bit_and($1, $1, $2);
    next;
  }

  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+)|(0b[01]+)|(0[0-7]+)|(0x[0-9a-f]+)))$/) {
    push_source "$1 = $2 | $5";
    do_bit_or($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_bit_or($1, $1, $2);
    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.
#
