#! perl
# Copyright (C) 2003-2007, The Perl Foundation.
# $Id: COMP_expressions.pm 21232 2007-09-12 19:30:46Z paultcochrane $
use subs qw(fetchvar);
use vars qw(@builtins @keywords);
my $retcount = 200;
my $currentexpr;
@builtins = qw( abs asc atn
cdbl chr$ cint
clng command$ cos
csng csrlin cvd
cvdmbf cvi cbl
cvs cvsmbf date$
environ$ eof erdev
erdev$ erl err
exp fileattr fix
fre freefile hex$
inkey$
space_NOTYET$
time_NOTYET$
inp input$
instr int ioctl$
lbound lcase$ left$ len loc lof log lpos ltrim$
mid$ mkd$ mkdmbf$ mki$ mkl$ mks$ mksmbf$
peek pen play pmap point pos
right$ rnd rtrim$
sadd screen seek setmem sgn sin spc sqr
stick str$ strig string$
tab$ tan timer
ubound ucase$ val varptr varptr$ varseg
);
@keywords = qw( access alias any append as
base beep binary bload bsave byval
call calls absolute interrupt base chain circle clear
close cls color com common const
data declare def fn seg defdbl defint deflng defsng defstr
dim do loop double draw
else elseif end endif environ erase error exit
field files for next function
get gosub goto
if then input integer ioctl is
key kill
let line input list local locate lock unlock long loop
lprint lset
mid$ mkdir
name next
off on com error key pen play strig timer gosub goto com
option base out open
paint palette pcopy pen play poke preset print using
pset put
random randomize read redim rem reset restore resume
return rmdir rset run
screen seek select case shared shell single sleep
sound static stop sub swap system step
then
time_NOTYET$
timer troff tron type to
uevent unlock until using
view
wait while wend width window write
keys
);
sub dumpq {
print "Upcoming: $type[0] $syms[0]\n";
print "Current : $type[1] $syms[1]\n";
print "Previous: $type[2] $syms[2]\n";
}
sub isbuiltin { # Built in functions
return 0 unless defined $_[0];
return 1 if ( grep /^\Q$_[0]\E$/i, @builtins );
return 0;
}
sub isuserfunc {
# print "Isuserfunc $_[0] and $funcname..";
return 0 unless defined $_[0];
return 0 if $funcname and $funcname eq $_[0]; # We're processing this, don't count!
if ( grep /^\Q$_[0]\E$/i, keys %functions ) {
# print "Yes\n";
return 1;
}
# print "No\n";
return 0;
}
sub isarray {
#print STDERR "Looking up $_[0]$seg...\n";
$_ = ( grep /^\Q$_[0]$seg\E$/i, keys %arrays );
#print "$_\n";
return $_;
}
sub hasargs {
return ( isbuiltin( $_[0] ) or isuserfunc( $_[0] ) or isarray( $_[0] ) );
}
sub iskeyword {
return 1 if ( grep /^\Q$_[0]\E$/i, @keywords );
return 0;
}
sub precedence {
my ( $op, $next ) = @_;
#print STDERR "Precedence with '$op' and '$next'\n";
return 5 if ( $op eq "and" );
return 5 if ( $op eq "eqv" );
return 5 if ( $op eq "imp" );
return 5 if ( $op eq "or" );
return 5 if ( $op eq "xor" );
return 7 if ( $op eq "not" );
return 10 if ( $op eq "=" );
return 10 if ( $op eq ">=" );
return 10 if ( $op eq "<=" );
return 10 if ( $op eq "<>" );
return 10 if ( $op eq ">" );
return 10 if ( $op eq "<" );
return 15 if ( $op eq "," );
return 20 if ( $op eq "+" );
return 20 if ( $op eq "-" );
return 30 if ( $op eq "mod" );
return 40 if ( $op eq '\\' );
return 50 if ( $op eq "*" );
return 50 if ( $op eq "/" );
return 60 if ( $op eq "^" );
return 70 if ( $op eq "." );
return 99 if ( $op eq "UNARYMINUS" );
return 100 if ( isbuiltin $op);
return 100 if ( isuserfunc $op);
return 100 if ( isarray $op
and ( ( $next and $next eq "(" ) or !$next ) );
return 0; # Not an operator
}
sub false {
my ($type) = @_;
if ( $type eq "N" ) {
return "0.0";
}
else {
return qq{""};
}
}
my $eqnum = 0;
my %opsubs = (
'+' => sub {
my ( $a1, $a2, $result ) = @_;
if ( $result =~ /S/ ) {
return ( "\tconcat $result, $a2, $a1", $result );
}
else {
return ( "\t$result = $a1 + $a2", $result );
}
},
'-' => sub {
return ( "\t$_[2] = $_[1] - $_[0]", $_[2] );
},
'*' => sub {
return ( "\t$_[2] = $_[0] * $_[1]", $_[2] );
},
'/' => sub {
return ( "\t$_[2] = $_[1] / $_[0]", $_[2] );
},
'=' => sub {
my ( $a1, $a2, $result, $op ) = @_;
$op = "eq" unless $op;
$result =~ s/S/N/;
$eqnum++;
return ( <<CODE, $result );
set $result, 1.0
$op $a2, $a1, EQ_$eqnum
set $result, 0.0
EQ_$eqnum: noop
CODE
},
'and' => sub {
my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
$result =~ s/S/N/;
$eqnum++;
$ot1 = false($ot1);
$ot2 = false($ot2);
return ( <<CODE, $result );
set $result, 0.0
eq $a1, $ot1, EQ_$eqnum
eq $a2, $ot2, EQ_$eqnum
set $result, 1.0
EQ_$eqnum: noop
CODE
},
'or' => sub {
my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
$result =~ s/S/N/;
$eqnum++;
$ot1 = false($ot1);
$ot2 = false($ot2);
return ( <<CODE, $result );
# OR $a1, $a2
set $result, 0.0
ne $a1, $ot1, EQ_$eqnum
ne $a2, $ot2, EQ_$eqnum
branch EQ_${eqnum}_false
EQ_$eqnum: set $result, 1.0
EQ_${eqnum}_false: noop
CODE
},
'not' => sub {
my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
$result =~ s/S/N/;
$eqnum++;
$ot1 = false($ot1);
return ( <<CODE, $result );
# FIXME
eq $a1, $ot1, TRUE_${eqnum}
set $result, 0.0
branch NOT_${eqnum}
TRUE_${eqnum}: set $result, 1.0
NOT_${eqnum}: noop
CODE
die "$a1,$a2,$result,$op,$ot1,$ot2\n";
},
'xor' => sub {
my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
$result =~ s/S/N/;
$eqnum++;
$ot1 = false($ot1);
$ot2 = false($ot2);
return ( <<CODE, $result );
# XOR $a1, $a2
set $result, 0.0
eq $a1, $ot1, EQ_${eqnum}_a
inc $result
EQ_${eqnum}_a:
eq $a2, $ot2, EQ_$eqnum
inc $result
EQ_$eqnum: ne $result, 2.0, EQ_${eqnum}_end
set $result, 0.0
EQ_${eqnum}_end: noop
CODE
},
'eqv' => sub {
my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
$result =~ s/S/N/;
$eqnum++;
$ot1 = false($ot1);
$ot2 = false($ot2);
return ( <<CODE, $result );
# EQV $a1, $a2
set $result, 0.0
eq $a1, $ot1, EQ_${eqnum}_a
inc $result
EQ_${eqnum}_a:
eq $a2, $ot2, EQ_$eqnum
dec $result
EQ_$eqnum: eq $result, 0.0, EQ_${eqnum}_ok
set $result, 0.0
branch EQ_${eqnum}_end
EQ_${eqnum}_ok: set $result, 1.0
EQ_${eqnum}_end: noop
CODE
},
'imp' => sub {
my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
$result =~ s/S/N/;
$eqnum++;
$ot1 = false($ot1);
$ot2 = false($ot2);
( $a1, $a2, $ot1, $ot2 ) = ( $a2, $a1, $ot2, $ot1 );
return ( <<CODE, $result );
# IMP $a1, $a2
set $result, 1.0
eq $a1, $ot1, EQ_${eqnum}_end
ne $a2, $ot2, EQ_${eqnum}_end
set $result, 0.0
EQ_${eqnum}_end: noop
CODE
},
'.' => "NULL",
'mod' => sub {
my ( $a1, $a2, $result ) = @_;
return ( <<CODE, $result );
cmod $result, $a2, $a1
CODE
},
'^' => "POW",
);
%opsubs = (
%opsubs,
'<=' => sub { &{ $opsubs{"="} }( @_[ 0 .. 2 ], "le" ) },
'>=' => sub { &{ $opsubs{"="} }( @_[ 0 .. 2 ], "ge" ) },
'<>' => sub { &{ $opsubs{"="} }( @_[ 0 .. 2 ], "ne" ) },
'<' => sub { &{ $opsubs{"="} }( @_[ 0 .. 2 ], "lt" ) },
'>' => sub { &{ $opsubs{"="} }( @_[ 0 .. 2 ], "gt" ) }
);
sub convert_to_rpn {
my (@expr) = @_;
#print STDERR "In RPN Convert...\n";
# Convert to RPN
my ( @stack, @stream );
my $i = -1;
foreach my $item (@expr) {
die "Expression too complex at line $sourceline" if $i++ > 100; # Arbitrary.
my ( $sym, $type ) = @$item;
#print "Got a $sym...\n";
if ( $sym eq "(" ) {
push @stack, $item;
next;
}
if ( $sym eq ")" ) {
push @stream, pop @stack while ( @stack and $stack[-1]->[0] ne "(" );
pop @stack;
next;
}
if ( $type eq "STRING"
or not precedence( $sym, exists $expr[ $i + 1 ] ? $expr[ $i + 1 ]->[0] : "NOTARR" ) )
{
push @stream, $item; # Operands, etc..
next;
}
#print "It's an op!\n";
$item->[2] = "OP";
if ( !@stack ) {
push @stack, $item;
next;
}
while ( @stack and precedence( $stack[-1]->[0] ) >= precedence( $item->[0] ) ) {
push @stream, pop @stack;
}
push @stack, $item;
}
push @stream, reverse @stack;
#print STDERR "Outta RPN convert\n";
return (@stream);
}
sub fixup {
my (@expr) = @_;
# Do the fixup. Unary minus, functions, etc.
my @foo = @expr;
@expr = ();
for my $t ( 0 .. @foo - 1 ) {
my ( $unary, $argthing ) = ( 0, 0 );
my ( $prev, $this, $next ) = (
( ( $t - 1 >= 0 ) ? $foo[ $t - 1 ] : undef ),
$foo[$t], ( ( $t + 1 <= $#foo ) ? $foo[ $t + 1 ] : undef )
);
if ( $this->[0] eq '-' and $this->[1] eq "PUN" ) {
if ( !defined $prev->[0] or $prev->[0] eq "(" ) {
$unary = 1;
}
elsif ( precedence( $prev->[0], $next->[0] )
and not isarray( $prev->[0] ) )
{
$unary = 1;
}
elsif ( iskeyword( $syms[PREV] ) and not isbuiltin( $syms[PREV] ) ) {
$unary = 1;
}
}
if (
$this->[0] eq "("
and hasargs( $prev->[0] ) # This works, but damned if I know why.
#and $next->[0] ne ")"
)
{
# print "Argthing $prev->[0]\n";
$argthing = 1;
}
if ( $this->[0] eq 'not' and $this->[1] ne "STRING" ) {
push(
@expr, [ "0.0", "INT" ], # Cheating, making not a binary op
[ "not", "PUN" ]
);
next;
}
if ($unary) {
push( @expr, [ "-1.0", "INT" ], [ "*", "PUN" ] );
next;
}
# Sadly, IMCC wants INTs to be INTs.
if ( $this->[1] eq "INT" ) {
$this->[0] .= ".0";
}
if ( $this->[1] eq "BARE" ) {
$this->[0] = changename( $this->[0] );
}
push( @expr, $foo[$t] );
# Functions, array lookups, and builtins are converted
# from a(b,d)
# to a(,b,d)
# and commas become a low-precedence unary operator that means
# "Push the top of the stack onto the function's call stack"
# No-arg funcs are simply left alone.
if ($argthing) {
push( @expr, [ "STARTARG", "STARTARG" ] );
}
}
return (@expr);
}
sub get_expression {
my (%opts) = @_;
my $parens;
my @expr;
goto PROCEXP_NOFEED if $opts{lhs};
goto PROCEXP_NOFEED if $opts{nofeed};
feedme();
PROCEXP_NOFEED:
while (1) {
$parens++ if ( $syms[CURR] eq "(" );
$parens-- if ( $syms[CURR] eq ")" );
#print "Read $syms[CURR]...";
last if ( not $parens
and $syms[CURR] eq "="
and $opts{lhs} );
#print "ok\n";
last
if (
$type[CURR] eq "STMT"
or $type[CURR] eq "COMP"
or $type[CURR] eq "COMM"
or (
$type[CURR] eq "BARE"
and ( iskeyword( $syms[CURR] )
and !isbuiltin( $syms[CURR] ) )
)
);
last
if (not $parens
and not $opts{ignorecomma}
and ( $syms[CURR] eq ',' and $type[CURR] ne "STRING" ) );
last if ( $syms[CURR] eq ';' );
push( @expr, [ $syms[CURR], $type[CURR] ] );
if ( ( isbuiltin( $syms[CURR] ) or isuserfunc( $syms[CURR] ) )
and $syms[NEXT] ne "("
and $type[CURR] ne "STRING" )
{
push( @expr, [ "(", "PUN" ] ); # Make sure no-arg funcs have at
push( @expr, [ ")", "PUN" ] ); # least token parenthesis...
}
feedme();
}
barf();
$currentexpr = join( ' ', map { $_->[0] } @expr );
return (@expr);
}
sub pushthing {
my ( $code, $optype, $sym, $type, $oldresult ) = @_;
my $ts = "INVALID";
if ( $type ne "RESULT" ) {
if ( $type =~ /STRING|INT|FLO|BARE/ ) {
$$optype = "N";
if ( $type =~ /STRING/ ) {
$$optype = "S";
$sym = qq{"$sym"};
}
if ( $type =~ /BARE/ ) {
if ( $sym =~ s/\$$/_string/ ) {
$$optype = "S";
}
else {
$$optype = "N";
}
$main::code{$main::seg}->{declarations}->{$sym} = 1
unless $main::code{$main::seg}->{declarations}->{$sym};
}
return $sym;
}
elsif ( $type eq "STARTARG" ) {
return;
}
else {
die "Bad type for $sym? in expression '$currentexpr'";
}
}
else {
return $oldresult;
}
}
sub pushargs {
my ( $code, $optype, $work ) = @_;
return unless @$work;
my @args = ();
while ( $$work[-1]->[0] ne "STARTARG" ) {
my $item = pop @$work;
my $a1 = pushthing( $code, $optype, @$item );
push @args, [ $a1, @$item ];
}
#foreach(@args) {
#push @$code, qq{\t.arg $_->[0]\t\t# $_->[0]};
#}
pop @$work; # REmove startarg tag...
return ( scalar @args, @args );
}
sub optype_of {
my ( $func, $extra ) = @_;
if ( $extra and $extra->[2] eq "STRING" ) {
return "S";
}
if ( $func =~ /\$$/ ) {
return "S";
}
else {
return "N";
}
}
sub generate_code { # Will return a result register, or something.
my ( $lhs, @stream ) = @_;
my ( @code, @work );
my $oneop = 0;
my $optype = "N";
my $result = "";
foreach my $token (@stream) {
my ( $sym, $type, $op ) = @$token;
#print "Dealing with $sym $type $op\n";
if ( !$op ) {
push @work, $token;
next;
}
next if ( $sym eq "," ); # Commas get ignored, args to stack
my ( $ac, @args, $extern, $pir_args );
if ( isarray($sym) and $lhs ) {
( $ac, @args ) = pushargs( \@code, \$optype, \@work );
$pir_args = join( ",", map { $_->[0] } ( reverse @args ) );
$pir_args = ",$pir_args" if $pir_args;
$extern = $sym;
$optype = optype_of($extern);
goto NEST_ARRAY_ASSIGN if (@work); # Ugly, yeah sue me.
push @code, qq{\t_ARRAY_ASSIGN("$extern$seg",INSERT NEW VALUE HERE,$ac$pir_args)};
return ( "~Array", "$optype", @code );
}
elsif ( hasargs($sym) ) {
( $ac, @args ) = pushargs( \@code, \$optype, \@work );
$pir_args = join( ",", map { $_->[0] } ( reverse @args ) );
$pir_args = ",$pir_args" if $pir_args;
$extern = $sym;
$optype = optype_of($extern);
my ( $calling_code, @return_params );
if ( isarray($sym) ) {
NEST_ARRAY_ASSIGN:
if ( $ac == 0 ) {
$optype = "P";
}
push @code,
qq{\t\$$optype$retcount = _ARRAY_LOOKUP_$optype("$extern$seg",$ac$pir_args)};
push @work, [ "result of $extern()", "RESULT", "\$$optype$retcount" ];
}
elsif ( isbuiltin($sym) ) {
$extern =~ s/\$/_string/g;
$extern =~ tr/a-z/A-Z/;
push @code, qq{\$$optype$retcount = _BUILTIN_$extern($ac$pir_args)};
push @work, [ "result of $extern()", "RESULT", "\$$optype$retcount" ];
}
else {
$extern =~ s/\$/_string/g;
$extern =~ tr/a-z/A-Z/;
$calling_code = "(%s) = _USERFUNC_${extern}_run($ac$pir_args)";
push @work, [ "result of $extern()", "RESULT", "\$$optype$retcount" ];
$retcount++;
# External functions return their arguments,
# except for PMC types. Figure if you want to locally
# modify those, go ahead. This simulates pass-by-reference.
foreach my $arg (@args) {
next if $arg->[0] =~ /^\$P\d+$/;
if ( $arg->[2] eq "BARE" ) {
push @return_params, $arg->[0];
}
else {
push @return_params, "\$" . optype_of( $arg->[0], $arg ) . $retcount++;
}
}
if (@return_params) {
push @code, sprintf( $calling_code, join( ",", @return_params ) );
}
else {
push @code, sprintf( $calling_code, '' );
}
}
$retcount++;
}
else {
my ( $op1, $op2 ) = ( pop @work, pop @work );
my ( $a1, $a2, $ot1, $ot2 );
$ot1 = $ot2 = $optype;
$a1 = pushthing( \@code, \$ot1, @$op1 );
$a2 = pushthing( \@code, \$ot2, @$op2 );
$optype = $ot2;
if ( exists $opsubs{$sym} ) {
if ( !ref $opsubs{$sym} ) {
die "No op code yet for $sym\n";
}
else {
my ( $code, $return ) =
&{ $opsubs{$sym} }( $a1, $a2, "\$$optype$retcount", "", $ot1, $ot2 );
($optype) = $return =~ /([N|S])/;
push @code, $code;
}
}
else {
die "Op $sym not implemented?";
}
push @work, [ "($op1->[0] $sym $op2->[0])", "RESULT", "\$$optype$retcount" ];
$retcount++;
}
}
if (@work) {
$_ = pop @work;
$result = pushthing( \@code, \$optype, @$_ );
}
return ( $result, $optype, @code );
}
sub build_assignment {
my ( $left, $leftexpr, $right, $rightexpr, $righttype ) = @_;
my (@ass);
if ( $left =~ /^\w+$/ ) {
if ( $left =~ /(_percent|_amp)$/ ) {
my $ti = "\$I" . ++$retcount;
my $tn = "\$N" . ++$retcount;
@ass =
( @$rightexpr, "\tset $ti, $right\t# Truncate", "\tset $tn, $ti", "\t$left = $tn",
);
}
else {
# Simple a=expr case.
@ass = (
@$rightexpr,
"\t$left = $right",
);
}
}
else {
s/INSERT NEW VALUE HERE/$right/g for @$leftexpr;
s/--TYPE--/$righttype/g for @$leftexpr;
@ass = ( @$rightexpr, @$leftexpr, );
}
return @ass;
}
sub EXPRESSION {
my (%opts);
%opts = %{ $_[0] } if @_;
my ( @expr, @stream, @left, $whole );
my ( $assignto, $result );
$whole = "";
$retcount = 0;
my $type = "";
if ( $opts{assign} ) {
#print STDERR "Assign\n";
$opts{lhs} = 1;
@expr = get_expression(%opts); # Get expression tokens
$whole .= join( ' ', map { $_->[0] } @expr );
@expr = fixup(@expr); # Repair unary -, functions, etc...
@stream = convert_to_rpn(@expr); # Get infix into RPN
( $assignto, $type, @left ) =
generate_code( $opts{lhs}, @stream ); # Generate PASM code stream
feedme(); # Eat the =
$whole .= " = ";
$opts{lhs} = 0;
@expr = get_expression(%opts); # Get expression tokens
$whole .= join( ' ', map { $_->[0] } @expr );
@expr = fixup(@expr); # Repair unary -, functions, etc...
@stream = convert_to_rpn(@expr); # Get infix into RPN
( $result, $type, @stream ) = generate_code( 0, @stream ); # Generate PASM code stream
@stream = build_assignment( $assignto, \@left, $result, \@stream, $type );
$result = $assignto;
}
elsif ( $opts{stuff} ) {
#print STDERR "Stuff\n";
$opts{lhs} = 1;
feedme();
# Do the left-hand side
@expr = get_expression(%opts); # Get expression tokens
#print STDERR Dumper(\@expr);
$whole .= join( ' ', map { $_->[0] } @expr );
@expr = fixup(@expr); # Repair unary -, functions, etc...
@stream = convert_to_rpn(@expr); # Get infix into RPN
#print STDERR "Stream:", join(' ', map { $_->[0] } @stream), "\n";
( $assignto, $type, @left ) =
generate_code( $opts{lhs}, @stream ); # Generate PASM code stream
#print STDERR "Left: @left \n";
if ( $opts{choose} ) {
$opts{stuff} =~ s/X/$type/g;
}
# The rhs was passed in
@stream = build_assignment( $assignto, \@left, $opts{stuff}, [], $type );
$result = $assignto;
}
else {
#print STDERR "Extract\n";
@expr = get_expression(%opts); # Get expression tokens
$whole .= join( ' ', map { $_->[0] } @expr );
@expr = fixup(@expr); # Repair unary -, functions, etc...
@stream = convert_to_rpn(@expr); # Get infix into RPN
( $result, $type, @stream ) = generate_code( 0, @stream ); # Generate PASM code stream
}
s/$/\n/ for @stream;
@stream =
( "\t#\n", "\t# Evaluating $whole\n", "\t# Result in $result of type $type\n", @stream );
return ( $result, $type, @stream );
}
sub changename {
my ($name) = @_;
my %lookup = (
'#' => "_hash",
'!' => "",
'&' => "_amp",
'%' => "_percent",
);
$name =~ s/(%|!|\#|&)$/$lookup{$1}/e;
$name =~ tr/A-Z/a-z/;
return $name;
}
1;
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
syntax highlighted by Code2HTML, v. 0.9.1