languages/BASIC/compiler/COMP_parsefuncs.pm

   1 # Aux. functions needed by the parser.  (For cleanliness)
   2 #
   3 # Copyright (C) 2003-2007, The Perl Foundation.
   4 # $Id$
   5
   6 use vars qw( %usertypes );
   7 use vars qw( %arrays );
   8 use vars qw( $funcname $subname );
   9 use vars qw( %labels $branchseq @selects);
  10 use vars qw( @data $sourceline %common );
  11 use vars qw( %code $debug $runtime_jump);
  12
  13 my @fors   = ();
  14 my @whiles = ();
  15 my @dos    = ();
  16 @selects = ();
  17 my $scopes = 0;
  18 my @data   = ();
  19
  20 sub parse_keys {
  21     feedme();
  22     my $targ = $syms[CURR];
  23     feedme();
  24     feedme() while ( $syms[CURR] =~ /[(),]/ );
  25     my $source = $syms[CURR];
  26     feedme();
  27     feedme() while ( $syms[CURR] =~ /[(),]/ );
  28     $targ   .= $seg;
  29     $source .= $seg;
  30     push @{ $code{$seg}->{code} }, <<KEYS;
  31         _ARRAY_KEYS("$source","$targ")
  32 KEYS
  33 }
  34
  35 sub parse_common {
  36     feedme();
  37     while ( $type[CURR] !~ /COMP|COMM|STMT/ ) {
  38         $var = $syms[CURR];
  39         feedme();
  40         next if $var eq ",";
  41         my $array = 0;
  42         if ( $syms[CURR] eq "(" ) {
  43             $array = 1;
  44             while ( $syms[CURR] ne ")" ) {
  45                 feedme;
  46             }
  47             feedme;
  48         }
  49         $var =~ s/\$$/_string/;
  50         push @{ $code{$seg}->{code} }, "\t# $var was declared COMMON\n";
  51         if ( !$array ) {
  52             $main::code{$main::seg}->{declarations}->{$var} = "COMMON";
  53             $common{$var} = 1;
  54         }
  55
  56     }
  57 }
  58
  59 sub parse_shared {    # Keyword only
  60     feedme();
  61     $loop = 0;
  62     while ( $type[CURR] !~ /COMP|COMM|STMT/ ) {
  63         die if $loop++ > 20;
  64         $var = $syms[CURR];
  65         feedme;
  66         my $array = 0;
  67         if ( $syms[CURR] eq "(" ) {
  68             $array = 1;
  69             while ( $syms[CURR] ne ")" ) {
  70                 feedme;
  71             }
  72             feedme;
  73         }
  74         $stype = "";
  75         $user  = 0;
  76         if ( $syms[CURR] eq "as" ) {
  77             feedme;
  78             $stype = $syms[CURR];
  79             feedme;    # N
  80             my %th = (
  81                 single  => 'FLO',
  82                 double  => 'FLO',
  83                 long    => 'INT',
  84                 integer => 'INT',
  85                 string  => 'STRING'
  86             );
  87             if ( exists $th{$stype} ) {
  88                 $stype = $th{$stype};
  89             }
  90             else {
  91                 unless ( exists $usertypes{$stype} ) {
  92                     die "User type $stype not found at source line $sourceline";
  93                 }
  94                 $user = 1;
  95             }
  96         }
  97         unless ($stype) {
  98             $stype = typeof($var);
  99         }
 100         $arrays{$var} = 1 if ($array);
 101
 102         #print "Flagging (assumed) $var as array\n";
 103         if ($array) {
 104             $stype = "ARRAY";
 105         }
 106         else {
 107             $var =~ s/\W$//g;
 108         }
 109
 110         #print "Type: $stype  User: $user Var: $var  Array: $array\n";
 111         if ( $user and !$array ) {
 112             print CODE<<SHARINGU;
 113         # Sharing $stype (user) $var with main
 114         P0= P10[0]
 115         P1= P0["USER"]
 116         P0= P1["$var"]  # Pull the original
 117         P2= P10[I25]
 118         P3= P2["USER"]
 119         P3["$var"]= P0  # Hack in the alias
 120
 121 SHARINGU
 122         }
 123         elsif ( $user and $array ) {
 124
 125             # TODO TODO TODO TODO
 126             print CODE<<SHARING;
 127         # Sharing $stype $var with main  (array=$array)
 128         P0= P10[0]
 129         P1= P0["$stype"]
 130         P0= P1["$var"]  # Pull the original
 131         P2= P10[I25]
 132         P3= P2["$stype"]
 133         P3["$var"]= P0  # Hack in the alias
 134
 135 SHARING
 136         }
 137         else {
 138             print CODE<<SHARING;
 139         # Sharing $stype $var with main  (array=$array)
 140         P0= P10[0]
 141         P1= P0["$stype"]
 142         P0= P1["$var"]  # Pull the original
 143         P2= P10[I25]
 144         P3= P2["$stype"]
 145         P3["$var"]= P0  # Hack in the alias
 146
 147 SHARING
 148         }
 149     }
 150 }
 151
 152 my $inputcounts = 0;
 153
 154 sub input_read_assign {
 155     my ( $prompt, $filedesc, $noreloop ) = @_;
 156     my @values = ();
 157
 158     push @{ $code{$seg}->{code} }, $prompt;
 159     my $sf = 1;
 160     $sf = 0 if ($filedesc);
 161
 162     push @{ $code{$seg}->{code} }, <<INP1;
 163         \$S0 = _READLINE($filedesc)
 164         \$P99 = _SPLITLINE(\$S0,$sf)
 165         \$I0= \$P99
 166 INP1
 167
 168     # Bug here...FIXME.. I'm using $vars before it's set.
 169     $vars = 1;
 170     if ($noreloop) {
 171         push @{ $code{$seg}->{code} }, "\t#ne \$I0, $vars, ERR_INPFIELDS\n";
 172     }
 173     else {
 174         push @{ $code{$seg}->{code} }, "\tne \$I0, $vars, INPUT_$inputcounts  # Re-prompt\n";
 175     }
 176
 177     $loop = 0;
 178     barf();    # We're too far in already...
 179     while ( $type[CURR] !~ /COMP|COMM|STMT/ ) {
 180         die if $loop++ > 20;
 181         push @{ $code{$seg}->{code} }, "\tpop \$S99, \$P99\n";
 182         push @{ $code{$seg}->{code} }, "\t\$N99= \$S99\n";
 183
 184         my ( $result, $type, @code ) = EXPRESSION( { stuff => "\$X99", choose => 1 } );
 185         push @{ $code{$seg}->{code} }, "@code";
 186         feedme();
 187         if ( $syms[CURR] eq "," ) {
 188             feedme();
 189             next;
 190         }
 191     }
 192
 193 }
 194
 195 sub parse_input {
 196     feedme();
 197     my $promptcode = "";
 198     if ( $syms[CURR] eq ";" ) {
 199         feedme();    # Ignore this form for now.
 200     }
 201     if ( $syms[CURR] eq "#" ) {
 202         feedme();
 203         $fd = $syms[CURR];
 204         feedme();
 205         die "Expecting ," unless $syms[CURR] eq ",";
 206         feedme();
 207         input_read_assign( $promptcode, $fd, 'noreprompt' );
 208         return;
 209     }
 210     $promptcode = "INPUT_$inputcounts:\n";
 211
 212     # BASIC is unambiguous here.  The next thing must be a quoted string or
 213     #   no prompting is done.  However, QB says that if no prompt, use " ?"
 214     if ( $type[CURR] eq "STRING" ) {
 215         $promptcode .= qq{\tprint "$syms[CURR]"\n};
 216         feedme();
 217         if ( $syms[CURR] eq "," ) {
 218             $promptcode .= qq{\tnoop  # No ?\n};
 219         }
 220         elsif ( $syms[CURR] eq ";" ) {
 221             $promptcode .= qq{\tprint "?"\n};
 222         }
 223         else {
 224             die "Syntax error, expected ',' or ';'";
 225         }
 226         feedme();
 227     }
 228     else {
 229         $promptcode .= qq{\tprint "? "\n};
 230     }
 231     input_read_assign( $promptcode, 0, 0 );
 232     $inputcounts++;
 233 }
 234
 235 my $ons = 0;
 236
 237 sub parse_on {
 238     my ( $result, $type, @code ) = EXPRESSION;    # The switch...
 239     feedme();
 240     my $branch = $syms[CURR];                     # goto or gosub
 241     push @{ $code{$seg}->{code} }, "\t# On X $branch...\n";
 242     feedme();
 243     $loop  = 0;
 244     @onlab = ();
 245     while ( $type[CURR] !~ /COMP|COMM|STMT/ ) {
 246         die if $loop++ > 255;
 247         if ( $syms[CURR] eq "," ) {
 248             feedme();
 249             next;
 250         }
 251         die "Only labels/numbers allowed" unless ( $type[CURR] =~ /BARE|INT/ );
 252         create_label();
 253         push( @onlab, $syms[CURR] );
 254         feedme();
 255     }
 256     push @{ $code{$seg}->{code} }, <<ON;
 257 @code   lt $result, 0.0, ONERR_${ons}
 258         gt $result, 255.0, ONERR_${ons}
 259         goto ONOK_${ons}
 260 ONERR_${ons}:
 261         print "On...goto/gosub out of range at $sourceline\\n"
 262         _platform_shutdown()
 263         end
 264 ONOK_${ons}:
 265 ON
 266     $i = 1;
 267     for my $jumps (@onlab) {
 268         push @{ $code{$seg}->{code} }, "\tne $result, $i.0, ON_${ons}_$i\n";
 269         if ( $branch eq "gosub" ) {
 270             push @{ $code{$seg}->{code} }, qq{\tbsr $labels{$jumps}\t# $branch $jumps\n};
 271             push @{ $code{$seg}->{code} }, qq{\t#RTJ ne S0, "", RUNTIME_JUMP\n};
 272             push @{ $code{$seg}->{code} }, qq{\tgoto ON_END_$ons\n};
 273         }
 274         elsif ( $branch eq "goto" ) {
 275             push @{ $code{$seg}->{code} }, qq{\tgoto $labels{$jumps}\t# $branch $jumps\n};
 276         }
 277         else {
 278             die "Illegal branch type, only GOSUB/GOTO allowed";
 279         }
 280         push @{ $code{$seg}->{code} }, "ON_${ons}_$i:\n";
 281         $i++;
 282     }
 283     if ( $branch eq "gosub" ) {
 284         push @{ $code{$seg}->{code} }, "\tnoop\nON_END_${ons}:\n";
 285     }
 286     $ons++;
 287 }
 288
 289 sub parse_randomize {
 290     if ( $type[NEXT] =~ /STMT|COMM|COMP/ ) {    # No arg version
 291         feedme();
 292         print CODE<<PROMPTRND;
 293         print "Random-number seed (-32768 to 32767)?"
 294         bsr READLINE
 295         bsr CHOMP
 296         I12= S0
 297 PROMPTRND
 298     }
 299     else {
 300         ( $result, $type, @code ) = EXPRESSION();
 301         push @{ $code{$seg}->{code} }, <<EOR;
 302 @code   find_global \$P0, "RANDSEED"
 303         \$I0= $result
 304         \$P0["value"]= \$I0
 305         store_global "RANDSEED", \$P0
 306 EOR
 307         feedme();
 308     }
 309 }
 310
 311 sub parse_locate {    # locate x,y   | locate x   | locate ,y
 312     my ( $x, $y );
 313     my (@e2);
 314     my ( $resulty, $typey, @codey );
 315     my ( $resultx, $typex, @codex );
 316     if ( $type[NEXT] =~ /PUN/ ) {    # Y only
 317         feedme();
 318         ( $resulty, $typey, @codey ) = EXPRESSION();    # Y (only)
 319     }
 320     else {
 321         ( $resultx, $typex, @codex ) = EXPRESSION();    # X
 322         if ( $type[NEXT] =~ /PUN/ ) {
 323             feedme();
 324             ( $resulty, $typey, @codey ) = EXPRESSION();
 325         }
 326     }
 327     if ( @codey and @codex ) {                          # X and Y
 328
 329         push @{ $code{$seg}->{code} }, <<XANDY;
 330 @codey
 331         \$N100= $resulty
 332 @codex
 333         \$N101= $resultx
 334         _screen_locate(\$N101,\$N100)
 335 XANDY
 336     }
 337     elsif ( @codey and not @codex ) {
 338         push @{ $code{$seg}->{code} }, <<YNOTX;
 339 @codey  noop                    # Broke!
 340         _screen_locate($resulty)
 341 YNOTX
 342     }
 343     elsif ( @codex and not @codey ) {
 344         push @{ $code{$seg}->{code} }, <<XNOTY;
 345 @codex  noop            # Broke!
 346         _screen_locate($resultx)
 347 XNOTY
 348     }
 349 }
 350
 351 sub parse_color {
 352     my ( $f,       $b );
 353     my ( $resultb, $typeb, @codeb );
 354     my ( $resultf, $typef, @codef );
 355
 356     if ( $type[NEXT] =~ /PUN/ ) {    # Back only
 357         feedme();
 358         ( $resultb, $typeb, @codeb ) = EXPRESSION();    # Back (only)
 359     }
 360     else {
 361         ( $resultf, $typef, @codef ) = EXPRESSION();    # Fore
 362         if ( $type[NEXT] =~ /PUN/ ) {
 363             feedme();
 364             ( $resultb, $typeb, @codeb ) = EXPRESSION();
 365         }
 366     }
 367     if ( @codeb and @codef ) {                          # F and B
 368         push @{ $code{$seg}->{code} }, <<FANDB;
 369 @codeb  \$N100= $resultb
 370 @codef  \$N101= $resultf
 371         _screen_color(\$N101,\$N100)
 372 FANDB
 373     }
 374     elsif ( @codeb and not @codef ) {
 375         push @{ $code{$seg}->{code} }, <<BNOTF;
 376 @codeb  noop
 377         _screen_color($resultb) # Broke!
 378 BNOTF
 379     }
 380     elsif ( @codef and not @codeb ) {
 381         push @{ $code{$seg}->{code} }, <<FNOTB;
 382 @codef  noop
 383         _screen_color($resultf) # Broke!
 384 FNOTB
 385     }
 386 }
 387
 388 sub parse_cls {
 389     if ( !$type[NEXT] =~ /STMT|COMM|COMP/ ) {    # No arg version
 390         @e = EXPRESSION();
 391     }
 392     push @{ $code{$seg}->{code} }, <<CLS;
 393         _screen_clear()
 394 CLS
 395     feedme();
 396 }
 397
 398 sub parse_open {
 399     ( $result, $type, @code ) = EXPRESSION();
 400     feedme();
 401     die "Expecting FOR at $sourceline" unless $syms[CURR] eq "for";
 402     feedme();
 403     my $mode = "";
 404     if ( $syms[CURR] eq "input" ) {
 405         $mode = "<";
 406     }
 407     elsif ( $syms[CURR] eq "output" ) {
 408         $mode = ">";
 409     }
 410     elsif ( $syms[CURR] eq "random" ) {
 411         die "random file i/o not implemented yet at $sourceline";
 412     }
 413     else {
 414         die "Expected input/output/random at $sourceline";
 415     }
 416     feedme();
 417     die "Expecting AS" unless $syms[CURR] eq "as";
 418     feedme();
 419     die "Expecting #" unless $syms[CURR] eq "#";
 420     feedme();
 421     $fd = $syms[CURR];
 422     push @{ $code{$seg}->{code} }, <<OPEN;
 423 @code   noop
 424         _OPEN($result,"$mode",$fd)
 425 OPEN
 426 }
 427
 428 sub parse_close {
 429     feedme();
 430     die "Expecting # at $sourceline" unless $syms[CURR] eq "#";
 431     feedme();
 432     $fd = $syms[CURR];
 433     push @{ $code{$seg}->{code} }, <<CLOSE;
 434         _CLOSE($fd)
 435 CLOSE
 436 }
 437
 438 sub fdprint {
 439     my ( $fd, $string ) = @_;
 440     if ($fd) {
 441         push @{ $code{$seg}->{code} }, <<PRINT;
 442         _WRITE($fd,1,"$string")
 443 PRINT
 444     }
 445     else {
 446         if ( $string ne "\\n" ) {
 447             push @{ $code{$seg}->{code} }, <<PRINT;
 448         _BUILTIN_DISPLAY(1,"$string")
 449 PRINT
 450         }
 451         else {
 452             push @{ $code{$seg}->{code} }, <<PRINT;
 453         find_global \$P0, "PRINTCOL"
 454         \$P0["value"]=0
 455         store_global "PRINTCOL", \$P0
 456         print "\\n"
 457 PRINT
 458         }
 459     }
 460
 461 }
 462
 463 sub parse_print {
 464     my $eol  = 0;
 465     my $expr = 0;
 466     my $c    = 0;
 467     my $fd   = "";
 468     my ( $result, $type, @CODE );
 469     feedme();
 470     if ( $syms[CURR] eq "#" and $type[CURR] eq "PUN" ) {
 471         feedme();
 472         $fd = $syms[CURR];
 473         feedme();
 474         feedme();
 475     }
 476     if ( $syms[CURR] eq "using" ) {
 477         print "WARNING: PRINT USING not yet supported\n";
 478         feedme();    # "####"
 479         feedme();    # ;
 480     }
 481     while (1) {
 482         if ( $type[CURR] eq "STMT" or $type[CURR] eq "COMP" or $type[CURR] eq "COMM" ) {
 483             last;
 484         }
 485         last if ( iskeyword( $syms[CURR] ) and not isbuiltin( $syms[CURR] ) );
 486         die "LOOP" if $c++ > 100;
 487         if (    $type[CURR] eq "STRING"
 488             and not $fd
 489             and ( $type[NEXT] eq "STMT" or $type[NEXT] eq "COMP" or $type[NEXT] eq "COMM" ) )
 490         {
 491             $eol = 0;
 492             fdprint( $fd, $syms[CURR] );
 493             feedme();
 494             $expr = 1;
 495             next;
 496         }
 497         if ( $syms[CURR] eq ";" ) {
 498             $eol = 1;
 499             feedme();
 500             $expr = 0;
 501             next;
 502         }
 503         if ( $syms[CURR] eq "," ) {
 504             fdprint( $fd, "\\t" );
 505             $eol = 1;
 506             feedme();
 507             $expr = 0;
 508             next;
 509         }
 510         last if $expr;
 511         ( $result, $type, @code ) = EXPRESSION( { nofeed => 1 } );
 512         feedme();
 513         if ($fd) {
 514             push @{ $code{$seg}->{code} }, <<PRINT;
 515 @code   noop
 516         _WRITE($fd,1,$result)
 517 PRINT
 518         }
 519         else {
 520             push @{ $code{$seg}->{code} }, <<PRINT;
 521 @code   noop
 522         _BUILTIN_DISPLAY(1,$result)
 523 PRINT
 524         }
 525
 526         #print "After Expression have $type[CURR] $syms[CURR]\n";
 527         $eol  = 0;
 528         $expr = 1;
 529         next;
 530     }
 531     unless ($eol) {
 532         fdprint( $fd, "\\n" );
 533     }
 534     barf();
 535 }
 536
 537 sub parse_read {
 538     while ( $type[CURR] !~ /COMP|COMM|STMT/ ) {
 539         push @{ $code{$seg}->{code} }, <<EOASS;
 540         \$S99 = _READ()
 541         \$N99= \$S99
 542 EOASS
 543         ( $result, $type, @code ) = EXPRESSION( { stuff => '$X99', choose => 1 } );
 544         feedme();
 545         push @{ $code{$seg}->{code} }, <<EOASS;
 546 @code
 547 EOASS
 548         if ( $syms[CURR] eq "," ) {
 549
 550             #feedme();
 551             next;
 552         }
 553     }
 554 }
 555
 556 sub parse_swap {
 557     my ( @f, @s );
 558     feedme();
 559     my ( $leftres, $lefttype, @left ) = EXPRESSION( { lhs => 1 } );
 560     feedme();
 561     die "Expected ',': $syms[CURR]" unless $syms[CURR] eq ",";
 562     feedme();
 563     my ( $rightres, $righttype, @right ) = EXPRESSION( { lhs => 1 } );
 564     push @{ $code{$seg}->{code} }, <<SWAP;
 565         \$${righttype}99 = $rightres
 566         $rightres = $leftres
 567         $leftres = \$${righttype}99
 568 SWAP
 569 }
 570
 571 sub parse_stop {
 572     feedme();
 573     print CODE<<STOP;
 574         print "Stopped at source line "
 575         print I11
 576         print "\\n"
 577         _platform_shutdown()
 578         end
 579 STOP
 580 }
 581
 582 sub parse_data {
 583     my ($currline) = @_;
 584     $currline = "" unless defined $currline;
 585     my @ld = ();
 586     feedme();
 587 OUTDATA: while ( $type[CURR] !~ /COMP|COMM|STMT/ ) {
 588         if ( $syms[CURR] eq "," ) {
 589             feedme();
 590             next;
 591         }
 592         if ( $type[CURR] eq "PUN" and $syms[CURR] =~ /-/ ) {
 593             if ( $type[NEXT] =~ /INT|FLO/ ) {
 594                 feedme();
 595                 $syms[CURR] = "-$syms[CURR]";
 596             }
 597         }
 598         if ( $type[CURR] =~ /STRING|BARE|INT|FLO/ ) {
 599             push @ld, { type => "STRING", value => qq{"$syms[CURR]"} };
 600         }
 601         elsif ( $type[CURR] eq "PUN" ) {
 602             my $s = $syms[CURR];
 603             while (1) {
 604                 feedme();
 605                 if ( $syms[CURR] eq "," ) {
 606                     push @ld, { type => "STRING", value => qq{"$s"} };
 607                     redo OUTDATA;
 608                 }
 609                 if ( $type[CURR] =~ /COMP|COMM|STMT/ ) {
 610                     push @ld, { type => "STRING", value => qq{"$s"} };
 611                     last OUTDATA;
 612                 }
 613                 $s .= $syms[CURR];
 614             }
 615         }
 616         else {
 617             die "Cannot use $type[CURR]/$syms[CURR] in DATA";
 618         }
 619         feedme();
 620     }
 621     push( @data, { line => $currline, data => \@ld } );
 622 }
 623
 624 sub parse_restore {
 625     my @args;
 626     if ( $type[NEXT] eq "BARE" or $type[NEXT] eq "INT" ) {
 627         feedme();
 628         create_label();
 629         push @args, qq{"$labels{$syms[CURR]}"};
 630     }
 631     else {
 632         push @args, qq{""};
 633     }
 634     feedme();
 635     push @{ $code{$seg}->{code} }, "\t_RESTORE(" . join( ",", @args ) . ")\n";
 636 }
 637
 638 sub parse_exit {
 639     if ( $syms[NEXT] eq "for" ) {
 640         feedme();
 641         $foo = $fors[$scopes]->[-1];
 642         push @{ $code{$seg}->{code} }, "\tgoto AFTER_NEXT_$foo->{num}\n";
 643     }
 644     elsif ( $syms[NEXT] eq "function" ) {
 645         push @{ $code{$seg}->{code} }, qq{\tgoto END_$seg\n};
 646         feedme();
 647
 648         #$_=english_func($funcname);
 649         #print CODE "\tgoto FUNC_EXIT_$_\n";
 650     }
 651     elsif ( $syms[NEXT] eq "sub" ) {
 652         push @{ $code{$seg}->{code} }, qq{\tgoto END_$seg\n};
 653         feedme();
 654
 655         #print CODE "\tgoto SUB_EXIT_$subname\n";
 656     }
 657     elsif ( $syms[NEXT] eq "do" ) {
 658         feedme();
 659         $foo = $dos[-1];
 660         push @{ $code{$seg}->{code} }, "\tgoto AFTERDO_$foo->{jump}\n";
 661     }
 662     else {
 663         die "Unknown EXIT type source line $sourceline";
 664     }
 665 }
 666
 667 $selectcounter = 0;
 668
 669 sub parse_select {
 670     die "Expected 'case'" if ( $syms[NEXT] ne "case" );
 671     feedme();
 672     push( @selects, { jump => ++$selectcounter, incase => 0 } );
 673     my @a = EXPRESSION();
 674     print CODE<<SELECTSTART;
 675         # Select case on
 676 @a      bsr DEREF                      # De-reference variables and whatnot.
 677         P0= P10[I25]
 678         P1= P0["SELECTS"]
 679         P1["$selectcounter"]= P6   # Store for later.
 680         goto CASE_${selectcounter}_0
 681
 682 SELECTSTART
 683
 684     # Honestly the next thing needs to be a case statement.
 685     # I don't enforce it though.  Honor system!  :)
 686 }
 687
 688 sub parse_case {
 689     my @a;
 690     my $s = $selects[-1];
 691     my ( $jump, $incase ) = ( $s->{jump}, $s->{incase} );
 692
 693     if ( $syms[NEXT] eq "else" ) {
 694         feedme();
 695         print CODE "\t goto CASE_${jump}_FIN\n";
 696         print CODE "CASE_${jump}_${incase}:\t# Default\n";
 697         $selects[-1]->{incase} = $incase + 1;
 698         return;
 699     }
 700
 701     my $lambda = <<GL;
 702
 703         P0= P10[I25]
 704         P1= P0["SELECTS"]
 705         P5= P1["$jump"]      # Stored value.
 706 GL
 707     print CODE<<CASE_SETUP;
 708         goto CASE_${jump}_FIN
 709 CASE_${jump}_${incase}:
 710         new P12, .ResizablePMCArray   # OR
 711         new P13, .ResizablePMCArray   # TO
 712         new P14, .ResizablePMCArray   # Operators.  Op first, then value
 713 CASE_SETUP
 714     my ( $ors, $tos, $ops ) = ( 0, 0, 0 );
 715     while (1) {
 716         if ( $type[CURR] eq "COMM" ) {
 717             print CODE "\t#$syms[CURR]\n";
 718             last;
 719         }
 720         last if ( $type[CURR] eq "STMT" or $type[CURR] eq "COMP" );
 721         if ( $syms[NEXT] =~ /^>|>=|<|<=|=|<>$/ ) {    # Relop
 722             feedme();
 723             $op = $syms[CURR];
 724             @a  = EXPRESSION();
 725             feedme();
 726             print CODE<<OP;
 727         push P14, "$op"
 728 @a      bsr DEREF
 729         push P14, P6
 730 OP
 731             $ops++;
 732             next;
 733         }
 734         @a = EXPRESSION();    # CURR = "to", "," or EOL.
 735         feedme();
 736         if (   $syms[CURR] eq ","
 737             or $type[CURR] eq "STMT"
 738             or $type[CURR] eq "COMP" )
 739         {
 740             print CODE<<EQ;
 741 @a      bsr DEREF
 742         push P12, P6   # Save result for later.
 743 EQ
 744             $ors++;
 745         }
 746         if ( $syms[CURR] eq "to" ) {
 747             my @b = EXPRESSION();
 748             feedme();
 749             print CODE<<TO;
 750 # From
 751 @a      bsr DEREF
 752         push P13, P6
 753 # To
 754 @b      bsr DEREF
 755         push P13, P6
 756 TO
 757             $tos++;
 758         }
 759         last if ( $type[CURR] eq "STMT" or $type[CURR] eq "COMP" );
 760     }
 761     print CODE "\tbsr EXPRINIT\n";
 762     print CODE $lambda;
 763     if ($ors) {
 764         print CODE <<ORS
 765         I5= P12
 766 CASE_${jump}_${incase}_STARTOR:
 767         eq I5, 1, CASE_${jump}_${incase}_NO_OR
 768         push P9, "or"
 769         push P9, "OP"
 770 CASE_${jump}_${incase}_NO_OR:
 771         push P9, "="
 772         push P9, "OP"
 773         P0= P5          # The "constant"
 774         bsr RUNTIME_PUSH
 775         pop P0, P12
 776         bsr RUNTIME_PUSH
 777         dec I5
 778         gt I5, 0, CASE_${jump}_${incase}_STARTOR
 779 ORS
 780     }
 781     if ( $ors and $tos ) {
 782         print CODE qq{\tunshift P9, "OP"\n};
 783         print CODE qq{\tunshift P9, "or"\n};
 784     }
 785     if ($tos) {
 786         print CODE<<TOS;
 787         I5= P13
 788         div I5, I5, 2
 789 CASE_${jump}_${incase}_STARTTO:
 790         eq I5, 1, CASE_${jump}_${incase}_NO_TO
 791         push P9, "or"
 792         push P9, "OP"
 793 CASE_${jump}_${incase}_NO_TO:
 794         push P9, "and"
 795         push P9, "OP"
 796         push P9, ">="
 797         push P9, "OP"
 798         P0= P5
 799         bsr RUNTIME_PUSH
 800         pop P0, P13
 801         bsr RUNTIME_PUSH
 802         push P9, "<="
 803         push P9, "OP"
 804         P0= P5
 805         bsr RUNTIME_PUSH
 806         pop P0, P13
 807         bsr RUNTIME_PUSH
 808         dec I5
 809         gt I5, 0, CASE_${jump}_${incase}_STARTTO
 810 TOS
 811     }
 812     if ( $ops and ( $tos or $ors ) ) {
 813         print CODE qq{\tunshift P9, "OP"\n};
 814         print CODE qq{\tunshift P9, "or"\n};
 815     }
 816     if ($ops) {
 817         print CODE<<OPS;
 818         I5= P14
 819         div I5, I5, 2
 820 CASE_${jump}_${incase}_STARTOPS:
 821         eq I5, 1, CASE_${jump}_${incase}_NO_OP
 822         push P9, "or"
 823         push P9, "OP"
 824 CASE_${jump}_${incase}_NO_OP:
 825         pop P1, P14
 826         pop S0, P14
 827         push P9, S0
 828         push P9, "OP"
 829         P0= P1
 830         bsr RUNTIME_PUSH
 831         P0= P5
 832         bsr RUNTIME_PUSH
 833         dec I5
 834         gt I5, 0, CASE_${jump}_${incase}_STARTOPS
 835 OPS
 836     }
 837     $incase++;
 838     print CODE<<ENDCASE;
 839         bsr EVALEXPR
 840         bsr TRUTH
 841         ne I1, 1, CASE_${jump}_${incase}
 842 ENDCASE
 843     $selects[-1]->{incase} = $incase;
 844 }
 845
 846 my $false;
 847 my $whilecounter = 0;
 848
 849 sub parse_while {
 850     $whilecounter++;
 851     push( @whiles, { jump => $whilecounter } );
 852     my ( $result, $type, @code ) = EXPRESSION();
 853     $false = "0.0";
 854     $false = qq{""} if ( $type eq "S" );
 855
 856     push @{ $code{$seg}->{code} }, "WHILE_$whilecounter:\n";
 857     push @{ $code{$seg}->{code} }, <<BRANCH;
 858 @code   eq $result, $false, AFTERWHILE_$whilecounter
 859 BRANCH
 860 }
 861
 862 sub parse_wend {
 863     $_ = pop(@whiles);
 864     $_ = $_->{jump};
 865     push @{ $code{$seg}->{code} }, <<LOOPUP;
 866         goto WHILE_$_
 867 AFTERWHILE_$_:
 868 LOOPUP
 869 }
 870 my $docounter = 0;
 871
 872 sub parse_do {
 873     $docounter++;
 874     if ( $syms[NEXT] eq "until" or $syms[NEXT] eq "while" ) {
 875         my $false = "0.0";
 876         feedme();    # At the while/until
 877         my $which = $syms[CURR];
 878         push @{ $code{$seg}->{code} }, "DO_$docounter:\n";
 879         my ( $result, $type, @code ) = EXPRESSION();
 880         $false = qq{""} if $type eq "S";
 881         if ( $which eq "while" ) {
 882             $_ = "@code eq $result, $false, AFTERDO_$docounter";
 883         }
 884         else {
 885             $_ = "@code ne $result, $false, AFTERDO_$docounter";
 886         }
 887         push @{ $code{$seg}->{code} }, "\t$_\n";
 888         push( @dos, { jump => $docounter, needstmt => 0 } );
 889     }
 890     else {
 891         push @{ $code{$seg}->{code} }, "DO_$docounter:\n";
 892         push( @dos, { jump => $docounter, needstmt => 1 } );
 893     }
 894 }
 895
 896 sub parse_goto {
 897     feedme;
 898     create_label();
 899     push @{ $code{$seg}->{code} }, "\tgoto $labels{$syms[CURR]}\t# Goto $syms[CURR]\n";
 900 }
 901
 902 sub parse_gosub {
 903     feedme;
 904     create_label();
 905
 906     push @{ $code{$seg}->{code} }, <<GOSUB;
 907         bsr $labels{$syms[CURR]}\t# GOSUB $syms[CURR]
 908         #RTJ ne JUMPLABEL, "", RUNTIME_JUMP
 909 GOSUB
 910 }
 911
 912 sub parse_return {
 913     if ( $type[NEXT] ne "BARE" ) {
 914         push @{ $code{$seg}->{code} }, <<RETURN1;
 915         JUMPLABEL= ""
 916         ret
 917 RETURN1
 918     }
 919     else {
 920         feedme();    # Special "Return Label"
 921         push @{ $code{$seg}->{code} }, <<RETURN2;
 922         JUMPLABEL= "$labels{$syms[CURR]}"  # Return $syms[CURR]
 923         ret
 924 RETURN2
 925         if ( !$runtime_jump ) {
 926             warn "Note: RETURN x causes slow IMCC compilation\n";
 927             $runtime_jump = 1;
 928         }
 929     }
 930 }
 931
 932 sub parse_loop {
 933     my $do = pop @dos;
 934     if ( $do->{needstmt} and not( $syms[NEXT] =~ /while|until/ ) ) {
 935         push @{ $code{$seg}->{code} }, "\ngoto DO_$do->{jump}\t# Unconditional\n";
 936         push @{ $code{$seg}->{code} }, "AFTERDO_$do->{jump}:\n";
 937         return;
 938     }
 939     if ( $do->{needstmt} ) {
 940         my $false = "0.0";
 941         feedme();
 942         my $which = $syms[CURR];
 943         my ( $result, $type, @code ) = EXPRESSION();
 944         $false = qq{""} if $type eq "S";
 945         if ( $which eq "while" ) {
 946             $_ = "@code ne $result, $false, DO_$do->{jump}";
 947         }
 948         else {
 949             $_ = "@code eq $result, $false, DO_$do->{jump}";
 950         }
 951         push @{ $code{$seg}->{code} }, "\t$_\n";
 952     }
 953     else {
 954         push @{ $code{$seg}->{code} }, "\tgoto DO_$do->{jump}\n";
 955     }
 956     push @{ $code{$seg}->{code} }, "AFTERDO_$do->{jump}:\n";
 957 }
 958
 959 sub parse_type {
 960     my (@types);
 961     feedme;
 962     my $typename = $syms[CURR];
 963     feedme;
 964     $sourceline++;
 965     feedme;
 966     while ( $syms[CURR] ne "end" ) {
 967         my ( $name, $type );
 968         die "Syntax error in type $type[CURR]/$syms[CURR] (source line $sourceline)"
 969             unless $type[CURR] eq "BARE";
 970         $name = $syms[CURR];
 971         feedme;
 972         die "Expected 'as' got $syms[CURR] (source line $sourceline)" unless $syms[CURR] eq 'as';
 973         feedme;
 974         $type = $syms[CURR];
 975         my %th = (
 976             single  => 'FLO',
 977             double  => 'FLO',
 978             long    => 'INT',
 979             integer => 'INT',
 980             string  => 'STRING'
 981         );
 982         die "Unknown type $type (source line $sourceline)"
 983             unless ( exists $th{$type}
 984             or exists $usertypes{$type} );
 985         my $marker;
 986
 987         if ( exists $th{$type} ) {
 988             $marker = $th{$type};
 989         }
 990         else {
 991             $marker = 'USER';
 992         }
 993         push( @types, [ $name, $type, $marker ] );
 994         feedme();
 995         if ( $type[CURR] eq "PUN" and $syms[CURR] eq "*" ) {
 996             print "WARNING: * in TYPE not supported yet for $name\n";
 997             feedme;
 998             feedme;
 999         }
1000         while ( $type[CURR] eq "STMT" or $type[CURR] eq "COMM" ) {
1001             print CODE "\t# $syms[CURR]\n" if $type[CURR] eq "COMM";
1002             feedme;
1003         }
1004         $sourceline++;
1005     }
1006     feedme;    # Collect the "type"
1007     $usertypes{$typename} = [@types];
1008     print CODE <<TYPE;
1009         # Type definition for $typename
1010         new P0, .ResizablePMCArray
1011 TYPE
1012     foreach (@types) {
1013         print CODE<<ADDT;
1014         new P1, .Hash
1015         P1["name"]= '$_->[0]'
1016         P1["type"]= '$_->[1]'
1017         push P0, P1
1018 ADDT
1019     }
1020     print CODE<<TYPEE;
1021         P1= P10[0]
1022         P2= P1["types"]
1023         P2["$typename"]= P0
1024         goto OUTOF_$typename
1025 DIM_$typename:
1026         #print "Dimensioning $typename\\n"
1027         pushp
1028         P2= .Hash
1029 TYPEE
1030     foreach (@types) {
1031         my %val = ( INT => 0, FLO => '0.0', STRING => '""' );
1032         if ( $_->[2] ne "USER" ) {
1033             print CODE<<NOTUSER;
1034         new P1, .Hash
1035         P1["name"]= '$_->[0]'
1036         P1["type"]= '$_->[2]'
1037         P1["value"]= $val{$_->[2]}
1038         P2["$_->[0]"]= P1
1039 NOTUSER
1040         }
1041         else {
1042             print CODE<<USERTYPE;
1043         new P1, .Hash
1044         P1["name"]= '$_->[0]'
1045         P1["type"]= "USER"
1046         bsr DIM_$_->[1]
1047         P1["storage"]= P0
1048         P1["_type"], '$_->[1]'
1049         P2["$_->[0]"]= P1
1050 USERTYPE
1051         }
1052     }
1053
1054     print CODE<<FINDIM;
1055         save P2
1056         popp
1057         restore P0
1058         ret
1059 COPY_$typename:                 # Source in P6 Dest in P1 (don't trash P0)
1060         #print "--Copying a $typename\\n"
1061         pushp                   # Makes an internal mess of P2, P3, P4, P5, P6 (popped)
1062         new P3, .Hash       # Uses S0, I0, N0
1063 FINDIM
1064
1065     foreach (@types) {
1066         my %val = ( INT => 'I0', FLO => 'N0', STRING => 'S0' );
1067         if ( $_->[2] ne "USER" ) {
1068             print CODE<<NOTUSER;
1069         new P2, .Hash
1070         P2["name"]= '$_->[0]'
1071         P2["type"]= '$_->[2]'
1072         P4= P6["storage"]
1073         P5= P4["$_->[0]"]
1074         $val{$_->[2]}= P5["value"]
1075         P2["value"]= $val{$_->[2]}
1076         #print "-> Copied value for "
1077         #print $val{$_->[2]}
1078         #print "\\n"
1079         P3["$_->[0]"]= P2
1080 NOTUSER
1081         }
1082         else {
1083             print CODE<<USER;
1084         new P2, .Hash
1085         P2["name"]= '$_->[0]'
1086         P2["type"]= "USER"
1087         P5= P6          # Remember where we were...
1088         P4= P6["storage"]
1089         P6= P4["$_->[0]"]
1090         bsr COPY_$_->[1]
1091         P2["storage"]= P1
1092         P6= P5          # Go back to where we were!
1093         P2["_type"]= '$_->[1]'
1094         P3["$_->[0]"]= P2
1095         #print "Finished substruct\\n"
1096 USER
1097         }
1098     }
1099
1100     print CODE<<OUTOF;
1101         #print "Out of copy $typename\\n"
1102         save P3
1103         popp
1104         restore P1
1105         ret
1106 OUTOF_$typename:
1107
1108 OUTOF
1109
1110 }
1111
1112 sub parse_dim {
1113     feedme;
1114 ANOTHERDIM:
1115     if ( $syms[NEXT] eq "as" ) {
1116         my $var = $syms[CURR];
1117         feedme;    # "as"
1118         feedme;    # type.
1119         die "Unknown type $syms[CURR]" unless exists $usertypes{ $syms[CURR] };
1120         my $type = $syms[CURR];
1121         die "SIGIL not allowed here" unless ( $var =~ /\w$/ );
1122         print CODE<<DIMTYPE;
1123         P1= P10[I25]
1124         P2= P1["USER"]
1125         bsr DIM_$type
1126         P1 = new .Hash
1127         P1["_type"]= '$type'
1128         P1["type"]= "USER"
1129         P1["storage"]= P0
1130         P2["$var"]= P1
1131 DIMTYPE
1132         if ( $syms[NEXT] eq "," ) {
1133             feedme();
1134             goto &parse_dim;
1135         }
1136     }
1137     elsif ( $syms[NEXT] eq "(" ) {
1138         my $var = $syms[CURR];
1139         while (1) {
1140             feedme;
1141             last if $syms[CURR] eq ")";
1142         }
1143         my $type;
1144         $type = "FLO";
1145         my %th = (
1146             single  => 'FLO',
1147             double  => 'FLO',
1148             long    => 'INT',
1149             integer => 'INT',
1150             string  => 'STRING'
1151         );
1152         my %sigilmap = (
1153             '%' => 'integer',
1154             '&' => 'long',
1155             '!' => 'single',
1156             '#' => 'double',
1157             '$' => 'string'
1158         );
1159         my $ut = "";
1160         if ( $syms[NEXT] eq "as" ) {
1161             feedme;    # "as"
1162             feedme;    # type...
1163             if ( exists $th{ $syms[CURR] } ) {
1164                 $type = $th{ $syms[CURR] };
1165             }
1166             elsif ( exists $usertypes{ $syms[CURR] } ) {
1167                 $type = "USER";
1168                 $ut   = qq{\tP2["usertype"]= "$syms[CURR]"\n};
1169             }
1170             else {
1171                 die "Unknown type $syms[CURR]";
1172             }
1173         }
1174         else {
1175             $_ = substr( $var, -1, 1 );
1176             if ( exists $sigilmap{$_} ) {
1177                 $type = $th{ $sigilmap{$_} };
1178             }
1179         }
1180         $arrays{"${var}${seg}"} = 1;
1181
1182         #print STDERR "Marking ${var}${seg}\n";
1183         push @{ $code{$seg}->{code} }, <<DIMARR;
1184         # Set aside storage for Array $var
1185         \$P0 = new .Hash
1186         \$P2 = new .ResizablePMCArray
1187         \$P3 = new .Hash
1188         \$P3["index"]=\$P2
1189         \$P3["hash"]=\$P0
1190         find_global \$P1, "BASICARR"
1191         \$P1["$var$seg"]= \$P3
1192         store_global "BASICARR", \$P1
1193         #
1194 DIMARR
1195         if ( $syms[NEXT] eq "," ) {
1196             feedme();
1197             goto &parse_dim;
1198         }
1199     }
1200     elsif ( $syms[CURR] eq "shared" ) {
1201         print "WARNING: SHARED keyword currently ignored\n";
1202         goto &parse_dim;
1203     }
1204     else {
1205         die "Unknown dim type: $syms[CURR] at source line $sourceline";
1206     }
1207 }
1208 my $forloop = 0;
1209
1210 sub parse_for {    # for var = start to finish [step increment]
1211     my ( $endexpr, $stepexpr, @stepcode );
1212
1213     $forloop++;
1214     feedme();
1215
1216     # The initial assignment.  Type of course will be a float.
1217     ( $result, $type, @code ) = EXPRESSION( { lhs => 1, assign => 1 } );
1218     push @{ $code{$seg}->{code} }, @code;
1219
1220     die "TO expected at source line $sourceline" unless ( $syms[CURR] ne "to" );
1221
1222     feedme();
1223
1224     # The destination value
1225     ( $endexpr, $type, @code ) = EXPRESSION();
1226
1227     feedme();
1228     if ( $syms[CURR] eq "step" ) {
1229         ( $stepexpr, $type, @stepcode ) = EXPRESSION();
1230     }
1231     else {
1232         $stepexpr = "1.0";
1233     }
1234     $main::code{$main::seg}->{declarations}->{"FORLOOP_END_$forloop"}  = 1;
1235     $main::code{$main::seg}->{declarations}->{"FORLOOP_STEP_$forloop"} = 1;
1236     push @{ $code{$seg}->{code} }, <<COND;
1237 @code   FORLOOP_END_$forloop= $endexpr
1238 @stepcode
1239         FORLOOP_STEP_$forloop= $stepexpr
1240 FOR_$forloop:
1241         gt FORLOOP_STEP_$forloop, 0.0, FOR_GT_$forloop
1242         lt $result, FORLOOP_END_$forloop, AFTER_NEXT_$forloop
1243         goto FOR_LOOP_BODY_$forloop
1244 FOR_GT_$forloop:
1245         gt $result, FORLOOP_END_$forloop, AFTER_NEXT_$forloop
1246 FOR_LOOP_BODY_$forloop:
1247 COND
1248     debug() if $debug;
1249
1250     push @{ $fors[$scopes] }, { var => $result, num => $forloop, inc => $stepexpr };
1251 }
1252
1253 sub parse_next {    # next [a[,b[,c]...]
1254     feedme();
1255     my ( $var, $vartype, $ovar );
1256     my $ps;
1257     $ps = pop @{ $fors[$scopes] };
1258
1259     if ( $type[CURR] ne "BARE" ) {    # next  (no variable)
1260         push @{ $code{$seg}->{code} }, <<NEXT;
1261         add $ps->{var}, $ps->{var}, FORLOOP_STEP_$ps->{num}
1262         goto FOR_$ps->{num}
1263 AFTER_NEXT_$ps->{num}: noop
1264 NEXT
1265     }
1266     else {                            # next var
1267         while (1) {
1268             push @{ $code{$seg}->{code} }, <<NEXT;
1269         add $ps->{var}, $ps->{var}, FORLOOP_STEP_$ps->{num}
1270         goto FOR_$ps->{num}
1271 AFTER_NEXT_$ps->{num}: noop
1272 NEXT
1273             if ( $syms[NEXT] eq "," ) {
1274                 feedme();
1275                 feedme();
1276                 $ps = pop @{ $fors[$scopes] };
1277                 next;
1278             }
1279             last;
1280         }
1281     }
1282 }
1283
1284 sub parse_call {
1285
1286     # Subroutines are disguised as user-defined functions,
1287     # except that there's no return value to deal with.
1288     feedme();
1289     if ( !exists $subs{ $syms[CURR] } ) {
1290         die "Subroutine $syms[CURR] not found at line $sourceline\n";
1291     }
1292     my $sub = $syms[CURR];
1293     barf();
1294
1295     #       print STDERR "Processing call $sub\n";
1296     ( $result, $type, @code ) = EXPRESSION( { ignorecomma => 1 } );
1297
1298     #       print STDERR "Got back @code\n";
1299     push @{ $code{$seg}->{code} }, <<CALLSUB;
1300 @code
1301 CALLSUB
1302 }
1303
1304 sub parse_sub {
1305
1306     # Deja-vu from functions.
1307     feedme;
1308     my $f;
1309     $funcname = $syms[CURR];
1310     my $englishname = english_func($funcname);
1311     $subs{$funcname}      = $englishname;
1312     $functions{$funcname} = $englishname;
1313
1314     $f = "_USERFUNC_$funcname";
1315     $f = changename($f);
1316     $f =~ s/\$/_string/g;
1317     $f =~ tr/a-z/A-Z/;
1318     $seg = $f;
1319     CALL_BODY( $englishname, "SUB" );
1320 }
1321
1322 sub parse_function {
1323     feedme;
1324     my $f;
1325     $funcname = $syms[CURR];
1326     my $englishname = english_func($funcname);
1327     $functions{$funcname} = $englishname;
1328
1329     $f = "_USERFUNC_$funcname";
1330     $f = changename($f);
1331     $f =~ s/\$/_string/g;
1332     $f =~ tr/a-z/A-Z/;
1333     $seg = $f;
1334     CALL_BODY( $englishname, "UF" );
1335 }
1336
1337 sub CALL_BODY {
1338     my ( $englishname, $prefix ) = @_;
1339     my @params;
1340     while ( feedme() ) {
1341         last if ( $type[CURR] eq "STMT" );
1342         last if ( $type[CURR] eq "PUN" and $syms[CURR] eq ")" );
1343         next if ( $type[CURR] eq "PUN" );
1344         if ( $type[CURR] eq "BARE" ) {    # Variable name parameter
1345             $a = $syms[CURR];
1346             if ( $syms[NEXT] eq "as" ) {
1347                 feedme();                 # Get the as
1348                 feedme();
1349                 push( @params, $syms[CURR], $a );
1350             }
1351             elsif ( $syms[NEXT] eq "(" ) {
1352                 feedme();
1353                 while ( $syms[CURR] ne ")" ) {
1354                     feedme();
1355                 }
1356                 push( @params, "()$a" );
1357             }
1358             else {
1359                 push( @params, $a );      # Always here?
1360             }
1361         }
1362     }
1363     my $argcnt = @params;
1364
1365     # The outer compiler will provide the framework for the
1366     # function call.  We just have to unwind its arguments.
1367     $_ = scalar @params;
1368     push @{ $code{$seg}->{code} }, <<EOH;
1369         .param int argc
1370         eq argc, $_, ${englishname}_ARGOK
1371         print "Function $englishname received "
1372         print argc
1373         print " arguments expected $_\\n"
1374         _platform_shutdown()
1375         end
1376 ${englishname}_ARGOK:
1377 EOH
1378     $main::code{$main::seg}->{declarations}->{$englishname} = 1;
1379
1380     foreach (@params) {
1381         unless (/\(\)/) {
1382             my $t = typeof($_);
1383             $t = "string" if $t eq "STRING";
1384             $t = "float"  if $t eq "FLO";
1385             $_ = changename($_);
1386             $_ =~ s/\$/_string/g;
1387             push @{ $code{$seg}->{code} }, qq{\t.param $t $_\n};
1388             push @{ $code{$seg}->{args} }, $_;
1389         }
1390         else {
1391             s/\(\)//g;
1392             $_ = changename($_);
1393
1394             #print STDERR "Marking ${_}${seg}\n";
1395             $arrays{"${_}${seg}"} = 1;
1396             push @{ $code{$seg}->{code} }, <<PUSHARR;
1397         .param pmc array_$englishname
1398         find_global \$P1, "BASICARR"
1399         \$P1["${_}$seg"]= array_$englishname
1400         store_global "BASICARR", \$P1
1401 PUSHARR
1402
1403             # push @{$code{$seg}->{args}}, $_;
1404         }
1405     }
1406     return;
1407 }
1408
1409 sub parse_endfunc {
1410     feedme;
1411     my $t = $seg;
1412     $seg =~ s/^_//;          # Remove the _
1413     $seg =~ tr/A-Z/a-z/;     # lowercase
1414     $seg =~ s/userfunc_//;
1415     push @{ $code{$t}->{code} }, "END_$t:\n";
1416     if ( exists $code{$t}->{args} ) {
1417         foreach ( @{ $code{$t}->{args} } ) {
1418             push @{ $code{$t}->{code} }, "\t.return $_\t# Returning arg\n";
1419         }
1420     }
1421     push @{ $code{$t}->{code} }, "\t.return $seg\n";
1422     $seg      = "_basicmain";
1423     $funcname = "";
1424     return;
1425 }
1426
1427 sub parse_endsub {
1428     goto &parse_endfunc;
1429 }
1430
1431 sub parse_function_dispatch {
1432     return;
1433     print FUNC<<FUNCDISP;
1434
1435         #
1436         # User function dispatch routine
1437         #
1438 UF_DISPATCH:
1439         I1= -1
1440 FUNCDISP
1441     if (%functions) {
1442         foreach ( keys %functions ) {
1443             print FUNC qq{\teq S0, "$_", UF_}, english_func($_), qq{\n};
1444         }
1445     }
1446     print FUNC<<FUNCEND;
1447         goto UF_DISPATCH_END
1448 UF_DISPATCH_END:
1449         #print "Ending user function, stack depth now "
1450         #print I25
1451         #print "\\n"
1452         ret
1453 FUNCEND
1454     print FUNC<<SUBDISP;
1455 SUB_DISPATCH:
1456         I1= -1
1457 SUBDISP
1458     foreach ( keys %subs ) {
1459         print FUNC qq{\teq S0, "$_", SUB_$_\n};
1460     }
1461     print FUNC<<SUBEND;
1462         goto SUB_DISPATCH_END
1463 SUB_DISPATCH_END:
1464         ret
1465 SUBEND
1466 }
1467
1468 sub parse_struct_copy_dispatch {
1469     goto RTJUMP;
1470     print CODE <<SCOPYDIS;
1471
1472         #
1473         # Structure copy dispatch routine
1474         # Call with S0 set to the type
1475         # Source in P6
1476         # Dest returned in P1
1477 STRUCT_COPY:
1478 SCOPYDIS
1479     foreach ( keys %usertypes ) {
1480         print CODE<<DISP;
1481         eq S0, "$_", COPY_$_
1482 DISP
1483     }
1484     print CODE <<DISP2;
1485         print "Structure type of "
1486         print S0
1487         print " not found\\n"
1488         _platform_shutdown()
1489         end
1490 DISP2
1491
1492     print CODE <<SCOPYDIS;
1493         #
1494         # Structure create dispatch routine
1495         # Call with S0 set to the type
1496         # Dest returned in P0
1497 STRUCT_DIM:
1498 SCOPYDIS
1499     foreach ( keys %usertypes ) {
1500         print CODE<<DISP;
1501         eq S0, "$_", DIM_$_
1502 DISP
1503     }
1504     print CODE <<DISP2;
1505         print "Structure type of "
1506         print S0
1507         print " not found\\n"
1508         _platform_shutdown()
1509         end
1510 DISP2
1511 RTJUMP:
1512     push @{ $code{$seg}->{code} }, <<RTB;
1513         # Several statements need to make branches
1514         # that are only discovered at runtime.
1515 RUNTIME_JUMP:
1516 RTB
1517     if ($runtime_jump) {
1518         foreach ( sort keys %labels ) {
1519             push @{ $code{$seg}->{code} }, qq|\teq JUMPLABEL, "$labels{$_}", $labels{$_}\n|;
1520         }
1521     }
1522
1523     push @{ $code{$seg}->{code} }, <<RTBE;
1524         print "Runtime branch of "
1525         print JUMPLABEL
1526         print " not found\\n"
1527         _platform_shutdown()
1528         end
1529 RTBE
1530 }
1531
1532 sub parse_data_setup {
1533     push @{ $code{_data}->{code} }, <<DATAPREP;
1534         # Prepare the Read/Data stuff
1535         find_global \$P1, "RESTOREINFO"
1536         find_global \$P2, "READDATA"
1537 DATAPREP
1538     my $counter = 0;
1539     foreach my $ld (@data) {
1540         my $line = $ld->{line};
1541         if ( length $line ) {
1542             push @{ $code{_data}->{code} }, qq{\t\$P1["$line"]= $counter\n};
1543         }
1544         foreach ( @{ $ld->{data} } ) {
1545             my ( $t, $v ) = ( $_->{type}, $_->{value} );
1546             push @{ $code{_data}->{code} }, <<ADDDATA;
1547         push \$P2, $v
1548 ADDDATA
1549             $counter++;
1550         }
1551     }
1552
1553     push @{ $code{_data}->{code} }, <<DATADONE;
1554         store_global "RESTOREINFO", \$P1
1555         store_global "READDATA", \$P2
1556 DATADONE
1557 }
1558
1559 sub typeof {
1560     my ($var) = @_;
1561     return "FLO"    if ( $var =~ /[!#%&]$/ );
1562     return "STRING" if ( $var =~ /\$$/ );
1563     return "FLO";
1564 }
1565
1566 1;
1567
1568 # Local Variables:
1569 #   mode: cperl
1570 #   cperl-indent-level: 4
1571 #   fill-column: 100
1572 # End:
1573 # vim: expandtab shiftwidth=4: