File Coverage

blib/lib/Imager/Expr/Assem.pm

Criterion	Covered	Total	%
statement	79	104	75.9
branch	38	54	70.3
condition	6	15	40.0
subroutine	6	6	100.0
pod	1	1	100.0
total	130	180	72.2

package Imager::Expr::Assem;
use 5.006;
use strict;
use Imager::Expr;
use Imager::Regops;

our $VERSION = "1.004";

our @ISA = qw(Imager::Expr);

__PACKAGE__->register_type('assem');

sub compile {
  my ($self, $expr, $opts) = @_;
  my %nregs;
  my @vars = $self->_variables();
  my @nregs = (0) x @vars;
  my @cregs;
  my %vars;
  @vars{@vars} = map { "r$_" } 0..$#vars;
  my %labels;
  my @ops;
  my @msgs;
  my $attr = \%Imager::Regops::Attr;

  # initially produce [ $linenum, $result, $opcode, @parms ]
  my $lineno = 0;
  while ($expr =~ s/^([^\n]+)(?:\n|$)//) {
    ++$lineno;
    my $line = $1;
    $line =~ s/#.*//;
    next if $line =~ /^\s*$/;
    for my $op (split /;/, $line) {
      if (my ($name, $type) = $op =~ /^\s*var\s+([^:]+):(\S+)\s*$/) {
	if (exists $vars{$name}) {
	  push(@msgs, "$lineno: duplicate variable name '$name'");
	  next;
	}
	if ($type eq 'num' || $type eq 'n') {
	  $vars{$name} = 'r'.@nregs;
	  push(@nregs, undef);
	  next;
	}
	elsif ($type eq 'pixel' || $type eq 'p' || $type eq 'c') {
	  $vars{$name} = 'p'.@cregs;
	  push(@cregs, undef);
	  next;
	}
	push(@msgs, "$lineno: unknown variable type $type");
	next;
      }
      # any statement can have a label
      if ($op =~ s/^\s*(\w+):\s*//) {
	if ($labels{$1}) {
	  push(@msgs,
	       "$lineno: duplicate label $1 (previous on $labels{$1}[1])");
	  next;
	}
	$labels{$1} = [ scalar @ops, $lineno ];
      }
      next if $op =~ /^\s*$/;
      # jumps have special operand handling
      if ($op =~ /^\s*jump\s+(\w+)\s*$/) {
	push(@ops, [$lineno, "", "jump", $1]);
      }
      elsif (my ($code, $reg, $targ) =
	     ($op =~ /^\s*(jumpz|jumpnz)\s+(\S+)\s+(\S+)\s*$/)) {
	push(@ops, [$lineno, "", $code, $reg, $targ]);
      }
      elsif ($op =~ /^\s*print\s+(\S+)\s*/) {
	push(@ops, [$lineno, "", 'print', $1 ]);
      }
      elsif ($op =~ /^\s*ret\s+(\S+)\s*/) {
	push(@ops, [$lineno, "", 'ret', $1]);
      }
      elsif ($op =~ s/\s*(\S+)\s*=\s*(\S+)\s*$//) {
	# simple assignment
	push(@ops, [$lineno, $1, "set", $2]);
      }
      elsif ($op =~ s/\s*(\S+)\s*=\s*(\S+)\s*//) {
	# some normal ops finally
	my ($result, $opcode) = ($1, $2);
	unless ($attr->{$opcode}) {
	  push(@msgs, "$lineno: unknown operator $opcode");
	  next;
	}
	my @oper;
	while ($op =~ s/(\S+)\s*//) {
	  push(@oper, $1);
	}
	push(@ops, [$lineno, $result, $opcode, @oper]);
      }
      else {
	push(@msgs, "$lineno: invalid statement '$op'");
      }
    }
  }

  my $max_opr = $Imager::Regops::MaxOperands;
  my $numre = $self->numre;
  my $trans =
    sub {
      # translate a name/number to a
      my ($name) = @_;
      $name = $self->{constants}{$name}
	if exists $self->{constants}{$name};
      if ($vars{$name}) {
	return $vars{$name};
      }
      elsif ($name =~ /^$numre$/) {
	$vars{$name} = 'r'.@nregs;
	push(@nregs, $name);
	return $vars{$name};
      }
      else {
	push(@msgs, "$lineno: undefined variable $name");
	return '';
      }
    };
  # now to translate symbols and so on
 OP: for my $op (@ops) {
    $lineno = shift @$op;
    if ($op->[1] eq 'jump') {
      unless (exists $labels{$op->[2]}) {
	push(@msgs, "$lineno: unknown label $op->[2]");
	next;
      }
      $op = [ 'jump', "j$labels{$op->[2]}[0]", (0) x $max_opr ];
    }
    elsif ($op->[1] =~ /^jump/) {
      unless (exists $labels{$op->[3]}) {
	push(@msgs, "$lineno: unknown label $op->[2]");
	next;
      }
      $op = [ $op->[1], $trans->($op->[2]), "j$labels{$op->[3]}[0]",
	      (0) x ($max_opr-1) ];
    }
    elsif ($op->[1] eq 'print') {
      $op = [ $op->[1], $trans->($op->[2]), (0) x $max_opr ];
    }
    elsif ($op->[1] eq 'ret') {
      $op = [ 'ret', $trans->($op->[2]), (0) x $max_opr ];
    }
    else {
      # a normal operator
      my ($result, $name, @parms) = @$op;

      if ($result =~ /^$numre$/) {
	push(@msgs, "$lineno: target of operator cannot be a constant");
	next;
      }
      $result = $trans->($result);
      for my $parm (@parms) {
	$parm = $trans->($parm);
      }
      push(@parms, (0) x ($max_opr-@parms));
      $op = [ $op->[1], @parms, $result ];
    }
  }

  # more validation than a real assembler
  # not trying to solve the halting problem...
  if (@ops && $ops[-1][0] ne 'ret' && $ops[-1][0] ne 'jump') {
    push(@msgs, ": the last instruction must be ret or jump");
  }

  $self->{nregs} = \@nregs;
  $self->{cregs} = \@cregs;

  if (@msgs) {
    $self->error(join("\n", @msgs));
    return 0;
  }

  return \@ops;
}

1;

__END__