#!/usr/bin/perl
#
# matops.pm --
#
#      Matrix operations.  This module implements a vectorized
#      Matlab-esque language to be used from Perl scripts.
#

use strict;
use warnings;

package matops;

use Carp;
use Data::Dumper;

sub RunScript;
sub Compile;

require Exporter;
our @ISA = ('Exporter');
our @EXPORT = qw(&RunScript &Compile);

my $debug = 0;


############################################################################
#

sub Debug {
   return unless $debug;

   print $_[0];
}


############################################################################
#

my @environments = ();
my @symbolTables = ();
my $currentEnvironment;

my %functions = (length => \&DoLength,
                 sum => \&DoSum,
                 min => \&DoMin,
                 max => \&DoMax,
                 sort => \&DoSort,
                 int => \&DoInt,
                 abs => \&DoAbs,
                 diff => \&DoDiff,
                 flip => \&DoFlip,
                 sqrt => \&DoSqrt,
                 ones => \&DoOnes,
                 zeros => \&DoZeros,
                 rand => \&DoRand,
                 all => \&DoAll,
                 any => \&DoAny,
                 sin => \&DoSin,
                 cos => \&DoCos,
                 tan => \&DoTan,
                 error => \&DoError,
                 disp => \&DoDisp,
                 save => \&DoSave);
my @userFunctions = ();


############################################################################
#

sub DeepCopy {
   my $this = shift;
   if (not ref $this) {
      $this;
   } elsif (ref $this eq "ARRAY") {
      [map DeepCopy($_), @$this];
   } elsif (ref $this eq "HASH") {
      +{map { $_ => DeepCopy($this->{$_}) } keys %$this};
   } else {
      croak "what type is $_?" . Backtrace();
   }
}


############################################################################
#
# Error --
#
#      Error handling.  Call die with the error message passed in and
#      the line and column position of the error.  This has the effect
#      of unwinding the stack back to RunScript() (which then has the
#      job of reporting the error to the user).
#

sub Error {
   my ($msg, $token) = @_;

   croak <<"ERROR";
Error:$$token[3]:$$token[4]: $msg
ERROR
}


sub Backtrace {
   my $unwind = '';
   my $frame = 0;

   my ($package, $file, $line, $sub);

   while (1) {
      my ($package, $file, $line) = caller($frame);
      my $thisFrame = sprintf("\n %3d: $file:$line in ", $frame);
      ($package, $file, $line, $sub) = caller($frame + 1);

      if (not defined($sub)) {
         $unwind = "$thisFrame(toplevel)$unwind";
         last;
      } else {
         $unwind = "$thisFrame$sub$unwind";
      }
      $frame++;
   }

   return "\n==================== Backtrace ====================$unwind\n"
}



############################################################################
#
# Various utilities --
#

sub IdentName {
   my $t = shift;

   if (!ref($t)) {
      print Dumper $t;
      croak q(Yo! $t isn't a ref) . Backtrace();
   }
   if ($t->[0] ne 'IDENT') {
      croak "Token is of type $t->[0], not IDENT!";
   }

   return $t->[1];
}


############################################################################
#
# Lexical analysis --
#
#      Interface to lexical analyzer is provided by these four functions:
#
#           Pushback
#           Peek
#           Match
#           Expect
#
############################################################################

no warnings 'qw';

my %tokens = qw$NUMBER (?:[0-9]*\\.[0-9]+|[0-9]+)(?:[eE]-?[0-9]+)?
                IDENT  [A-Za-z_][A-Za-z0-9_]*
                STRING '(?:[^'\\n]|\\')*?'
                LBRACK \\[
                RBRACK \\]
                LPAREN \\(
                RPAREN \\)
                COLON  :
                PLUS   \\+
                MINUS  -
                TIMES  \\*
                DIVIDE /
                MODULO %
                EXP    \\^
                AND    &
                OR     \\|
                EQ     ==
                NE     ~=
                LE     <=
                LT     <
                GE     >=
                GT     >
                NOT    ~
                ASSIGN =
                NL     (?:\\n|;)
                COMMA  ,
                VARS   vars:$;

my %keywords = qw$IF     if
                  ELIF   elif
                  ELSE   else
                  ENDIF  endif
                  DEFUN  defun
                  ENDFUN endfun
                  WHILE  while
                  NEXT   next$;

## Global state (no, this isn't a reentrant parser).

my @tokenList = ();
my $line = 1;
my $pos = 0;


############################################################################
#
# Token --
#
#      Get the next token from the input.  This function is not
#      intended to be called by the parser.
#
#      The returned token is in the form:
#
#           (symbol, token, nextTokenPos)
#

sub Token {
   my $s = shift;

   unless (length($$s)) {
      return ('END', '', 0);
   }

   # XXX: This currently returns the first token to match, but it
   # should return instead the longest valid match.
   foreach my $sym (keys(%tokens)) {
      my $re = $tokens{$sym};

      if ($$s =~ m/^([ \t]*)($re)([ \t]*)(.*)/s) {
         my ($token, $rest) = ($2, $4);

         if ($sym eq 'IDENT') {
            # Check for keywords
            foreach my $kw (keys(%keywords)) {
               if ($token eq $keywords{$kw}) {
                  $sym = $kw;
                  last;
               }
            }
         }

         $$s = $4;
         return ($sym, $token, length($1)+length($2)+length($3));
      }
   }

   Error('Unrecognized character', [undef, undef, length($$s), $line, $pos]);
}


############################################################################
#
# Pushback --
#
#      Push the provided token back.  It will then be the next token
#      returned by Peek or Expect.
#

sub Pushback {
   my $token = $_[0];

   push @tokenList, $token;
}


############################################################################
#
# Peek --
#
#      Return the top token on the stack without popping it.  Used for
#      lookahead.
#

sub Peek {
   my $expr = $_[0];

   if (@tokenList == 0) {
      push @tokenList, [Token($expr), $line, $pos];

      if ($tokenList[-1][0] eq 'NL') {
         $tokenList[-1][1] = ''; # for debugging
         $line++;
         $pos = 0;
      }

      Debug("type $tokenList[-1][0] token: <$tokenList[-1][1]>\n");
   }

   return $tokenList[-1];
}


############################################################################
#
# Match --
#
#      Determine if the provided token matches the expected symbol
#      type.
#

sub Match {
   my ($token, $match) = @_;

   return defined($$token[0]) && $$token[0] eq $match;
}


############################################################################
#
# Expect --
#
#      Pop the next symbol off the stack (or retrieve it from the
#      lexer), compare it with the expected symbol type, and, if it
#      matches, return it.  If it doesn't match, throw an error.
#

sub Expect {
   if (@_ != 2) {
      croak "Hey dumbo! Expect takes two args.\n" . Backtrace();
   }

   my ($expr, $match) = @_;

   my $token;

   if (@tokenList) {
      $token = pop @tokenList;
   } else {
      $token = [Token($expr), $line, $pos];

      if ($$token[0] eq 'NL') {
         $$token[1] = ''; # for debugging
         $line++;
         $pos = 0;
      }

      Debug("type $$token[0] token: <$$token[1]>\n");
   }

   if (Match($token, $match)) {
      $pos += $$token[2];
      return $token;
   }

   Error("expected $match token but found $$token[0]", $token);
}


############################################################################
#
# Parser --
#
#      This grammar is implemented as an LL(2) parser.
#
############################################################################


############################################################################
#
# varlist : IDENT
#         | IDENT COMMA varlist
#

sub varlist {
   my $expr = $_[0];

   my $token = Expect($expr, 'IDENT');
   my $tree = [$token];

   if (Match(Peek($expr), 'COMMA')) {
      Expect($expr, 'COMMA');
      push @$tree, @{varlist($expr)};
   }

   return $tree;
}


############################################################################
#
# vardecl : VARS varlist NL
#

sub vardecl {
   my $expr = $_[0];

   my $tree = ['VARDECL'];

   Expect($expr, 'VARS');
   push @$tree, @{varlist($expr)};
   Expect($expr, 'NL');

   return $tree;
}


############################################################################
#
# arrexpr : IDENT LBRACK expr RBRACK
#

sub arrexpr {
   my $expr = $_[0];

   my $token = Expect($expr, 'IDENT');

   my @tree = ('ARREXPR', $token);

   Expect($expr, 'LBRACK');
   push @tree, expr($expr);
   Expect($expr, 'RBRACK');

   return \@tree;
}


############################################################################
#
# array_list :
#            | expr
#            | expr COMMA array_list
#

sub array_list {
   my $expr = $_[0];

   my @tree = (expr($expr));

   while (Match(Peek($expr), 'COMMA')) {
      Expect($expr, 'COMMA');
      push @tree, @{array_list($expr)};
   }

   return \@tree;
}



############################################################################
#
# array : LBRACK array_list RBRACK
#

sub array {
   my $expr = $_[0];

   my @tree = ('ARRAY');;

   Expect($expr, 'LBRACK');
   if (!Match(Peek($expr), 'RBRACK')) {
      push @tree, @{array_list($expr)};
   }
   Expect($expr, 'RBRACK');

   return \@tree;
}


############################################################################
#
# funargs :
#         | expr
#         | expr COMMA funargs
#

sub funargs {
   my $expr = $_[0];

   my @args = ();

   while (1) {
      push @args, expr($expr);

      if (not Match(Peek($expr), 'COMMA')) {
         last;
      }

      Expect($expr, 'COMMA');
   }

   return \@args;
}


############################################################################
#
# funcall : IDENT LPAREN funargs RPAREN
#

sub funcall {
   my $expr = $_[0];

   my $token = Expect($expr, 'IDENT');
   my @tree = ('FUNCALL', $token);

   Expect($expr, 'LPAREN');
   if (not Match(Peek($expr), 'RPAREN')) {
      my $args;
      $args = funargs($expr);
      if (@$args) {
         push @tree, @$args;
      }
   }
   Expect($expr, 'RPAREN');

   return \@tree;
}


############################################################################
#
# uniexpr : IDENT
#         | NUMBER
#         | arrexpr
#         | array
#         | funcall
#         | LPAREN expr RPAREN
#         | MINUS uniexpr
#         | PLUS uniexpr
#         | NOT uniexpr
#

sub uniexpr {
   my $expr = $_[0];

   my $tree = [];
   my $token = Peek($expr);

   if (Match($token, 'MINUS')) {
      $token = Expect($expr, 'MINUS');
      $tree = ['UNIEXPR', $token, uniexpr($expr)];

   } elsif(Match($token, 'PLUS')) {
      $token = Expect($expr, 'PLUS');
      $tree = ['UNIEXPR', $token, uniexpr($expr)];

   } elsif(Match($token, 'NOT')) {
      $token = Expect($expr, 'NOT');
      $tree = ['UNIEXPR', $token, uniexpr($expr)];

   } elsif (Match($token, 'IDENT')) {
      # IDENT, TERMINAL, or arrexpr

      $token = Expect($expr, 'IDENT');

      if (Match(Peek($expr), 'LPAREN')) {
         Pushback($token);
         $tree = funcall($expr);

      } elsif (Match(Peek($expr), 'LBRACK')) {
         Pushback($token);
         $tree = arrexpr($expr);

      } else {
         # IDENT
         $tree = ['TERMINAL', $token];

      }

   } elsif (Match($token, 'NUMBER')) {
      # NUMBER
      $tree = ['TERMINAL', Expect($expr, 'NUMBER')];

   } elsif (Match($token, 'LPAREN')) {
      Expect($expr, 'LPAREN');
      $tree = ['UNIEXPR', expr($expr)];
      Expect($expr, 'RPAREN');

   } elsif (Match($token, 'LBRACK')) {
      $tree = array($expr);

   } else {
      Error('missing expression', $token);
   }

   return $tree;
}

############################################################################
#
# expr : uniexpr
#      | uniexpr EXP expr
#      | uniexpr TIMES expr
#      | uniexpr DIVIDE expr
#      | uniexpr MODULO expr
#      | uniexpr PLUS expr
#      | uniexpr MINUS expr
#      | uniexpr AND expr
#      | uniexpr OR expr
#      | uniexpr EQ expr
#      | uniexpr NE expr
#      | uniexpr LT expr
#      | uniexpr LE expr
#      | uniexpr GT expr
#      | uniexpr GE expr
#

# Operator precedence:
#
#   11:  f(...)     function call   postfix         ltr
#   10:  ~          logical not     unary           rtl
#    9:  - +        negation, plus  unary           rtl
#    8:  ^          exponentiation  binary          rtl
#    7:  * / %      multiplicative  binary          ltr
#    6:  + -        additive        binary          ltr
#    5:  < > <= >=  relational      binary          ltr
#    4:  == ~=      equality        binary          ltr
#    3:  &          logical and     binary          ltr
#    2:  |          logical or      binary          ltr
#    1:  :          colon operator  binary/trinary  ltr
#
# Precedence levels 11, 10, and 9 are handled by uniexpr().
#

my %precedence = (EXP    => 8,
                  TIMES  => 7,
                  DIVIDE => 7,
                  MODULO => 7,
                  PLUS   => 6,
                  MINUS  => 6,
                  LT     => 5,
                  GT     => 5,
                  LE     => 5,
                  GE     => 5,
                  EQ     => 4,
                  NE     => 4,
                  AND    => 3,
                  OR     => 2,
                  COLON  => 1);

sub Precedence {
   my $op = $_[0];

   return $precedence{$op->[0]};
}

sub Assoc {
   my $op = $_[0];

   if ($op->[0] eq 'EXP') {
      # ~ and unary +- are handled in uniexpr()
      return 'RTL';
   } else {
      return 'LTR';
   }
}


sub expr {
   my $expr = $_[0];

   my $left = uniexpr($expr);
   my $op;
   my $right;

 expr_loop:
   $op = Peek($expr);

   if (Match($op, 'EQ')) {
      $op = Expect($expr, 'EQ');
   } elsif (Match($op, 'NE')) {
      $op = Expect($expr, 'NE');
   } elsif (Match($op, 'LT')) {
      $op = Expect($expr, 'LT');
   } elsif (Match($op, 'LE')) {
      $op = Expect($expr, 'LE');
   } elsif (Match($op, 'GT')) {
      $op = Expect($expr, 'GT');
   } elsif (Match($op, 'GE')) {
      $op = Expect($expr, 'GE');
   } elsif (Match($op, 'AND')) {
      $op = Expect($expr, 'AND');
   } elsif (Match($op, 'OR')) {
      $op = Expect($expr, 'OR');
   } elsif (Match($op, 'PLUS')) {
      $op = Expect($expr, 'PLUS');
   } elsif (Match($op, 'MINUS')) {
      $op = Expect($expr, 'MINUS');
   } elsif (Match($op, 'TIMES')) {
      $op = Expect($expr, 'TIMES');
   } elsif (Match($op, 'DIVIDE')) {
      $op = Expect($expr, 'DIVIDE');
   } elsif (Match($op, 'MODULO')) {
      $op = Expect($expr, 'MODULO');
   } elsif (Match($op, 'EXP')) {
      $op = Expect($expr, 'EXP');
   } elsif (Match($op, 'COLON')) {
      $op = Expect($expr, 'COLON');
   } else {
      # Done with expr

      # Special case for x:y:z - flatten the tree somewhat.
      if (@$left > 1 and
          $left->[1]->[0] eq 'COLON' and
          $left->[2]->[0] eq 'EXPR' and
          $left->[2]->[1]->[0] eq 'COLON') {

         $left = [$left->[0],
                  $left->[1],
                  $left->[2]->[2],
                  $left->[2]->[3],
                  $left->[3]];
      }

      return $left;
   }

   $right = expr($expr);

   if ($right->[0] ne 'EXPR') {
      $left = ['EXPR', $op, $left, $right];
   } else {
      my $rop = $right->[1];

      my ($pl, $pr) = (Precedence($op), Precedence($rop));

      if ($pl < $pr || ($pl == $pr && Assoc($op) eq 'RTL')) {
         $left = ['EXPR', $op, $left, $right];
      } else {
         $left = ['EXPR',
                  $right->[1],
                  ['EXPR', $op, $left, $right->[2]],
                  $right->[3]];
      }
   }

   $op = undef;
   $right = undef;
   goto expr_loop;
}


############################################################################
#
# str  : STRING
#      | expr

sub str {
   my $expr = $_[0];

   my $token = Peek($expr);
   if (Match($token, 'STRING')) {
      $token = Expect($expr, 'STRING');
   } else {
      $token = expr($expr);
   }

   return $token;
}


############################################################################
#
# strs : str
#      | str COMMA strs
#

sub strs {
   my $expr = $_[0];

   my @tree = ();

   while (1) {
      push @tree, str($expr);

      last if not Match(Peek($expr), 'COMMA');
      Expect($expr, 'COMMA');
   }

   return \@tree;
}


############################################################################
#
# proc_stmnt : IDENT LPAREN strs RPAREN
#

sub proc_stmnt {
   my $expr = $_[0];

   my @tree = ('PROCEDURE');

   my $token = Expect($expr, 'IDENT');
   push @tree, $token;
   Expect($expr, 'LPAREN');
   my $strs = strs($expr);
   push @tree, @$strs;
   Expect($expr, 'RPAREN');

   return \@tree;
}


############################################################################
#
# assn_stmnt : IDENT ASSIGN expr
#            | arrexp ASSIGN expr
#

sub assn_stmnt {
   my $expr = $_[0];

   my $token = Expect($expr, 'IDENT');

   my @tree = ('ASSIGN');

   if (Match(Peek($expr), 'LBRACK')) {
      Pushback($token);
      push @tree, arrexpr($expr);
   } else {
      # IDENT
      push @tree, $token;
   }

   Expect($expr, 'ASSIGN');
   push @tree, expr($expr);

   return \@tree;
}


############################################################################
#
# loop_stmnt : WHILE expr NL stmnts NL NEXT
#

sub loop_stmnt {
   my $expr = $_[0];

   my @tree = ('LOOP');

   Expect($expr, 'WHILE');
   push @tree, expr($expr);
   Expect($expr, 'NL');
   push @tree, stmnts($expr);
   Expect($expr, 'NEXT');

   return \@tree;
}


############################################################################
#
# elif_stmnt : ELIF expr NL stmnts
#            | elif_stmnt NL elif_stmnt
#

sub elif_stmnt {
   my $expr = $_[0];

   my @elif = ();

   Expect($expr, 'ELIF');
   push @elif, expr($expr);
   Expect($expr, 'NL');
   push @elif, stmnts($expr);

   return \@elif;
}


############################################################################
#
# cond_stmnt : IF expr NL stmnts ENDIF
#            | IF expr NL stmnts ELSE NL stmnts ENDIF
#            | IF expr NL stmnts elif_stmnt ENDIF
#            | IF expr NL stmnts elif_stmnt ELSE NL stmnts ENDIF
#

sub cond_stmnt {
   my $expr = $_[0];

   my @tree = ('COND');
   my @if;

   Expect($expr, 'IF');
   push @if, expr($expr);
   Expect($expr, 'NL');
   push @if, stmnts($expr);

   push @tree, \@if;

   while (Match(Peek($expr), 'ELIF')) {
      push @tree, elif_stmnt($expr);
   }

   my $token = Peek($expr);

   if (Match($token, 'ELSE')) {
      Expect($expr, 'ELSE');
      Expect($expr, 'NL');
      push @tree, [['TERMINAL', ['NUMBER', '1', 0, 0, 0]], stmnts($expr)];
   } elsif (Match($token, 'ENDIF')) {
      # nop
   } else {
      Error("expected 'endif' before '$$token[1]' token", $token);
   }

   Expect($expr, 'ENDIF');

   return \@tree;
}


############################################################################
#
# defun_stmnt: DEFUN IDENT ASSIGN IDENT LPAREN varlist RPAREN NL stmnts ENDFUN
#            | DEFUN IDENT ASSIGN IDENT LPAREN RPAREN NL stmnts ENDFUN
#

sub defun_stmnt {
   my $expr = $_[0];

   my @tree = ('DEFUN');

   Expect($expr, 'DEFUN');
   push @tree, Expect($expr, 'IDENT');
   Expect($expr, 'ASSIGN');

   my $fcn = Expect($expr, 'IDENT');

   push @tree, $fcn;
   Expect($expr, 'LPAREN');
   if (Match(Peek($expr), 'RPAREN')) {
      push @tree, [];
   } else {
      push @tree, varlist($expr);
   }
   Expect($expr, 'RPAREN');
   Expect($expr, 'NL');
   push @tree, stmnts($expr);
   Expect($expr, 'ENDFUN');

   return \@tree;
}


############################################################################
#
# stmnt  : NL
#        | proc_stmnt NL
#        | assn_stmnt NL
#        | loop_stmnt NL
#        | cond_stmnt NL
#

sub stmnt {
   my $expr = $_[0];

   my $token = Peek($expr);
   my $tree;

   if (Match($token, 'NL')) {
      $tree = [];
   } elsif (Match($token, 'IF')) {
      $tree = cond_stmnt($expr);
   } elsif (Match($token, 'WHILE')) {
      $tree = loop_stmnt($expr);
   } elsif (Match($token, 'DEFUN')) {
      $tree = defun_stmnt($expr);
   } elsif (Match($token, 'IDENT')) {
      $token = Expect($expr, 'IDENT');
      if (Match(Peek($expr), 'LPAREN')) {
         Pushback($token);
         $tree = proc_stmnt($expr);
      } else {
         Pushback($token);
         $tree = assn_stmnt($expr);
      }
   } else {
      Error("expected identifier or 'if' or 'while' or 'defun'", $token);
   }

   Expect($expr, 'NL');

   return $tree;
}


############################################################################
#
# stmnts : stmnt
#        | stmnt stmnts
#

sub stmnts {
   my $expr = $_[0];
   my @tree = ();

 restart:
   my $s = stmnt($expr);
   push @tree, $s if @$s;

   my $token = Peek($expr);

   if (Match($token, 'ELIF') or
       Match($token, 'ELSE') or
       Match($token, 'ENDIF') or
       Match($token, 'ENDFUN') or
       Match($token, 'NEXT') or
       Match($token, 'END')) {
      return \@tree;
   }

   goto restart;
}


############################################################################
#
# script : vardecl stmnts
#

sub ParseScript {
   my $expr = $_[0];

   my @tree = ();
   push @tree, vardecl($expr);
   push @tree, stmnts($expr);

   return \@tree;
}


############################################################################
#
# function : defun_stmnt NL
#

sub ParseFunction {
   my $expr = $_[0];

   my $tree = defun_stmnt($expr);
   Expect($expr, 'NL');
   Expect($expr, 'END');

   return $tree;
}


############################################################################
#
# program : script
#         | function
#

sub Parse {
   my $expr = $_[0];

   # Strip comments
   $expr =~ s/#.*$//mg;

   @tokenList = ();
   $line = 1;
   $pos = 0;

   my $token = Peek(\$expr);
   my $tree;

   if (Match($token, 'VARS')) {
      $tree = ParseScript(\$expr);
   } elsif (Match($token, 'DEFUN')) {
      $tree = ParseFunction(\$expr);
   } else {
      Error("Source must be either a function or script", $token);
   }

   return $tree;
}


############################################################################
#
# Analysis section --
#
#      Go through the parse tree, reducing common subexpressions,
#      adding vars to the symbol table and functions to the function
#      table, and creating bind environments.
#

sub IsRunnable {
   my $r = shift;

   return ref($r) and ref($r) eq 'HASH';
}



############################################################################
#
# Analyze_CheckVars --
#
#      Check that vars are defined before use (and that defined vars
#      are used).
#

sub Analyze_CheckVars {
   my ($environmentName, $line1, $defined, $used) = @_;

   foreach my $dv (keys(%$defined)) {
      unless (defined($used->{$dv})) {
         print "Warning:" . $defined->{$dv} .
            ": '${environmentName}::${dv}' defined but not used\n"
      }
   }

   foreach my $uv (keys(%$used)) {
      if (not defined($defined->{$uv}) or
          ($defined->{$uv} >= $used->{$uv} and
           $defined->{$uv} != $line1 and $used->{$uv} != $line1)) {
         Error("'${environmentName}::${uv}' used before definition",
               ['IDENT', $uv, length($uv), $used->{$uv}, 0]);
      }
   }

}


############################################################################
#

sub Analyze_expr {
   my ($expr, $used, $symbolTable) = @_;

   if ($expr->[0] eq 'EXPR') {
      Analyze_expr($expr->[2], $used, $symbolTable);
      Analyze_expr($expr->[3], $used, $symbolTable);

   } elsif ($expr->[0] eq 'UNIEXPR') {
      if ($expr->[1]->[0] eq 'EXPR') {
         Analyze_expr($expr->[1], $used, $symbolTable);
      } else {
         Analyze_expr($expr->[2], $used, $symbolTable);
      }

   } elsif ($expr->[0] eq 'FUNCALL') {
      foreach my $e (2..$#$expr) {
         Analyze_expr($expr->[$e], $used, $symbolTable);
      }

   } elsif ($expr->[0] eq 'ARREXPR') {
      $used->{IdentName($expr->[1])} = $expr->[1]->[3];
      Analyze_expr($expr->[2], $used, $symbolTable);

   } elsif ($expr->[0] eq 'ARRAY') {
      foreach my $a (1..$#$expr) {
         Analyze_expr($expr->[$a], $used, $symbolTable);
      }

   } elsif ($expr->[0] eq 'TERMINAL') {
      if (IsIdent($expr->[1])) {
         my $i = IdentName($expr->[1]);

         if (not defined($used->{$i})) {
            $used->{$i} = $expr->[1]->[3];
            $symbolTable->{$i} = [];
         }
      }

   } elsif ($expr->[0] eq 'STRING') {
      # nop
   } else {
      print Backtrace() . "\n";
      print "Analyze_expr: ????\n";
      print Dumper $expr;
      croak "Analyze_expr: ????";
   }
}


############################################################################
#

sub Analyze_defun {
   my $ptree = $_[0];

   my %defined = ();
   my %used = ();

   my ($environmentName, $symbolTable);

   my $bindTable = {type => 'function', in => [], out => []};

   # structure is ['DEFUN',out,name,[in],stmnts]
   $environmentName = IdentName($ptree->[2]);

   my $line1 = $ptree->[2]->[3];

   if (defined($functions{$environmentName})) {
      Error("Attempt to redefine function '" .
            IdentName($ptree->[2]) . "'", $ptree->[2]);
   }

   my $o = IdentName($ptree->[1]);
   $used{$o} = $ptree->[1]->[3];
   $bindTable->{out} = $o;

   foreach my $in (@{$ptree->[3]}) {
      my $i = IdentName($in);
      $defined{$i} = $in->[3];
      push @{$bindTable->{in}}, $i;
   }

   my $fcn = Analyze_stmnts($ptree->[4], $symbolTable, \%defined, \%used);

   Analyze_CheckVars($environmentName, $line1, \%defined, \%used);


   ## Create caller and add to function table
   push @userFunctions, $environmentName;
   $functions{$environmentName} = sub {
      my @in = @_;

      push @environments, $currentEnvironment;
      $currentEnvironment = $environmentName;

      # Bind input vars
      foreach my $k (0..$#in) {
         my $var = $bindTable->{in}->[$k];
         $symbolTable->{$var} = $in[$k];
      }

      push @symbolTables, $symbolTable;

      Exec_stmnts(DeepCopy($fcn));

      # Bind output vars

      my $out = $symbolTable->{$bindTable->{out}};

      # Clean up input vars
      foreach my $k (0..$#in) {
         my $var = $bindTable->{in}->[$k];
         $symbolTable->{$var} = [];
      }

      $currentEnvironment = pop @environments;
      pop @symbolTables;

      return $out;
   };
}


############################################################################
#

