languages/BASIC/compiler/COMP_expressions.pm

   1 #! perl
   2
   3 # Copyright (C) 2003-2007, The Perl Foundation.
   4 # $Id$
   5
   6 use subs qw(fetchvar);
   7 use vars qw(@builtins @keywords);
   8
   9 my $retcount = 200;
  10 my $currentexpr;
  11
  12 @builtins = qw(   abs             asc             atn
  13     cdbl            chr$            cint
  14     clng            command$        cos
  15     csng            csrlin          cvd
  16     cvdmbf          cvi             cbl
  17     cvs             cvsmbf          date$
  18     environ$        eof             erdev
  19     erdev$          erl             err
  20     exp             fileattr        fix
  21     fre             freefile        hex$
  22     inkey$
  23     space_NOTYET$
  24     time_NOTYET$
  25     inp             input$
  26     instr           int             ioctl$
  27     lbound lcase$ left$ len loc lof log lpos ltrim$
  28     mid$ mkd$ mkdmbf$ mki$ mkl$ mks$ mksmbf$
  29     peek pen play pmap point pos
  30     right$ rnd rtrim$
  31     sadd screen seek setmem sgn sin spc sqr
  32     stick str$ strig string$
  33     tab$ tan timer
  34     ubound ucase$ val varptr varptr$ varseg
  35 );
  36 @keywords = qw(   access alias any append as
  37     base beep binary bload bsave byval
  38     call calls absolute interrupt base chain circle clear
  39     close cls color com common const
  40     data declare def fn seg defdbl defint deflng defsng defstr
  41     dim do loop double draw
  42     else elseif end endif environ erase error exit
  43     field files for next function
  44     get gosub goto
  45     if then input integer ioctl is
  46     key kill
  47     let line input list local locate lock unlock long loop
  48     lprint lset
  49     mid$ mkdir
  50     name next
  51     off on com error key pen play strig timer gosub goto com
  52     option base out open
  53     paint palette pcopy pen play poke preset print using
  54     pset put
  55     random randomize read redim rem reset restore resume
  56     return rmdir rset run
  57     screen seek select case shared shell single sleep
  58     sound static stop sub swap system step
  59     then
  60     time_NOTYET$
  61     timer troff tron type to
  62     uevent unlock until using
  63     view
  64     wait while wend width window write
  65     keys
  66 );
  67
  68 sub dumpq {
  69     print "Upcoming: $type[0] $syms[0]\n";
  70     print "Current : $type[1] $syms[1]\n";
  71     print "Previous: $type[2] $syms[2]\n";
  72 }
  73
  74 sub isbuiltin {    # Built in functions
  75     return 0 unless defined $_[0];
  76     return 1 if ( grep /^\Q$_[0]\E$/i, @builtins );
  77     return 0;
  78 }
  79
  80 sub isuserfunc {
  81
  82     #       print "Isuserfunc $_[0] and $funcname..";
  83     return 0 unless defined $_[0];
  84     return 0 if $funcname and $funcname eq $_[0];    # We're processing this, don't count!
  85     if ( grep /^\Q$_[0]\E$/i, keys %functions ) {
  86
  87         #               print "Yes\n";
  88         return 1;
  89     }
  90
  91     #       print "No\n";
  92     return 0;
  93 }
  94
  95 sub isarray {
  96
  97     #print STDERR "Looking up $_[0]$seg...\n";
  98     $_ = ( grep /^\Q$_[0]$seg\E$/i, keys %arrays );
  99
 100     #print "$_\n";
 101     return $_;
 102 }
 103
 104 sub hasargs {
 105     return ( isbuiltin( $_[0] ) or isuserfunc( $_[0] ) or isarray( $_[0] ) );
 106 }
 107
 108 sub iskeyword {
 109     return 1 if ( grep /^\Q$_[0]\E$/i, @keywords );
 110     return 0;
 111 }
 112
 113 sub precedence {
 114     my ( $op, $next ) = @_;
 115
 116     #print STDERR "Precedence with '$op' and '$next'\n";
 117
 118     return 5  if ( $op eq "and" );
 119     return 5  if ( $op eq "eqv" );
 120     return 5  if ( $op eq "imp" );
 121     return 5  if ( $op eq "or" );
 122     return 5  if ( $op eq "xor" );
 123     return 7  if ( $op eq "not" );
 124     return 10 if ( $op eq "=" );
 125     return 10 if ( $op eq ">=" );
 126     return 10 if ( $op eq "<=" );
 127     return 10 if ( $op eq "<>" );
 128     return 10 if ( $op eq ">" );
 129     return 10 if ( $op eq "<" );
 130     return 15 if ( $op eq "," );
 131     return 20 if ( $op eq "+" );
 132     return 20 if ( $op eq "-" );
 133     return 30 if ( $op eq "mod" );
 134     return 40 if ( $op eq '\\' );
 135     return 50 if ( $op eq "*" );
 136     return 50 if ( $op eq "/" );
 137     return 60 if ( $op eq "^" );
 138     return 70 if ( $op eq "." );
 139
 140     return 99 if ( $op eq "UNARYMINUS" );
 141
 142     return 100 if ( isbuiltin $op);
 143     return 100 if ( isuserfunc $op);
 144     return 100 if ( isarray $op
 145         and ( ( $next and $next eq "(" ) or !$next ) );
 146
 147     return 0;    # Not an operator
 148
 149 }
 150
 151 sub false {
 152     my ($type) = @_;
 153     if ( $type eq "N" ) {
 154         return "0.0";
 155     }
 156     else {
 157         return qq{""};
 158     }
 159 }
 160 my $eqnum  = 0;
 161 my %opsubs = (
 162     '+' => sub {
 163         my ( $a1, $a2, $result ) = @_;
 164         if ( $result =~ /S/ ) {
 165             return ( "\tconcat $result, $a2, $a1", $result );
 166         }
 167         else {
 168             return ( "\t$result = $a1 + $a2", $result );
 169         }
 170     },
 171     '-' => sub {
 172         return ( "\t$_[2] = $_[1] - $_[0]", $_[2] );
 173     },
 174     '*' => sub {
 175         return ( "\t$_[2] = $_[0] * $_[1]", $_[2] );
 176     },
 177     '/' => sub {
 178         return ( "\t$_[2] = $_[1] / $_[0]", $_[2] );
 179     },
 180     '=' => sub {
 181         my ( $a1, $a2, $result, $op ) = @_;
 182         $op = "eq" unless $op;
 183         $result =~ s/S/N/;
 184         $eqnum++;
 185         return ( <<CODE, $result );
 186         set $result, 1.0
 187         $op $a2, $a1, EQ_$eqnum
 188         set $result, 0.0
 189 EQ_$eqnum: noop
 190 CODE
 191     },
 192     'and' => sub {
 193         my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
 194         $result =~ s/S/N/;
 195         $eqnum++;
 196         $ot1 = false($ot1);
 197         $ot2 = false($ot2);
 198         return ( <<CODE, $result );
 199         set $result, 0.0
 200         eq $a1, $ot1, EQ_$eqnum
 201         eq $a2, $ot2, EQ_$eqnum
 202         set $result, 1.0
 203 EQ_$eqnum: noop
 204 CODE
 205     },
 206     'or' => sub {
 207         my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
 208         $result =~ s/S/N/;
 209         $eqnum++;
 210         $ot1 = false($ot1);
 211         $ot2 = false($ot2);
 212         return ( <<CODE, $result );
 213         # OR $a1, $a2
 214         set $result, 0.0
 215         ne $a1, $ot1, EQ_$eqnum
 216         ne $a2, $ot2, EQ_$eqnum
 217         branch EQ_${eqnum}_false
 218 EQ_$eqnum: set $result, 1.0
 219 EQ_${eqnum}_false: noop
 220 CODE
 221     },
 222     'not' => sub {
 223         my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
 224         $result =~ s/S/N/;
 225         $eqnum++;
 226         $ot1 = false($ot1);
 227         return ( <<CODE, $result );
 228         # FIXME
 229         eq $a1, $ot1, TRUE_${eqnum}
 230         set $result, 0.0
 231         branch NOT_${eqnum}
 232 TRUE_${eqnum}: set $result, 1.0
 233 NOT_${eqnum}: noop
 234 CODE
 235         die "$a1,$a2,$result,$op,$ot1,$ot2\n";
 236     },
 237     'xor' => sub {
 238         my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
 239         $result =~ s/S/N/;
 240         $eqnum++;
 241         $ot1 = false($ot1);
 242         $ot2 = false($ot2);
 243         return ( <<CODE, $result );
 244         # XOR $a1, $a2
 245         set $result, 0.0
 246         eq $a1, $ot1, EQ_${eqnum}_a
 247         inc $result
 248 EQ_${eqnum}_a:
 249         eq $a2, $ot2, EQ_$eqnum
 250         inc $result
 251 EQ_$eqnum: ne $result, 2.0, EQ_${eqnum}_end
 252         set $result, 0.0
 253 EQ_${eqnum}_end: noop
 254 CODE
 255     },
 256     'eqv' => sub {
 257         my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
 258         $result =~ s/S/N/;
 259         $eqnum++;
 260         $ot1 = false($ot1);
 261         $ot2 = false($ot2);
 262         return ( <<CODE, $result );
 263         # EQV $a1, $a2
 264         set $result, 0.0
 265         eq $a1, $ot1, EQ_${eqnum}_a
 266         inc $result
 267 EQ_${eqnum}_a:
 268         eq $a2, $ot2, EQ_$eqnum
 269         dec $result
 270 EQ_$eqnum: eq $result, 0.0, EQ_${eqnum}_ok
 271         set $result, 0.0
 272         branch EQ_${eqnum}_end
 273 EQ_${eqnum}_ok: set $result, 1.0
 274 EQ_${eqnum}_end: noop
 275 CODE
 276     },
 277     'imp' => sub {
 278         my ( $a1, $a2, $result, $op, $ot1, $ot2 ) = @_;
 279         $result =~ s/S/N/;
 280         $eqnum++;
 281         $ot1 = false($ot1);
 282         $ot2 = false($ot2);
 283         ( $a1, $a2, $ot1, $ot2 ) = ( $a2, $a1, $ot2, $ot1 );
 284         return ( <<CODE, $result );
 285         # IMP $a1, $a2
 286         set $result, 1.0
 287         eq $a1, $ot1, EQ_${eqnum}_end
 288         ne $a2, $ot2, EQ_${eqnum}_end
 289         set $result, 0.0
 290 EQ_${eqnum}_end: noop
 291 CODE
 292     },
 293     '.'   => "NULL",
 294     'mod' => sub {
 295         my ( $a1, $a2, $result ) = @_;
 296         return ( <<CODE, $result );
 297         cmod $result, $a2, $a1
 298 CODE
 299     },
 300     '^' => "POW",
 301 );
 302 %opsubs = (
 303     %opsubs,
 304     '<=' => sub { &{ $opsubs{"="} }( @_[ 0 .. 2 ], "le" ) },
 305     '>=' => sub { &{ $opsubs{"="} }( @_[ 0 .. 2 ], "ge" ) },
 306     '<>' => sub { &{ $opsubs{"="} }( @_[ 0 .. 2 ], "ne" ) },
 307     '<'  => sub { &{ $opsubs{"="} }( @_[ 0 .. 2 ], "lt" ) },
 308     '>'  => sub { &{ $opsubs{"="} }( @_[ 0 .. 2 ], "gt" ) }
 309 );
 310
 311 sub convert_to_rpn {
 312     my (@expr) = @_;
 313
 314     #print STDERR "In RPN Convert...\n";
 315     # Convert to RPN
 316     my ( @stack, @stream );
 317     my $i = -1;
 318     foreach my $item (@expr) {
 319         die "Expression too complex at line $sourceline" if $i++ > 100;    # Arbitrary.
 320         my ( $sym, $type ) = @$item;
 321
 322         #print "Got a $sym...\n";
 323         if ( $sym eq "(" ) {
 324             push @stack, $item;
 325             next;
 326         }
 327         if ( $sym eq ")" ) {
 328             push @stream, pop @stack while ( @stack and $stack[-1]->[0] ne "(" );
 329             pop @stack;
 330             next;
 331         }
 332
 333         if ( $type eq "STRING"
 334             or not precedence( $sym, exists $expr[ $i + 1 ] ? $expr[ $i + 1 ]->[0] : "NOTARR" ) )
 335         {
 336             push @stream, $item;    # Operands, etc..
 337             next;
 338         }
 339
 340         #print "It's an op!\n";
 341         $item->[2] = "OP";
 342         if ( !@stack ) {
 343             push @stack, $item;
 344             next;
 345         }
 346         while ( @stack and precedence( $stack[-1]->[0] ) >= precedence( $item->[0] ) ) {
 347             push @stream, pop @stack;
 348         }
 349         push @stack, $item;
 350
 351     }
 352     push @stream, reverse @stack;
 353
 354     #print STDERR "Outta RPN convert\n";
 355     return (@stream);
 356 }
 357
 358 sub fixup {
 359     my (@expr) = @_;
 360
 361     # Do the fixup.  Unary minus, functions, etc.
 362     my @foo = @expr;
 363     @expr = ();
 364     for my $t ( 0 .. @foo - 1 ) {
 365         my ( $unary, $argthing ) = ( 0, 0 );
 366         my ( $prev, $this, $next ) = (
 367             ( ( $t - 1 >= 0 ) ? $foo[ $t - 1 ] : undef ),
 368             $foo[$t], ( ( $t + 1 <= $#foo ) ? $foo[ $t + 1 ] : undef )
 369         );
 370         if ( $this->[0] eq '-' and $this->[1] eq "PUN" ) {
 371             if ( !defined $prev->[0] or $prev->[0] eq "(" ) {
 372                 $unary = 1;
 373             }
 374             elsif ( precedence( $prev->[0], $next->[0] )
 375                 and not isarray( $prev->[0] ) )
 376             {
 377                 $unary = 1;
 378             }
 379             elsif ( iskeyword( $syms[PREV] ) and not isbuiltin( $syms[PREV] ) ) {
 380                 $unary = 1;
 381             }
 382         }
 383         if (
 384             $this->[0] eq "("
 385             and hasargs( $prev->[0] )    # This works, but damned if I know why.
 386                                          #and $next->[0] ne ")"
 387             )
 388         {
 389
 390             #                       print "Argthing $prev->[0]\n";
 391             $argthing = 1;
 392         }
 393         if ( $this->[0] eq 'not' and $this->[1] ne "STRING" ) {
 394             push(
 395                 @expr, [ "0.0", "INT" ],    # Cheating, making not a binary op
 396                 [ "not", "PUN" ]
 397             );
 398             next;
 399         }
 400
 401         if ($unary) {
 402             push( @expr, [ "-1.0", "INT" ], [ "*", "PUN" ] );
 403             next;
 404         }
 405
 406         # Sadly, IMCC wants INTs to be INTs.
 407         if ( $this->[1] eq "INT" ) {
 408             $this->[0] .= ".0";
 409         }
 410
 411         if ( $this->[1] eq "BARE" ) {
 412             $this->[0] = changename( $this->[0] );
 413         }
 414
 415         push( @expr, $foo[$t] );
 416
 417         # Functions, array lookups, and builtins are converted
 418         # from a(b,d)
 419         # to   a(,b,d)
 420         # and commas become a low-precedence unary operator that means
 421         # "Push the top of the stack onto the function's call stack"
 422         # No-arg funcs are simply left alone.
 423         if ($argthing) {
 424             push( @expr, [ "STARTARG", "STARTARG" ] );
 425         }
 426     }
 427     return (@expr);
 428 }
 429
 430 sub get_expression {
 431     my (%opts) = @_;
 432     my $parens;
 433     my @expr;
 434
 435     goto PROCEXP_NOFEED if $opts{lhs};
 436     goto PROCEXP_NOFEED if $opts{nofeed};
 437     feedme();
 438
 439 PROCEXP_NOFEED:
 440     while (1) {
 441         $parens++ if ( $syms[CURR] eq "(" );
 442         $parens-- if ( $syms[CURR] eq ")" );
 443
 444         #print "Read $syms[CURR]...";
 445         last if ( not $parens
 446             and $syms[CURR] eq "="
 447             and $opts{lhs} );
 448
 449         #print "ok\n";
 450         last
 451             if (
 452                $type[CURR] eq "STMT"
 453             or $type[CURR] eq "COMP"
 454             or $type[CURR] eq "COMM"
 455             or (
 456                 $type[CURR] eq "BARE"
 457                 and ( iskeyword( $syms[CURR] )
 458                     and !isbuiltin( $syms[CURR] ) )
 459             )
 460             );
 461         last
 462             if (not $parens
 463             and not $opts{ignorecomma}
 464             and ( $syms[CURR] eq ',' and $type[CURR] ne "STRING" ) );
 465         last if ( $syms[CURR] eq ';' );
 466         push( @expr, [ $syms[CURR], $type[CURR] ] );
 467         if (    ( isbuiltin( $syms[CURR] ) or isuserfunc( $syms[CURR] ) )
 468             and $syms[NEXT] ne "("
 469             and $type[CURR] ne "STRING" )
 470         {
 471             push( @expr, [ "(", "PUN" ] );    # Make sure no-arg funcs have at
 472             push( @expr, [ ")", "PUN" ] );    # least token parenthesis...
 473         }
 474         feedme();
 475     }
 476     barf();
 477     $currentexpr = join( ' ', map { $_->[0] } @expr );
 478     return (@expr);
 479 }
 480
 481 sub pushthing {
 482     my ( $code, $optype, $sym, $type, $oldresult ) = @_;
 483     my $ts = "INVALID";
 484
 485     if ( $type ne "RESULT" ) {
 486         if ( $type =~ /STRING|INT|FLO|BARE/ ) {
 487             $$optype = "N";
 488             if ( $type =~ /STRING/ ) {
 489                 $$optype = "S";
 490                 $sym     = qq{"$sym"};
 491             }
 492             if ( $type =~ /BARE/ ) {
 493                 if ( $sym =~ s/\$$/_string/ ) {
 494                     $$optype = "S";
 495                 }
 496                 else {
 497                     $$optype = "N";
 498                 }
 499                 $main::code{$main::seg}->{declarations}->{$sym} = 1
 500                     unless $main::code{$main::seg}->{declarations}->{$sym};
 501             }
 502             return $sym;
 503         }
 504         elsif ( $type eq "STARTARG" ) {
 505             return;
 506         }
 507         else {
 508             die "Bad type for $sym? in expression '$currentexpr'";
 509         }
 510     }
 511     else {
 512         return $oldresult;
 513     }
 514 }
 515
 516 sub pushargs {
 517     my ( $code, $optype, $work ) = @_;
 518
 519     return unless @$work;
 520     my @args = ();
 521
 522     while ( $$work[-1]->[0] ne "STARTARG" ) {
 523         my $item = pop @$work;
 524         my $a1 = pushthing( $code, $optype, @$item );
 525         push @args, [ $a1, @$item ];
 526     }
 527
 528     #foreach(@args) {
 529     #push @$code, qq{\t.arg $_->[0]\t\t# $_->[0]};
 530     #}
 531     pop @$work;    # REmove startarg tag...
 532     return ( scalar @args, @args );
 533 }
 534
 535 sub optype_of {
 536     my ( $func, $extra ) = @_;
 537     if ( $extra and $extra->[2] eq "STRING" ) {
 538         return "S";
 539     }
 540     if ( $func =~ /\$$/ ) {
 541         return "S";
 542     }
 543     else {
 544         return "N";
 545     }
 546 }
 547
 548 sub generate_code {    # Will return a result register, or something.
 549     my ( $lhs, @stream ) = @_;
 550     my ( @code, @work );
 551
 552     my $oneop  = 0;
 553     my $optype = "N";
 554     my $result = "";
 555     foreach my $token (@stream) {
 556         my ( $sym, $type, $op ) = @$token;
 557
 558         #print "Dealing with $sym $type $op\n";
 559
 560         if ( !$op ) {
 561             push @work, $token;
 562             next;
 563         }
 564         next if ( $sym eq "," );    # Commas get ignored, args to stack
 565         my ( $ac, @args, $extern, $pir_args );
 566         if ( isarray($sym) and $lhs ) {
 567             ( $ac, @args ) = pushargs( \@code, \$optype, \@work );
 568             $pir_args = join( ",", map { $_->[0] } ( reverse @args ) );
 569             $pir_args = ",$pir_args" if $pir_args;
 570             $extern   = $sym;
 571             $optype   = optype_of($extern);
 572             goto NEST_ARRAY_ASSIGN if (@work);    # Ugly, yeah sue me.
 573             push @code, qq{\t_ARRAY_ASSIGN("$extern$seg",INSERT NEW VALUE HERE,$ac$pir_args)};
 574             return ( "~Array", "$optype", @code );
 575         }
 576         elsif ( hasargs($sym) ) {
 577             ( $ac, @args ) = pushargs( \@code, \$optype, \@work );
 578             $pir_args = join( ",", map { $_->[0] } ( reverse @args ) );
 579             $pir_args = ",$pir_args" if $pir_args;
 580             $extern   = $sym;
 581             $optype   = optype_of($extern);
 582             my ( $calling_code, @return_params );
 583             if ( isarray($sym) ) {
 584             NEST_ARRAY_ASSIGN:
 585                 if ( $ac == 0 ) {
 586                     $optype = "P";
 587                 }
 588                 push @code,
 589                     qq{\t\$$optype$retcount = _ARRAY_LOOKUP_$optype("$extern$seg",$ac$pir_args)};
 590                 push @work, [ "result of $extern()", "RESULT", "\$$optype$retcount" ];
 591             }
 592             elsif ( isbuiltin($sym) ) {
 593                 $extern =~ s/\$/_string/g;
 594                 $extern =~ tr/a-z/A-Z/;
 595                 push @code, qq{\$$optype$retcount = _BUILTIN_$extern($ac$pir_args)};
 596                 push @work, [ "result of $extern()", "RESULT", "\$$optype$retcount" ];
 597             }
 598             else {
 599                 $extern =~ s/\$/_string/g;
 600                 $extern =~ tr/a-z/A-Z/;
 601
 602                 $calling_code = "(%s) = _USERFUNC_${extern}_run($ac$pir_args)";
 603                 push @work, [ "result of $extern()", "RESULT", "\$$optype$retcount" ];
 604                 $retcount++;
 605
 606                 # External functions return their arguments,
 607                 # except for PMC types.  Figure if you want to locally
 608                 # modify those, go ahead.  This simulates pass-by-reference.
 609                 foreach my $arg (@args) {
 610                     next if $arg->[0] =~ /^\$P\d+$/;
 611                     if ( $arg->[2] eq "BARE" ) {
 612                         push @return_params, $arg->[0];
 613                     }
 614                     else {
 615                         push @return_params, "\$" . optype_of( $arg->[0], $arg ) . $retcount++;
 616                     }
 617                 }
 618                 if (@return_params) {
 619                     push @code, sprintf( $calling_code, join( ",", @return_params ) );
 620                 }
 621                 else {
 622                     push @code, sprintf( $calling_code, '' );
 623                 }
 624             }
 625
 626             $retcount++;
 627         }
 628         else {
 629             my ( $op1, $op2 ) = ( pop @work, pop @work );
 630             my ( $a1, $a2, $ot1, $ot2 );
 631             $ot1 = $ot2 = $optype;
 632             $a1 = pushthing( \@code, \$ot1, @$op1 );
 633             $a2 = pushthing( \@code, \$ot2, @$op2 );
 634             $optype = $ot2;
 635             if ( exists $opsubs{$sym} ) {
 636                 if ( !ref $opsubs{$sym} ) {
 637                     die "No op code yet for $sym\n";
 638                 }
 639                 else {
 640                     my ( $code, $return ) =
 641                         &{ $opsubs{$sym} }( $a1, $a2, "\$$optype$retcount", "", $ot1, $ot2 );
 642                     ($optype) = $return =~ /([N|S])/;
 643                     push @code, $code;
 644                 }
 645             }
 646             else {
 647                 die "Op $sym not implemented?";
 648             }
 649             push @work, [ "($op1->[0] $sym $op2->[0])", "RESULT", "\$$optype$retcount" ];
 650             $retcount++;
 651         }
 652     }
 653
 654     if (@work) {
 655         $_ = pop @work;
 656         $result = pushthing( \@code, \$optype, @$_ );
 657     }
 658
 659     return ( $result, $optype, @code );
 660 }
 661
 662 sub build_assignment {
 663     my ( $left, $leftexpr, $right, $rightexpr, $righttype ) = @_;
 664     my (@ass);
 665
 666     if ( $left =~ /^\w+$/ ) {
 667         if ( $left =~ /(_percent|_amp)$/ ) {
 668             my $ti = "\$I" . ++$retcount;
 669             my $tn = "\$N" . ++$retcount;
 670             @ass =
 671                 ( @$rightexpr, "\tset $ti, $right\t# Truncate", "\tset $tn, $ti", "\t$left = $tn",
 672                 );
 673         }
 674         else {
 675
 676             # Simple a=expr case.
 677             @ass = (
 678                 @$rightexpr,
 679                 "\t$left = $right",
 680
 681             );
 682         }
 683     }
 684     else {
 685         s/INSERT NEW VALUE HERE/$right/g for @$leftexpr;
 686         s/--TYPE--/$righttype/g          for @$leftexpr;
 687
 688         @ass = ( @$rightexpr, @$leftexpr, );
 689     }
 690
 691     return @ass;
 692 }
 693
 694 sub EXPRESSION {
 695     my (%opts);
 696     %opts = %{ $_[0] } if @_;
 697     my ( @expr, @stream, @left, $whole );
 698     my ( $assignto, $result );
 699     $whole    = "";
 700     $retcount = 0;
 701     my $type = "";
 702
 703     if ( $opts{assign} ) {
 704
 705         #print STDERR "Assign\n";
 706         $opts{lhs} = 1;
 707         @expr = get_expression(%opts);    # Get expression tokens
 708         $whole .= join( ' ', map { $_->[0] } @expr );
 709         @expr   = fixup(@expr);             # Repair unary -, functions, etc...
 710         @stream = convert_to_rpn(@expr);    # Get infix into RPN
 711         ( $assignto, $type, @left ) =
 712             generate_code( $opts{lhs}, @stream );    # Generate PASM code stream
 713         feedme();                                    # Eat the =
 714         $whole .= " = ";
 715
 716         $opts{lhs} = 0;
 717         @expr      = get_expression(%opts);          # Get expression tokens
 718         $whole .= join( ' ', map { $_->[0] } @expr );
 719         @expr   = fixup(@expr);                      # Repair unary -, functions, etc...
 720         @stream = convert_to_rpn(@expr);             # Get infix into RPN
 721         ( $result, $type, @stream ) = generate_code( 0, @stream );    # Generate PASM code stream
 722
 723         @stream = build_assignment( $assignto, \@left, $result, \@stream, $type );
 724         $result = $assignto;
 725     }
 726     elsif ( $opts{stuff} ) {
 727
 728         #print STDERR "Stuff\n";
 729         $opts{lhs} = 1;
 730         feedme();
 731
 732         # Do the left-hand side
 733         @expr = get_expression(%opts);                                # Get expression tokens
 734                                                                       #print STDERR Dumper(\@expr);
 735         $whole .= join( ' ', map { $_->[0] } @expr );
 736         @expr   = fixup(@expr);             # Repair unary -, functions, etc...
 737         @stream = convert_to_rpn(@expr);    # Get infix into RPN
 738              #print STDERR "Stream:", join(' ', map { $_->[0] } @stream), "\n";
 739         ( $assignto, $type, @left ) =
 740             generate_code( $opts{lhs}, @stream );    # Generate PASM code stream
 741                                                      #print STDERR "Left: @left \n";
 742
 743         if ( $opts{choose} ) {
 744             $opts{stuff} =~ s/X/$type/g;
 745         }
 746
 747         # The rhs was passed in
 748         @stream = build_assignment( $assignto, \@left, $opts{stuff}, [], $type );
 749
 750         $result = $assignto;
 751     }
 752     else {
 753
 754         #print STDERR "Extract\n";
 755         @expr = get_expression(%opts);    # Get expression tokens
 756         $whole .= join( ' ', map { $_->[0] } @expr );
 757         @expr   = fixup(@expr);             # Repair unary -, functions, etc...
 758         @stream = convert_to_rpn(@expr);    # Get infix into RPN
 759         ( $result, $type, @stream ) = generate_code( 0, @stream );    # Generate PASM code stream
 760     }
 761     s/$/\n/ for @stream;
 762     @stream =
 763         ( "\t#\n", "\t# Evaluating   $whole\n", "\t# Result in $result of type $type\n", @stream );
 764     return ( $result, $type, @stream );
 765 }
 766
 767 sub changename {
 768     my ($name) = @_;
 769     my %lookup = (
 770         '#' => "_hash",
 771         '!' => "",
 772         '&' => "_amp",
 773         '%' => "_percent",
 774     );
 775     $name =~ s/(%|!|\#|&)$/$lookup{$1}/e;
 776     $name =~ tr/A-Z/a-z/;
 777     return $name;
 778 }
 779 1;
 780
 781 # Local Variables:
 782 #   mode: cperl
 783 #   cperl-indent-level: 4
 784 #   fill-column: 100
 785 # End:
 786 # vim: expandtab shiftwidth=4: