lang/basic/src/gencode.c

   1 /*
   2  * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
   3  * See the copyright notice in the ACK home directory, in the file "Copyright".
   4  */
   5
   6 #include "bem.h"
   7
   8 #ifndef NORSCID
   9 static char rcs_id[] = "$Id: gencode.c,v 1.3 1994/06/24 11:30:46 ceriel Exp $" ;
  10 #endif
  11
  12
  13 /* Here we find all routines dealing with pure EM code generation */
  14
  15 static int      emlabel=1;
  16 label   err_goto_label;
  17
  18
  19
  20 genlabel()
  21 {
  22          return(emlabel++);
  23 }
  24
  25
  26
  27 genemlabel()
  28 {
  29         int l;
  30
  31         l=genlabel();
  32         C_df_dlb((label)l);
  33         return(l);
  34 }
  35
  36
  37
  38
  39
  40 int tronoff=0;
  41 newemblock(nr)
  42 int nr;
  43 {
  44         C_df_ilb((label)currline->emlabel);
  45         C_lin((arith)nr);
  46         if ( tronoff || traceflag) {
  47                 C_loc((arith)nr);
  48                 C_cal("_trace");
  49                 C_asp((arith)BEMINTSIZE);
  50         }
  51 }
  52
  53
  54
  55
  56
  57 /* Handle data statements */
  58 List    *datalist=0;
  59 datastmt()
  60 {
  61         List *l,*l1;
  62         extern long sys_filesize();
  63
  64         /* NOSTRICT */ l= (List *) salloc(sizeof(List));
  65         l->linenr= currline->linenr;
  66         l->emlabel =  sys_filesize(datfname);
  67         if ( datalist==0)
  68         {
  69                 datalist=l;
  70         } else {
  71                 l1= datalist;
  72                 while (l1->nextlist) l1= l1->nextlist;
  73                 l1->nextlist=l;
  74         }
  75
  76 }
  77
  78
  79
  80 datatable()
  81 {
  82         List *l;
  83         int line=0;
  84
  85         /* called at end to generate the data seek table */
  86         C_exa_dnam("_seektab");
  87         C_df_dnam("_seektab");       /* VRAAGTEKEN */
  88         l= datalist;
  89         while (l)
  90         {
  91                 C_rom_cst((arith)(l->linenr));
  92                 C_rom_cst((arith)(line++));
  93                 l= l->nextlist;
  94         }
  95         C_rom_cst((arith)0);
  96         C_rom_cst((arith)0);
  97 }
  98
  99
 100
 101 /* ERROR and exception handling */
 102 exceptstmt(lab)
 103 int lab;
 104 {
 105         /* exceptions to subroutines are supported only */
 106         extern int gosubcnt;
 107         List    *l;
 108
 109         C_loc((arith)gosubcnt);
 110         l= (List *) gosublabel();
 111         l->emlabel= gotolabel(lab);
 112         C_cal("_trpset");
 113         C_asp((arith)BEMINTSIZE);
 114 }
 115
 116
 117
 118 errorstmt(exprtype)
 119 int     exprtype;
 120 {
 121         /* convert expression to a valid error number */
 122         /* obtain the message and print it */
 123         C_cal("error");
 124         C_asp((arith)typesize(exprtype));
 125 }
 126
 127
 128
 129 /* BASIC IO */
 130 openstmt(recsize)
 131 int recsize;
 132 {
 133         C_loc((arith)recsize);
 134         C_cal("_opnchn");
 135         C_asp((arith)(2*BEMPTRSIZE+BEMINTSIZE));
 136 }
 137
 138
 139
 140 printstmt(exprtype)
 141 int     exprtype;
 142 {
 143         switch(exprtype)
 144         {
 145                 case INTTYPE:
 146                         C_cal("_prinum");
 147                         C_asp((arith)typestring(INTTYPE));
 148                         break;
 149                 case FLOATTYPE:
 150                 case DOUBLETYPE:
 151                         C_cal("_prfnum");
 152                         C_asp((arith)typestring(DOUBLETYPE));
 153                         break;
 154                 case STRINGTYPE:
 155                         C_cal("_prstr");
 156                         C_asp((arith)BEMPTRSIZE);
 157                         break;
 158                 case 0: /* result of tab function etc */
 159                         break;
 160                 default:
 161                         error("printstmt:unexpected");
 162         }
 163 }
 164
 165
 166
 167 zone(i)
 168 int i;
 169 {
 170         if ( i) C_cal("_zone");
 171 }
 172
 173
 174
 175 writestmt(exprtype,comma)
 176 int     exprtype,comma;
 177 {
 178         if ( comma) C_cal("_wrcomma");
 179
 180         switch(exprtype)
 181         {
 182                 case INTTYPE:
 183                         C_cal("_wrint");
 184                         break;
 185                 case FLOATTYPE:
 186                 case DOUBLETYPE:
 187                         C_cal("_wrflt");
 188                         break;
 189                 case STRINGTYPE:
 190                         C_cal("_wrstr");
 191                         break;
 192                 default:
 193                         error("printstmt:unexpected");
 194         }
 195         C_asp((arith)BEMPTRSIZE);
 196 }
 197
 198
 199
 200 restore(lab)
 201 int lab;
 202 {
 203         /* save this information too */
 204
 205         C_loc((arith)0);
 206         C_cal("_setchan");
 207         C_asp((arith)BEMINTSIZE);
 208         C_loc((arith)lab);
 209         C_cal("_restore");
 210         C_asp((arith)BEMINTSIZE);
 211 }
 212
 213
 214
 215 prompt(qst)
 216 int qst;
 217 {
 218         setchannel(-1);
 219         C_cal("_prstr");
 220         C_asp((arith)BEMPTRSIZE);
 221         if (qst) C_cal("_qstmark");
 222 }
 223
 224
 225
 226 linestmt(type)
 227 int type;
 228 {
 229         if ( type!= STRINGTYPE)
 230                 error("String variable expected");
 231         C_cal("_rdline");
 232         C_asp((arith)BEMPTRSIZE);
 233 }
 234
 235
 236
 237 readelm(type)
 238 int type;
 239 {
 240         switch(type)
 241         {
 242                 case INTTYPE:
 243                         C_cal("_readint");
 244                         break;
 245                 case FLOATTYPE:
 246                 case DOUBLETYPE:
 247                         C_cal("_readflt");
 248                         break;
 249                 case STRINGTYPE:
 250                         C_cal("_readstr");
 251                         break;
 252                 default:
 253                         error("readelm:unexpected type");
 254         }
 255         C_asp((arith)BEMPTRSIZE);
 256 }
 257
 258
 259
 260 /* Swap exchanges the variable values */
 261 swapstmt(ltype,rtype)
 262 int     ltype, rtype;
 263 {
 264         if ( ltype!= rtype)
 265                 error("Type mismatch");
 266         else
 267                 switch(ltype)
 268                 {
 269                         case INTTYPE:
 270                                 C_cal("_intswap");
 271                                 break;
 272                         case FLOATTYPE:
 273                         case DOUBLETYPE:
 274                                 C_cal("_fltswap");
 275                                 break;
 276                         case STRINGTYPE:
 277                                 C_cal("_strswap");
 278                                 break;
 279                         default:
 280                                 error("swap:unexpected");
 281                 }
 282
 283         C_asp((arith)(2*BEMPTRSIZE));
 284 }
 285
 286
 287
 288 /* input/output handling */
 289 setchannel(val)
 290 int val;
 291 {       /* obtain file descroption */
 292         C_loc((arith)val);
 293         C_cal("_setchan");
 294         C_asp((arith)BEMINTSIZE);
 295 }
 296
 297
 298
 299 /* The if-then-else statements */
 300 ifstmt(type)
 301 int type;
 302 {
 303         /* This BASIC follows the True= -1 rule */
 304         int nr;
 305
 306         nr= genlabel();
 307         if ( type == INTTYPE)
 308                 C_zeq((label)nr);
 309         else
 310                 if ( type == FLOATTYPE || type == DOUBLETYPE )
 311                 {
 312                         C_lae_dnam("fltnull",(arith)0);
 313                         C_loi((arith)BEMFLTSIZE);
 314                         C_cmf((arith)BEMFLTSIZE);
 315                         C_zeq((label)nr);
 316                 }
 317                 else error("Integer or Float expected");
 318
 319         return(nr);
 320 }
 321
 322
 323
 324 thenpart( elselab)
 325 int elselab;
 326 {
 327         int nr;
 328
 329         nr=genlabel();
 330         C_bra((label)nr);
 331         C_df_ilb((label)elselab);
 332         return(nr);
 333 }
 334
 335
 336
 337 elsepart(lab)int lab;
 338 {
 339         C_df_ilb((label)lab);
 340 }
 341
 342
 343
 344 /* generate code for the for-statement */
 345 #define MAXFORDEPTH 20
 346
 347 struct FORSTRUCT{
 348         Symbol  *loopvar;       /* loop variable */
 349         int     initaddress;
 350         int     limitaddress;
 351         int     stepaddress;
 352         int     fortst;         /* variable limit test */
 353         int     forinc;         /* variable increment code */
 354         int     forout;         /* end of loop */
 355 } fortable[MAXFORDEPTH];
 356
 357 int     forcnt= -1;
 358
 359
 360
 361 forinit(s)
 362 Symbol *s;
 363 {
 364         int type;
 365         struct FORSTRUCT *f;
 366
 367         dcltype(s);
 368         type= s->symtype;
 369         forcnt++;
 370         if ( (type!=INTTYPE && type!=FLOATTYPE && type!=DOUBLETYPE) ||
 371             s->dimensions)
 372                 error("Illegal loop variable");
 373         if ( forcnt >=MAXFORDEPTH)
 374                 error("too many for statements");
 375         else {
 376                 f=fortable+forcnt;
 377                 f->loopvar=s;
 378                 f->fortst=genlabel();
 379                 f->forinc=genlabel();
 380                 f->forout=genlabel();
 381                 /* generate space for temporary objects */
 382                 f->initaddress= dclspace(type);
 383                 f->limitaddress= dclspace(type);
 384                 f->stepaddress= dclspace(type);
 385         }
 386 }
 387
 388
 389
 390 forexpr(type)
 391 int type;
 392 {
 393         /* save start value of loop variable in a save place*/
 394         /* to avoid clashing with final value and step expression */
 395         int result;
 396
 397         result= fortable[forcnt].loopvar->symtype;
 398         conversion(type,result);
 399         storevar(fortable[forcnt].initaddress, result);
 400 }
 401
 402
 403
 404 forlimit(type)
 405 int type;
 406 {
 407         /* save the limit value too*/
 408         int result;
 409
 410         result= fortable[forcnt].loopvar->symtype;
 411         conversion(type,result);
 412         storevar(fortable[forcnt].limitaddress, result);
 413 }
 414
 415
 416
 417 forskipped(f)
 418 struct FORSTRUCT *f;
 419 {
 420         int type;
 421
 422         type= f->loopvar->symtype;
 423         /* evaluate lower bound times sign of step */
 424         C_lae_dlb((label)f->initaddress,(arith)0);
 425         loadvar(type);
 426         conversion(type,DOUBLETYPE);
 427         C_lae_dlb((label)f->stepaddress,(arith)0);
 428         loadvar(type);
 429         conversion(type,DOUBLETYPE);
 430         C_cal("_forsgn");
 431         C_asp((arith)BEMFLTSIZE);
 432         C_lfr((arith)BEMINTSIZE);
 433         conversion(INTTYPE,DOUBLETYPE);
 434         C_mlf((arith)BEMFLTSIZE);
 435         /* evaluate higher bound times sign of step */
 436         C_lae_dlb((label)f->limitaddress,(arith)0);
 437         loadvar(type);
 438         conversion(type,DOUBLETYPE);
 439         C_lae_dlb((label)f->stepaddress,(arith)0);
 440         loadvar(type);
 441         conversion(type,DOUBLETYPE);
 442         C_cal("_forsgn");
 443         C_asp((arith)BEMFLTSIZE);
 444         C_lfr((arith)BEMINTSIZE);
 445         conversion(INTTYPE,DOUBLETYPE);
 446         C_mlf((arith)BEMFLTSIZE);
 447         /* skip condition */
 448         C_cmf((arith)BEMFLTSIZE);
 449         C_zgt((label)f->forout);
 450 }
 451
 452
 453
 454 forstep(type)
 455 int type;
 456 {
 457         int result;
 458         int varaddress;
 459         struct FORSTRUCT *f;
 460
 461         f= fortable+forcnt;
 462         result= f->loopvar->symtype;
 463         varaddress= f->loopvar->symalias;
 464         conversion(type,result);
 465         storevar(f->stepaddress, result);
 466         /* all information available, generate for-loop head */
 467         /* test for ingoring loop */
 468         forskipped(f);
 469         /* set initial value */
 470         C_lae_dlb((label)f->initaddress,(arith)0);
 471         loadvar(result);
 472         C_lae_dlb((label)varaddress,(arith)0);
 473         C_sti((arith)typestring(result));
 474         C_bra((label)f->fortst);
 475         /* increment loop variable */
 476         C_df_ilb((label)f->forinc);
 477         C_lae_dlb((label)varaddress,(arith)0);
 478         loadvar(result);
 479         C_lae_dlb((label)f->stepaddress,(arith)0);
 480         loadvar(result);
 481         if (result == INTTYPE)
 482                 C_adi((arith)BEMINTSIZE);
 483         else    C_adf((arith)BEMFLTSIZE);
 484         C_lae_dlb((label)varaddress,(arith)0);
 485         C_sti((arith)typestring(result));
 486         /* test boundary */
 487         C_df_ilb((label)f->fortst);
 488         C_lae_dlb((label)varaddress,(arith)0);
 489         loadvar(result);
 490         /* Start of NEW code */
 491         C_lae_dlb((label)f->stepaddress,(arith)0);
 492         loadvar(result);
 493         conversion(result,DOUBLETYPE);
 494         C_cal("_forsgn");
 495         C_asp((arith)BEMFLTSIZE);
 496         C_lfr((arith)BEMINTSIZE);
 497         conversion(INTTYPE,result);
 498         if ( result == INTTYPE )
 499                 C_mli((arith)BEMINTSIZE);
 500         else    C_mlf((arith)BEMFLTSIZE);
 501         /* End of NEW code */
 502         C_lae_dlb((label)f->limitaddress,(arith)0);
 503         loadvar(result);
 504         /* Start NEW code */
 505         C_lae_dlb((label)f->stepaddress,(arith)0);
 506         loadvar(result);
 507         conversion(result,DOUBLETYPE);
 508         C_cal("_forsgn");
 509         C_asp((arith)BEMFLTSIZE);
 510         C_lfr((arith)BEMINTSIZE);
 511         conversion(INTTYPE,result);
 512         if ( result == INTTYPE )
 513                 C_mli((arith)BEMINTSIZE);
 514         else    C_mlf((arith)BEMFLTSIZE);
 515         /* End NEW code */
 516         if (result == INTTYPE)
 517                 C_cmi((arith)BEMINTSIZE);
 518         else    C_cmf((arith)BEMFLTSIZE);
 519         C_zgt((label)f->forout);
 520 }
 521
 522
 523
 524 nextstmt(s)
 525 Symbol *s;
 526 {
 527         if (forcnt>MAXFORDEPTH || forcnt<0 ||
 528             (s && s!= fortable[forcnt].loopvar))
 529                 error("NEXT without FOR");
 530         else {
 531                 /* address of variable is on top of stack ! */
 532                 C_bra((label)fortable[forcnt].forinc);
 533                 C_df_ilb((label)fortable[forcnt].forout);
 534                 forcnt--;
 535         }
 536 }
 537
 538
 539
 540 pokestmt(type1,type2)
 541 int     type1,type2;
 542 {
 543         conversion(type1,INTTYPE);
 544         conversion(type2,INTTYPE);
 545         C_asp((arith)(2*BEMINTSIZE));
 546 }
 547
 548
 549
 550 /* generate code for the while statement */
 551 #define MAXDEPTH 20
 552
 553 int     whilecnt, whilelabels[MAXDEPTH][2]; /*0=head,1=out */
 554
 555 whilestart()
 556 {
 557         whilecnt++;
 558         if ( whilecnt==MAXDEPTH)
 559                 fatal("too many nestings");
 560         /* gendummy label in graph */
 561         newblock(-1);
 562         whilelabels[whilecnt][0]= currline->emlabel;
 563         whilelabels[whilecnt][1]= genlabel();
 564         C_df_ilb((label)whilelabels[whilecnt][0]);
 565 }
 566
 567
 568
 569 whiletst(exprtype)
 570 int exprtype;
 571 {
 572         /* test expression type */
 573         conversion(exprtype,INTTYPE);
 574         C_zeq((label)whilelabels[whilecnt][1]);
 575 }
 576
 577
 578
 579 wend()
 580 {
 581         if ( whilecnt<1)
 582                 error("not part of while statement");
 583         else {
 584                 C_bra((label)whilelabels[whilecnt][0]);
 585                 C_df_ilb((label)whilelabels[whilecnt][1]);
 586                 whilecnt--;
 587         }
 588 }
 589
 590
 591
 592 /* generate code for the final version */
 593 prologcode()
 594 {
 595         /* generate the EM prolog code */
 596         C_df_dnam("fltnull");
 597         C_con_cst((arith)0);
 598         C_con_cst((arith)0);
 599         C_con_cst((arith)0);
 600         C_con_cst((arith)0);
 601         C_df_dnam("dummy2");
 602         C_con_cst((arith)0);
 603         C_con_cst((arith)0);
 604         C_con_cst((arith)0);
 605         C_con_cst((arith)0);
 606         /* NEW variable we make */
 607         C_df_dnam("dummy3");
 608         C_bss_dnam((arith)BEMPTRSIZE,"dummy3",(arith)0,0);
 609         C_df_dnam("tronoff");
 610         C_con_cst((arith)0);
 611         C_df_dnam("dummy1");
 612         C_con_cst((arith)0);
 613         C_con_cst((arith)0);
 614         C_con_cst((arith)0);
 615         C_con_cst((arith)0);
 616         C_exa_dnam("_iomode");
 617         C_df_dnam("_iomode");
 618         C_rom_scon("O",(arith)2);
 619         C_exa_dnam("_errsym");
 620         C_df_dnam("_errsym");
 621         C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
 622         C_exa_dnam("_erlsym");
 623         C_df_dnam("_erlsym");
 624         C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
 625 }
 626
 627
 628
 629 prolog2()
 630 {
 631         int result;
 632         label l = genlabel(), l2;
 633
 634         err_goto_label = genlabel();
 635         C_exp("main");
 636         C_pro("main",(arith)0);
 637         C_ms_par((arith)0);
 638         /* Trap handling */
 639         C_cal("_ini_trp");
 640
 641         l2 = genemlabel();
 642         C_rom_ilb(l);
 643         C_lae_dlb(l2, (arith) 0);
 644         C_loi((arith) BEMPTRSIZE);
 645         C_exa_dnam("trpbuf");
 646         C_lae_dnam("trpbuf",(arith)0);
 647         C_cal("setjmp");
 648         C_df_ilb(l);
 649         C_asp((arith)(BEMPTRSIZE+BEMPTRSIZE));
 650         C_lfr((arith)BEMINTSIZE);
 651         C_dup((arith)BEMINTSIZE);
 652         C_zeq((label)0);
 653         C_lae_dnam("returns",(arith)0);
 654         C_csa((arith)BEMINTSIZE);
 655         C_df_ilb((label)0);
 656         C_asp((arith)BEMINTSIZE);
 657         result= sys_open(datfname, OP_WRITE, &datfile);
 658         if ( result==0 ) fatal("improper file creation permission");
 659         gendata();
 660 }
 661
 662
 663
 664 /* NEW */
 665 gendata()
 666 {
 667         C_loc((arith)0);
 668         C_cal("_setchan");
 669         C_asp((arith)BEMINTSIZE);
 670         C_df_dnam("datfname");
 671         C_rom_scon(datfname,(arith)strlen(datfname) + 1);       /* EHB */
 672         C_df_dnam("dattyp");
 673         C_rom_scon("i\\0",(arith)4);
 674         C_df_dnam("datfdes");
 675         C_rom_dnam("datfname",(arith)0);
 676         C_rom_cst((arith)1);
 677         C_rom_cst((arith)(itoa(strlen(datfname))));
 678         C_df_dnam("dattdes");
 679         C_rom_dnam("dattyp",(arith)0);
 680         C_rom_cst((arith)1);
 681         C_rom_cst((arith)1);
 682         C_lae_dnam("dattdes",(arith)0);
 683         C_lae_dnam("datfdes",(arith)0);
 684         C_loc((arith)0);
 685         C_cal("_opnchn");
 686         C_asp((arith)(2*BEMPTRSIZE+BEMINTSIZE));
 687 }
 688
 689
 690
 691 epilogcode()
 692 {
 693         /* finalization code */
 694         int nr;
 695         nr= genlabel();
 696         C_bra((label)nr);
 697         genreturns();
 698         C_df_ilb((label)nr);
 699         datatable(); /* NEW */
 700         C_loc((arith)0);
 701         C_cal("_hlt");
 702         C_df_ilb(err_goto_label);
 703         C_cal("_goto_err");
 704         C_end((arith)0);
 705 }