sub Analyze_stmnts {
   my ($stmnts, $symbolTable, $defined, $used) = @_;

   my $tree = [];

   foreach my $stmnt (@$stmnts) {
      my $new;

      if ($stmnt->[0] eq 'DEFUN') {
         Analyze_defun($stmnt);

         next; # Don't add to output tree.

      } elsif ($stmnt->[0] eq 'LOOP') {
         $new = ['LOOP', $stmnt->[1]];
         Analyze_expr($stmnt->[1], $used, $symbolTable);

         push @$new, Analyze_stmnts($stmnt->[2], $symbolTable, $defined, $used);

      } elsif ($stmnt->[0] eq 'COND') {
         $new = ['COND'];

         foreach my $c (1..$#$stmnt) {
            my $cond = $stmnt->[$c];

            Analyze_expr($cond->[0], $used, $symbolTable);

            push @$new, [$cond->[0], Analyze_stmnts($cond->[1], $symbolTable,
                                                    $defined, $used)];
         }

      } elsif ($stmnt->[0] eq 'ASSIGN') {
         my $id;
         if (IsIdent($stmnt->[1])) {
            $id = $stmnt->[1];
         } else {
            $id = $stmnt->[1]->[1];
         }

         if (not defined($defined->{IdentName($id)})) {
            $defined->{IdentName($id)} = $id->[3];
         }

         Analyze_expr($stmnt->[2], $used, $symbolTable);

         $new = $stmnt;

      } elsif ($stmnt->[0] eq 'PROCEDURE') {
         foreach my $e (2..$#$stmnt) {
            Analyze_expr($stmnt->[$e], $used, $symbolTable);
         }

         $new = $stmnt;

      } else {
         croak "Unknown stmnt: " . $stmnt->[0] . "!" . Backtrace();
      }

      push @$tree, $new;
   }

   return $tree;
}


############################################################################
#

sub Analyze {
   my $ptree = shift;

   ## XXX for now, just look for vars and functions

   # Sets of defined/used variables.  Used vars that aren't defined or
   # that are defined after usage cause an error.  Defined vars that
   # aren't used cause a warning.
   my %defined = ();
   my %used = ();

   my ($runnable, $environmentName);

   if (!ref($ptree->[0]) and $ptree->[0] eq 'DEFUN') {
      # Function

      Analyze_defun($ptree);
      $runnable = {};

   } else {
      # Script
      my ($symbolTable, $bindTable, $tree);

      $bindTable = {type => 'script', vars => []};
      $environmentName = '__main__';

      foreach my $k (1..$#{$ptree->[0]}) {
         my $v = $ptree->[0]->[$k];
         my $id = IdentName($v);

         push @{$bindTable->{vars}}, $id;
         $defined{$id} = $v->[3];
         $used{$id} = $v->[3];
      }

      $tree = Analyze_stmnts($ptree->[1], $symbolTable, \%defined, \%used);

      $runnable = {environmentName => $environmentName,
                   symbolTable => $symbolTable,
                   bindTable => $bindTable,
                   tree => [$ptree->[0], $tree]};
   }

   Analyze_CheckVars($environmentName, 1, \%defined, \%used);

   return $runnable;
}


############################################################################
#
# Execution engine --
#
#

sub NotImplemented {
   print Dumper $_[1];

   croak "Not implemented ($_[0])\n" . Backtrace();
}


############################################################################
#

sub IsIdent {
   my $v = $_[0];

   return $v->[0] eq 'IDENT';
}


############################################################################
#

sub NumberValue {
   my $n = $_[0];

   return 0 + $n->[1];
}


############################################################################
#

sub IsEmpty {
   return @{$_[0]} == 0;
}


############################################################################
#

sub IsScalar {
   return @{$_[0]} == 1;
}


############################################################################
#

sub CheckDim {
   my ($op, $left, $right) = @_;

   if (@$left != @$right) {
      Error('Array size mismatch', $op);
   }
}


############################################################################
#

sub ApplyOne {
   my ($arg, $fcn) = @_;

   my @out = (0) x @$arg;
   foreach my $k (0..$#$arg) {
      $out[$k] = &$fcn($arg->[$k]);
   }

   return \@out;
}


############################################################################
#

sub ApplyTwo {
   my ($left, $right, $fcn) = @_;

   my @out = 0 x @$left;
   foreach my $k (0..$#$left) {
      $out[$k] = &$fcn($left->[$k], $right->[$k]);
   }

   return \@out;
}


############################################################################
#

sub DoLength {
   my $arg = $_[0];

   return [scalar(@$arg)];
}


############################################################################
#

sub DoSum {
   my $arg = $_[0];

   my $s = 0;
   $s += $_ foreach @$arg;

   return [$s];
}


############################################################################
#

sub DoMin {
   my @A = @{$_[0]};

   return 0 unless @A;

   my $m = $A[0];

   foreach (@A) {
      $m = $_ if $_ < $m;
   }

   return [$m];
}


############################################################################
#

sub DoMax {
   my @A = @{$_[0]};

   return 0 unless @A;

   my $m = $A[0];

   foreach (@A) {
      $m = $_ if $_ > $m;
   }

   return [$m];
}


############################################################################
#

sub DoSort {
   my $arg = $_[0];

   my @r = sort { $a <=> $b } @{DeepCopy($arg)};

   return \@r;
}


############################################################################
#

sub DoInt {
   my $arg = $_[0];

   my @a = ();
   push @a, int($_) foreach @$arg;

   return \@a;
}


############################################################################
#

sub DoAbs {
   my $arg = $_[0];

   return ApplyOne($arg, sub { return abs($_[0]); });
}


############################################################################
#

sub DoSin {
   my $arg = $_[0];

   return ApplyOne($arg, sub { return sin($_[0]); });
}


############################################################################
#

sub DoCos {
   my $arg = $_[0];

   return ApplyOne($arg, sub { return cos($_[0]); });
}


############################################################################
#

sub DoTan {
   my $arg = $_[0];

   return ApplyOne($arg, sub { return sin($_[0]) / cos(($_[0])); });
}

############################################################################
#

sub DoDiff {
   my $arg = $_[0];

   my @arr = (0) x @$arg;

   foreach my $k (1..$#$arg) {
      $arr[$k] = $arg->[$k] - $arg->[$k-1];
   }

   return \@arr;
}


############################################################################
#

sub DoFlip {
   my $arg = $_[0];

   my @arr = @{DeepCopy($arg)};
   my @rev = reverse @arr;

   return \@rev;
}


############################################################################
#

sub DoSqrt {
   my $arg = $_[0];

   return ApplyOne($arg, sub { return sqrt($_[0]); });
}


############################################################################
#

sub DoOnes {
   my $arr = $_[0];

   my $len = @$arr;
   $len = $arr->[0] if $len == 1;

   my @out = (1) x $len;

   return \@out;
}

############################################################################
#

sub DoZeros {
   my $arr = $_[0];

   my $len = @$arr;
   $len = $arr->[0] if $len == 1;

   my @out = (0) x $len;

   return \@out;
}

############################################################################
#

sub DoAny {
   my $arr = $_[0];

   foreach my $v (@$arr) {
      return [1] if $v;
   }

   return [0];
}

############################################################################
#

sub DoRand {
   my $arr = $_[0];

   my $len = @$arr;
   $len = $arr->[0] if $len == 1;

   my @out = ();
   foreach (1..$len) {
      push @out, rand();
   }

   return \@out;
}


############################################################################
#

sub DoAll {
   my $arr = $_[0];

   foreach my $v (@$arr) {
      return [0] if !$v;
   }

   return [1];
}


############################################################################
#

sub DoError {
   croak "Error: $_[0]\n";
}


############################################################################
#

sub DoDisp {
   my @strs = ();

   foreach my $arg (@_) {
      if (ref($arg) ne 'ARRAY') {
         push @strs, $arg;
      } else {
         my $s;
         if (@$arg == 1) {
            $s = $arg->[0];
         } else {
            $s = '[' . join(',', @$arg) . ']';
         }
         push @strs, $s;
      }
   }

   print join(' ', @strs) . "\n";
}


############################################################################
#

sub DoSave {
   my $f = shift;

   if (@_ == 0) {
      croak('save: Missing argument')
   }

   my $N = @{$_[0]};

   # Check arg dimensions if more than one array was passed in.
   if (@_ > 1) {
      foreach my $a (0..$#_) {
         if (@{$_[$a]} != $N) {
            croak('save: array size mismatch in arg ' . ($a + 2))
         }
      }
   }

   open OUTFILE, ">$f" or croak "Unable to open $f: $!";
   foreach my $k (0..$N-1) {
      my @vals = ();
      foreach my $a (0..$#_) {
         push @vals, $_[$a]->[$k];
      }

      print OUTFILE join(',', @vals) . "\n";
   }
   close OUTFILE;
}

############################################################################
#

sub DoColon {
   my ($start, $incr, $stop);

   if (defined($_[2])) {
      ($start, $incr, $stop) = @_;
   } else {
      ($start, $incr, $stop) = ($_[0], [1], $_[1]);
   }

   if (!IsScalar($start) ||
       !IsScalar($incr) ||
       !IsScalar($stop)) {
      croak ": args must be scalar";
   }

   ($start, $incr, $stop) = ($start->[0], $incr->[0], $stop->[0]);

   # check vals
   if ($stop < $start && $incr > 0 or
       $stop > $start && $incr < 0 or
       $incr == 0 or
       $start == $stop) {
      return [];
   }

   my @out = ();

   my $d = 1; # direction + => 1, -  => -1
   $d = -1 if $stop < $start;

   while ($d * $start <= $d * $stop) {
      push @out, $start;
      $start += $incr;
   }

   return \@out;
}


############################################################################
#

sub DoOperation {
   my ($op, $left, $right, $extra) = @_;

   my $o = $op->[0];

   if (IsEmpty($left) || IsEmpty($right)) {
      return [];
   }

   if (IsScalar($left) xor IsScalar($right)) {
      if (IsScalar($left)) {
         my @a = ($left->[0]) x @$right;
         $left = \@a;
      } else {
         my @a = ($right->[0]) x @$left;
         $right = \@a;
      }
   }

   CheckDim($op, $left, $right);

   my $val;

   if ($o eq 'EXP') {
      $val = ApplyTwo($left, $right, sub { return $_[0] ** $_[1]; });
   } elsif ($o eq 'TIMES') {
      $val = ApplyTwo($left, $right, sub { return $_[0] * $_[1]; });
   } elsif ($o eq 'DIVIDE') {
      $val = ApplyTwo($left, $right, sub { return $_[0] / $_[1]; });
   } elsif ($o eq 'MODULO') {
      $val = ApplyTwo($left, $right, sub { return $_[0] % $_[1]; });
   } elsif ($o eq 'PLUS') {
      $val = ApplyTwo($left, $right, sub { return $_[0] + $_[1]; });
   } elsif ($o eq 'MINUS') {
      $val = ApplyTwo($left, $right, sub { return $_[0] - $_[1]; });
   } elsif ($o eq 'LT') {
      $val = ApplyTwo($left, $right, sub { return $_[0] < $_[1]; });
   } elsif ($o eq 'GT') {
      $val = ApplyTwo($left, $right, sub { return $_[0] > $_[1]; });
   } elsif ($o eq 'LE') {
      $val = ApplyTwo($left, $right, sub { return $_[0] <= $_[1]; });
   } elsif ($o eq 'GE') {
      $val = ApplyTwo($left, $right, sub { return $_[0] >= $_[1]; });
   } elsif ($o eq 'EQ') {
      $val = ApplyTwo($left, $right, sub { return $_[0] == $_[1]; });
   } elsif ($o eq 'NE') {
      $val = ApplyTwo($left, $right, sub { return $_[0] != $_[1]; });
   } elsif ($o eq 'AND') {
      $val = ApplyTwo($left, $right, sub { return $_[0] && $_[1]; });
   } elsif ($o eq 'OR') {
      $val = ApplyTwo($left, $right, sub { return $_[0] || $_[1]; });
   } elsif ($o eq 'COLON') {
      $val = DoColon($left, $right, $extra);
   } else {
      NotImplemented("Unknown operation ($o)", $op);
   }

   return $val;
}


############################################################################
#

sub Exec_uniexpr {
   my $expr = $_[0];

   my $val = [];
   my $arg = Exec_expr($expr->[2]);

   if ($expr->[1]->[0] eq 'MINUS') {
      $val = ApplyOne($arg, sub { return -($_[0]); });
   } elsif ($expr->[1]->[0] eq 'PLUS') {
      $val = ApplyOne($arg, sub { return +($_[0]); });
   } elsif ($expr->[1]->[0] eq 'NOT') {
      $val = ApplyOne($arg, sub { return !($_[0]); });
   }

   return $val;
}


############################################################################
#

sub Exec_array {
   my $expr = $_[0];

   my @out = ();

   shift @$expr;
   foreach my $e (@$expr) {
      push @out, @{Exec_expr($e)};
   }

   return \@out;
}


############################################################################
#

sub Exec_arrexpr {
   my $expr = $_[0];

   my $val = $symbolTables[-1]->{IdentName($expr->[1])};
   my $indices = Exec_expr($expr->[2]);

   my @out = @$val[@$indices];

   foreach my $k (0..$#out) {
      $out[$k] = 0 if not defined $out[$k];
   }


   return \@out;
}


############################################################################
#

sub Exec_funcall {
   my $expr = $_[0];

   my $fcn = $functions{IdentName($expr->[1])};

   unless (defined($fcn)) {
      Error(q(Function ') . IdentName($expr->[1]) . q(' does not exist),
            $expr->[1]);
   }

   my @args = ();
   foreach my $a (2..$#$expr) {
      push @args, Exec_expr($expr->[$a]);
   }

   return &$fcn(@args);
}


############################################################################
#

sub Exec_expr {
   my $expr = $_[0];

   my $val = [];

   if ($expr->[0] eq 'EXPR') {
      my $extra = undef;

      if (@$expr == 5) {
         # For :
         $extra = Exec_expr($expr->[4]);
      }

      $val = DoOperation($expr->[1],
                         Exec_expr($expr->[2]),
                         Exec_expr($expr->[3]),
                         $extra);

   } elsif ($expr->[0] eq 'TERMINAL') {

      if (IsIdent($expr->[1])) {
         $val = $symbolTables[-1]->{IdentName($expr->[1])};

         if (!defined($val)) {
            Error("Variable '${currentEnvironment}::" . IdentName($expr->[1]) .
                  "' used before defined", $expr->[1]);
         }
      } else {
         # NUMBER
         $val = [NumberValue($expr->[1])];
      }

   } elsif ($expr->[0] eq 'UNIEXPR') {
      # UNIEXPR
      if ($expr->[1]->[0] eq 'EXPR') {
         # parenthetical expression
         $val = Exec_expr($expr->[1]);
      } else {
         $val = Exec_uniexpr($expr);
      }
   } elsif ($expr->[0] eq 'ARRAY') {
      $val = Exec_array($expr);
   } elsif ($expr->[0] eq 'ARREXPR') {
      $val = Exec_arrexpr($expr);
   } elsif ($expr->[0] eq 'FUNCALL') {
      $val = Exec_funcall($expr);
   } else {
      NotImplemented('Exec_expr', $expr);
   }

   return $val;
}


############################################################################
#

sub Exec_assign {
   my $stmnt = $_[0];

   my $val = Exec_expr($stmnt->[2]);

   if (IsIdent($stmnt->[1])) {
      if ($debug) {
         print 'Assigning to ' . IdentName($stmnt->[1]) . "\n";
      }

      $symbolTables[-1]->{IdentName($stmnt->[1])} = $val;
   } else {
      # subscripted reference
      my $indices = Exec_expr($stmnt->[1]->[2]);

      if (IsScalar($val)) {
         my @vals = (@$val) x @$indices;
         $val = \@vals;
      }

      # var[indices] = val
      my $var = $symbolTables[-1]->{IdentName($stmnt->[1]->[1])};
      $var = [] if not defined $var;

      CheckDim(['ASSIGN', '=', 1,
                $stmnt->[1]->[1]->[3],
                $stmnt->[1]->[1]->[4]],
               $indices, $val);

      @$var[@$indices] = @$val;

      for my $k (0..$#$var) {
         $var->[$k] = 0 if not defined $var->[$k];
      }

      $symbolTables[-1]->{IdentName($stmnt->[1]->[1])} = $var;
   }
}


############################################################################
#

sub Exec_cond {
   my $stmnt = $_[0];

   foreach my $k (1..$#$stmnt) {
      my $cond = $stmnt->[$k];

      if (@{DoAll(Exec_expr($cond->[0]))}[0]) {
         Exec_stmnts($cond->[1]);
         last;
      }
   }
}


############################################################################
#

sub Exec_loop {
   my $stmnt = $_[0];

   while (@{DoAll(Exec_expr(DeepCopy($stmnt->[1])))}[0]) {
      Exec_stmnts(DeepCopy($stmnt->[2]));
   }
}


############################################################################
#

sub Exec_procedure {
   my $stmnt = $_[0];

   my $fcn = $functions{IdentName($stmnt->[1])};

   unless (defined($fcn)) {
      Error(q(Function ') . IdentName($stmnt->[1]) . q(' does not exist),
            $stmnt->[1]);
   }

   my @args = ();
   foreach my $k (2..$#$stmnt) {
      my $e = $stmnt->[$k];

      if ($e->[0] eq 'STRING') {
         my $s = $e->[1];
         $s =~ s/'(.*)'/$1/;
         $s =~ s/\\'/'/g;
         push @args, $s;
      } else {
         push @args, Exec_expr($e);
      }
   }

   &$fcn(@args);
}


############################################################################
#

sub Exec_stmnt {
   my $stmnt = $_[0];

   my $action = $stmnt->[0];
   croak "Exec_stmnt: ACTION undefined!" . Backtrace() unless defined $action;

   if ($action eq 'ASSIGN') {
      Exec_assign($stmnt);
   } elsif ($action eq 'COND') {
      Exec_cond($stmnt);
   } elsif ($action eq 'LOOP') {
      Exec_loop($stmnt);
   } elsif ($action eq 'PROCEDURE') {
      Exec_procedure($stmnt);
   }
}


############################################################################
#

sub Exec_stmnts {
   my $stmnts = $_[0];

   foreach my $stmnt (@$stmnts) {
      Exec_stmnt($stmnt);
   }
}


############################################################################
#

sub Eval {
   my ($runnable, $vars) = @_;

   my $symbolTable = {};
   $currentEnvironment = '__main__';

   # Bind vars
   my $tree = $runnable->{tree};
   my $vardecl = $tree->[0];

   if (@$vardecl - 1 != @$vars) {
      my $want = @$vardecl - 1;
      my $have = @$vars;
      croak("Number of args ($have) != number of vars in declaration ($want)");
   }

   push @symbolTables, $symbolTable;

   foreach my $v (0..$#$vars) {
      $symbolTables[-1]->{IdentName($vardecl->[$v + 1])} = $vars->[$v];

      if ($debug) {
         print 'Binding ' . IdentName($vardecl->[$v + 1]) . "\n";
      }
   }

   # Now exec everything recursively
   my $stmnts = $tree->[1];
   Exec_stmnts($stmnts);

   # Unbind vars

   my @out = ();
   foreach my $v (0..$#$vars) {
      push @out, $symbolTables[-1]->{IdentName($vardecl->[$v + 1])};
      if ($debug) {
         print 'Unbinding ' . IdentName($vardecl->[$v + 1]) . "\n";
      }
   }

   pop @symbolTables;

   return @out;
}


############################################################################
#

sub CompileWork {
   my ($script, $rrunnable) = @_;

   my ($tree, $runnable);

   eval {
      $tree = Parse($script);
      $runnable = Analyze($tree);
   };

   $$rrunnable = $runnable;
   return $@;
}


############################################################################
#

sub RunScriptWork {
   my $script = shift;
   my @args = @_;

   my $runnable;

   if (IsRunnable($script)) {
      $runnable = $script;
   } else {
      my $err = CompileWork($script, \$runnable);
      return $err if $err;
   }

   # Evaluate tree

   my @outArgs;
   eval {
      @outArgs = Eval($runnable, \@args);
   };
   return $@ if $@;

   # Reassign args
   foreach my $k (0..$#outArgs) {
      eval {
         splice @{$args[$k]}, 0, @{$args[$k]}, @{$outArgs[$k]};
      };
      if ($@) {
         croak $@ . Backtrace();
      }
   }
}


############################################################################
#

sub new {
   my $class = shift;
   my $this = {};
   bless($this, $class);

   if (@userFunctions) {
      foreach my $f (@userFunctions) {
         undef $functions{$f};
      }
      @userFunctions = ();
   }

   return $this;
}


############################################################################
#
# Compile a script only - add to function table.

sub Compile {
   my $this = shift;
   croak("Missing script") unless @_ >= 1;
   my $script = shift;

   Debug("======================================\n$script\n");

   my $runnable;
   my $err = CompileWork($script, \$runnable);

   chomp $err;
   croak "$err" if $err;

   return $runnable;
}


############################################################################
#

sub RunScript {
   my $this = shift;

   croak("Missing script") unless @_ >= 1;
   my $script = shift;

   croak("Must have one or more arguments") unless @_ >= 1;

   foreach (@_) {
      croak("Arguments must be array refs") unless ref($_) eq 'ARRAY';
   }

   unless (ref($script)) {
      Debug("======================================\n$script\n");
   }

   my $err = RunScriptWork($script, @_);

   chomp $err;
   croak "$err" if $err;
}


1;

__END__

=head1 MATOPS

Simple matrix operations for Perl (actually vector operations, but
that's splitting hairs).

=head1 SYNOPSIS

  use matops;

  @x = 1..3;
  @y = undef
  $m = matops->new();
  $m->RunScript(<<"SCRIPT", \@x, \@y);
  vars: x, y
  y = x^2
  SCRIPT

  @x = [data from somewhere]
  @m = undef
  $s = $m->Compile(<<"FUNCTION");
  vars: out, in
  out = mean(in)
  defun x = mean(data)
     x = sum(data) / length(data)
  endfun
  FUNCTION
  $m->RunScript($s, \@m, \@x);
  print "mean is $m[0]\n";


=head1 DESCRIPTION

matops is a Perl module which implements a simple and intuitive
language designed to operate in a seamless fashion on vectors of data.

Using the Compile function, it is possible to build a library of
subfunctions, and then execute scripts that use them.  It is also
possible to precompile scripts with the Compile function to save
future execution time.

Input and output is via array references.  Any array reference passed
in can be used for both input and output.


=head1 EXAMPLES


=item FIR filter:

  vars: y, x, f

  F = length(f)
  N = length(x) + F - 1
  f = flip(f)
  k = 0
  while (k < N)
     y[k] = sum(x[k:k+length(f)-1] * f)
  loop

=item Median absolute deviation:

  vars MAD, X

  mad = median(abs(X - median(X)))

  defun m = median(X)
     N = length(X)
     X = sort(X)
     mid = int(N / 2)

     if N % 2
        m = X[mid]
     else
        m = (X[mid] + X[mid - 1]) / 2
     endif
  endfun


=head1 BUILTIN FUNCTIONS

=item length:

Return the length of a vector.

=item sum:

Return the sum of all elements of a vector.

=item min:

Return the smallest element of a vector.

=item max:

Return the largest element of a vector.

=item sort:

Return a sorted vector, from small to large.

=item int:

Integer part.

=item abs:

Absolute value.

=item diff:

Return the difference between each adjacent element of a vector.

=item flip:

Return a vector that is the mirror image of the input.  E.g.:

  [1,2,3,4,5] => [5,4,3,2,1]

=item sqrt:

Square root.

=item ones:

Create a vector of ones of a specified length.

  ones(5) => [1,1,1,1,1]

=item zeros:

Create a vector of zeros of a specified length.

  zeros(5) => [0,0,0,0,0]

=item rand:

Create a vector of a specified length with random elements, in between
0 and 1.

=item all:

Return 1 if all elements in a vector are non-zero.

=item any:

Return 1 if any of the elements in a vector are non-zero.

=item sin:

Sine.

=item cos:

Cosine.

=item tan:

Tangent.

=item error:

Abort execution and print an error message.

=item disp:

Display a message to the console.  If an argument is a vector, convert
it to a string reprentation first.

=item save:

Save an array to a file.  The first argument is the filename, the
second is the array.


=head1 OPERATOR PRECEDENCE


11:  f(...)     function call   postfix         ltr
10:  ~          logical not     unary           rtl
 9:  - +        negation, plus  unary           rtl
 8:  ^          exponentiation  binary          rtl
 7:  * / %      multiplicative  binary          ltr
 6:  + -        additive        binary          ltr
 5:  < > <= >=  relational      binary          ltr
 4:  == ~=      equality        binary          ltr
 3:  &          logical and     binary          ltr
 2:  |          logical or      binary          ltr
 1:  :          colon operator  binary/trinary  ltr

=head1 GRAMMAR

 IDENT  => [A-Za-z_][A-Za-z0-9_]*
 NUMBER => ([0-9]*\\.[0-9]+|[0-9]+)([eE]-?[0-9]+)?
 STRING => '(?:[^'\\n]|\\')*?'
 IF     => if
 ELIF   => elif
 ELSE   => else
 ENDIF  => endif
 WHILE  => while
 NEXT   => next
 DEFUN  => defun
 ENDFUN => endfun
 LBRACK => [
 RBRACK => ]
 LPAREN => (
 RPAREN => )
 COLON  => :
 PLUS   => +
 MINUS  => -
 TIMES  => *
 DIVIDE => /
 MODULO => %
 EXP    => ^
 AND    => &
 OR     => |
 EQ     => ==
 NE     => ~=
 LT     => <
 LE     => <=
 GT     => >
 GE     => >=
 NOT    => ~
 ASSIGN => =
 NL     => \n|;
 COMMA  => ,
 VARS   => vars:


 varlist     : IDENT
             | IDENT COMMA varlist

 vardecl     : VARS varlist NL

 arrexpr     : IDENT LBRACK expr RBRACK

 array_list  :
             | expr
             | expr COMMA array_list

 array       : LBRACK array_list RBRACK

 funargs     :
             | expr
             | expr COMMA funargs

 funcall     : IDENT LPAREN funargs RPAREN

 uniexpr     : IDENT
             | NUMBER
             | arrexpr
             | array
             | funcall
             | LPAREN expr RPAREN
             | MINUS uniexpr
             | PLUS uniexpr
             | NOT uniexpr

 expr        : uniexpr
             | uniexpr EXP expr
             | uniexpr TIMES expr
             | uniexpr DIVIDE expr
             | uniexpr MODULO expr
             | uniexpr PLUS expr
             | uniexpr MINUS expr
             | uniexpr AND expr
             | uniexpr OR expr
             | uniexpr EQ expr
             | uniexpr NE expr
             | uniexpr LT expr
             | uniexpr LE expr
             | uniexpr GT expr
             | uniexpr GE expr

 str         : STRING
             | expr

 strs        : str
             | str COMMA strs

 proc_stmnt  : IDENT LPAREN strs RPAREN

 assn_stmnt  : IDENT ASSIGN expr
             | arrexp ASSIGN expr

 loop_stmnt  : WHILE expr NL stmnts NL NEXT

 elif_stmnt  : ELIF expr NL stmnts
             | elif_stmnt NL elif_stmnt

 cond_stmnt  : IF expr NL stmnts ENDIF
             | IF expr NL stmnts ELSE NL stmnts ENDIF
             | IF expr NL stmnts elif_stmnt ENDIF
             | IF expr NL stmnts elif_stmnt ELSE NL stmnts ENDIF

 stmnt       : NL
             | proc_stmnt NL
             | assn_stmnt NL
             | loop_stmnt NL
             | cond_stmnt NL

 stmnts      : stmnt
             | stmnt stmnts

 script      : vardecl stmnts

 defun_stmnt : DEFUN IDENT ASSIGN LPAREN varlist RPAREN NL stmnts ENDFUN
             | DEFUN IDENT ASSIGN LPAREN RPAREN NL stmnts ENDFUN

 function    : defun_stmnt NL

 program     : script
             | function

=cut