int/execute.c

   1 /*     Loglan82 Compiler&Interpreter
   2      Copyright (C) 1993 Institute of Informatics, University of Warsaw
   3      Copyright (C)  1993, 1994 LITA, Pau
   4
   5      This program is free software; you can redistribute it and/or modify
   6      it under the terms of the GNU General Public License as published by
   7      the Free Software Foundation; either version 2 of the License, or
   8      (at your option) any later version.
   9
  10      This program is distributed in the hope that it will be useful,
  11      but WITHOUT ANY WARRANTY; without even the implied warranty of
  12      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13      GNU General Public License for more details.
  14
  15              You should have received a copy of the GNU General Public License
  16              along with this program; if not, write to the Free Software
  17              Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18
  19  contacts:  Andrzej.Salwicki@univ-pau.fr
  20
  21 or             Andrzej Salwicki
  22                 LITA   Departement d'Informatique
  23                 Universite de Pau
  24                 Avenue de l'Universite
  25                 64000 Pau   FRANCE
  26                  tel.  ++33 59923154    fax. ++33 59841696
  27
  28 =======================================================================
  29 */
  30
  31 #include "depend.h"
  32 #include "genint.h"
  33 #include "int.h"
  34 #include "process.h"
  35 #include "intproto.h"
  36
  37 #include <assert.h>
  38
  39
  40 /* Execute one L-code instruction */
  41
  42
  43 void execute()
  44 {
  45     word t1, t2;
  46     int i;
  47     real r;
  48     virtaddr virt1, virt2, virt3;
  49     switch (opcode)
  50     {
  51         case 1   : /* LOPENRC */
  52                 openrc(a3, &virt2, &t2);
  53                 storevirt(virt2, a1);
  54                 M[ a2 ] = t2;
  55                 break;
  56
  57         case 2   : /* LBACKADDR */
  58                 storevirt(thisp->backobj, a1);
  59                 M[ a2 ] = M[ temporary ];
  60                 break;
  61
  62         case 3   : /* LRAISE */
  63                 ic++;                   /* skip the address */
  64                 raise_signal(a3, M[ ic-1 ], &t1, &t2);
  65                 M[ a1 ] = t1;
  66                 M[ a2 ] = t2;
  67                 break;
  68
  69         case 4   : /* LOPEN */
  70                 openobj(M[ a3 ], &t1, &t2);
  71                 M[ a1 ] = t1;
  72                 M[ a2 ] = t2;
  73                 break;
  74
  75         case 5   : /* LSLOPEN */
  76                 loadvirt(virt3, a3);
  77                 slopen(M[ a3+APREF ], &virt3, &t1, &t2);
  78                 M[ a1 ] = t1;
  79                 M[ a2 ] = t2;
  80                 break;
  81
  82         case 15  : /* LTHIS */
  83                 virt1.addr = M[ display2+a2 ];
  84                 virt1.mark = M[ virt1.addr+1 ];
  85                 storevirt(virt1, a1);
  86                 break;
  87
  88         case 20  : /* LVIRTDISPL */
  89                 t2 = M[ display+a2 ];
  90                 t1 = M[ t2+PROTNUM ];
  91                 M[ a1 ] = M[ prototype[ t1 ]->virtlist+a3 ];
  92                 break;
  93
  94         case 21  : /* LSTATTYPE */
  95                 M[ a1 ] = a2;
  96                 M[ a1+1 ] = a3;
  97                 break;
  98
  99         case 23  : /* LIPAROUT */
 100                 M[ a1 ] = param[ a3 ].xword;
 101                 break;
 102
 103         case 24  : /* LRPAROUT */
 104                 MR(a1) = param[ a3 ].xreal;
 105                 break;
 106
 107         case 25  : /* LVPAROUT */
 108                 storevirt(param[ a3 ].xvirt, a1);
 109                 break;
 110
 111         case 31  : /* LSIGN */
 112                 if (M[ a2 ] == 0) M[ a1 ] = 0;
 113                 else
 114                     if (M[ a2 ] < 0) M[ a1 ] = -1;
 115                     else M[ a1 ] = 1;
 116                 break;
 117
 118         case 33  : /* LLOWER */
 119         case 34  :
 120                 loadvirt(virt2, a2);
 121                 if (member(&virt2, &t1))
 122                 {
 123                     switch ((int) M[ t1+PROTNUM ])
 124                     {
 125                         case AINT  :  t2 = APINT;   break;
 126                         case AREAL :  t2 = APREAL;  break;
 127                         case AVIRT :  t2 = APREF;   break;
 128                     }
 129                     M[ a1 ] = (M[ t1+2 ]+3)/t2;
 130                 }
 131                 else errsignal(RTEREFTN);
 132                 break;
 133
 134         case 35  : /* LUPPER */
 135         case 36  :
 136                 loadvirt(virt2, a2);
 137                 if (member(&virt2, &t1))
 138                 {
 139                     switch ((int) M[ t1+PROTNUM ])
 140                     {
 141                         case AINT  :  t2 = APINT;   break;
 142                         case AREAL :  t2 = APREAL;  break;
 143                         case AVIRT :  t2 = APREF;   break;
 144                     }
 145                     M[ a1 ] = (M[ t1+2 ]+M[ t1 ])/t2-1;
 146                 }
 147                 else errsignal(RTEREFTN);
 148                 break;
 149
 150         case 40  : /* LGETTYPE */
 151                 typep(M[ a2 ], a3, &virt1.addr, &virt1.mark);
 152                 storevirt(virt1, a1);
 153                 break;
 154
 155         case 41  : /* LCOPY */
 156                 loadvirt(virt2, a2);
 157                 copy(&virt2, &virt1);
 158                 storevirt(virt1, a1);
 159                 break;
 160
 161         case 42  : /* LNOT */
 162                 M[ a1 ] = ~ M[ a2 ];
 163                 break;
 164
 165         case 43  : /* LRCVAVIRT */      /* recover virtual address from ah */
 166                 virt1.addr = M[ a2 ];
 167                 virt1.mark = M[ virt1.addr+1 ];
 168                 storevirt(virt1, a1);
 169                 break;
 170
 171         case 44  : /* LVIRTDOT */
 172         case 45  :
 173                 M[ a1 ] = M[ prototype[ M[ temporary ] ]->virtlist+a2 ];
 174                 break;
 175
 176         case 46  : /* LADDRPH */
 177         case 47  : /* LADDRPH2 */
 178             /*    fprintf(stderr, "co ja tu robie?"); */
 179                 loadvirt(virt2, a2);
 180                 if (!member(&virt2, &M[ a1 ])) errsignal(RTEREFTN);
 181                 break;
 182
 183         case 48  : /* LIABS */
 184                 t2 = M[ a2 ];
 185                 M[ a1 ] = absolute(t2);
 186                 break;
 187
 188         case 49  : /* LINEG */
 189                 M[ a1 ] = -M[ a2 ];
 190                 break;
 191
 192         case 50  : /* LRABS */
 193                 r = MR(a2);
 194                 if( r < (real)0.0 )
 195                    r=(real)0.0-r;
 196                 MR(a1) = r;
 197                 break;
 198
 199         case 51  : /* LRNEG */
 200                 MR(a1) = -MR(a2);
 201                 break;
 202
 203         case 52  : /* LPARAMADDR */
 204                 t2 = M[ a2 ];
 205                 M[ a1 ] = t2+M[ prototype[ M[ t2+PROTNUM ] ]->parlist+a3 ];
 206                 break;
 207
 208         case 54  : /* LLOADT */
 209                 t1 = M[ ic++ ];         /* offset */
 210                 t2 = t1+loadt(M[ M[ a2 ] ], a3);  /* object address */
 211                 loadvirt(virt1, t2);
 212                 storevirt(virt1, a1);
 213                 break;
 214
 215         case 55  : /* LIS */
 216                 loadvirt(virt2, a2);
 217                 M[ a1 ] = lbool(is(&virt2, a3));
 218                 break;
 219
 220         case 56  : /* LIN */
 221                 loadvirt(virt2, a2);
 222                 M[ a1 ] = lbool(inl(&virt2, a3));
 223                 break;
 224
 225         case 57  : /* LQUA */
 226                 loadvirt(virt2, a2);
 227                 if (member(&virt2, &M[ a1 ]))
 228                     qua(&virt2, a3);
 229                 else errsignal(RTEREFTN);
 230                 break;
 231
 232         case 58  : /* LIFIX */
 233                 M[ a1 ] = (word)( MR(a2) );
 234                 break;
 235
 236         case 59  : /* LFLOAT */
 237                 MR(a1) = (real)( M[ a2 ] );
 238                 break;
 239
 240         case 60  : /* LIMOVE */
 241                 M[ a1 ] = M[ a2 ];
 242                 break;
 243
 244         case 61  : /* LVMOVE */
 245                 loadvirt(virt1, a2);
 246                 storevirt(virt1, a1);
 247                 break;
 248
 249         case 62  : /* LRMOVE */         /* WARNING: these areas may overlap! */
 250                 r = MR(a2);
 251                 MR(a1) = r;
 252                 break;
 253
 254         case 63  : /* LFPMOVE */        /* WARNING: these areas may overlap! */
 255                 loadvirt(virt1, a2);    /* MACHINE DEPENDENT */
 256                 t1 = M[ a2+2 ];
 257                 storevirt(virt1, a1);
 258                 M[ a1+2 ] = t1;
 259                 break;
 260
 261         case 82  : /* LEQNONE */
 262                 M[ a1 ] = lbool(M[ a2+1 ] != M[ M[ a2 ]+1 ]);
 263                 break;
 264
 265         case 83  : /* LNENONE */
 266                 M[ a1 ] = lbool(M[ a2+1 ] == M[ M[ a2 ]+1 ]);
 267                 break;
 268
 269         case 87  : /* LMDFTYPE */       /* modify the formal type */
 270                 loadvirt(virt1, a2);
 271                 virt1.addr += a3;       /* number of "arrayof" */
 272                 storevirt(virt1, a1);
 273                 break;
 274
 275         case 100 : /* LOR */
 276                 M[ a1 ] = M[ a2 ] | M[ a3 ];
 277                 break;
 278
 279         case 101 : /* LAND */
 280                 M[ a1 ] = M[ a2 ] & M[ a3 ];
 281                 break;
 282
 283         case 102 : /* LARRAY */
 284         case 103 :
 285         case 104 :
 286                 loadvirt(virt2, a2);
 287                 if (member(&virt2, &t2))
 288                 {
 289                     t1 = M[ a3 ]-M[ t2+2 ];     /* index-lower+3 */
 290                     if (t1 < 3 || t1 >= M[ t2 ]) errsignal(RTEINVIN);
 291                     else M[ a1 ] = t2+t1;
 292                 }
 293                 else errsignal(RTEREFTN);
 294                 break;
 295
 296         case 105 : /* LFARRAY */        /* without any tests */
 297                 t1 = M[ M[ a2 ] ];      /* physical address */
 298                 M[ a1 ] = t1+M[ a3 ]-M[ t1+2 ];
 299                 break;
 300
 301         case 106 : /* LIEQUAL */
 302                 M[ a1 ] = lbool(M[ a2 ] == M[ a3 ]);
 303                 break;
 304
 305         case 107 : /* LINEQUAL */
 306                 M[ a1 ] = lbool(M[ a2 ] != M[ a3 ]);
 307                 break;
 308
 309         case 108 : /* LILT */
 310                 M[ a1 ] = lbool(M[ a2 ] < M[ a3 ]);
 311                 break;
 312
 313         case 109 : /* LILE */
 314                 M[ a1 ] = lbool(M[ a2 ] <= M[ a3 ]);
 315                 break;
 316
 317         case 110 : /* LIGT */
 318                 M[ a1 ] = lbool(M[ a2 ] > M[ a3 ]);
 319                 break;
 320
 321         case 111 : /* LIGE */
 322                 M[ a1 ] = lbool(M[ a2 ] >= M[ a3 ]);
 323                 break;
 324
 325         case 112 : /* LCOMBINE */
 326                 loadvirt(virt2, a2);
 327                 t1 = M[ a3 ];
 328                 storevirt(virt2, a1);
 329                 M[ a1+APREF ] = t1;
 330                 break;
 331
 332         case 113 : /* LIADD */
 333                 M[ a1 ] = M[ a2 ]+M[ a3 ];
 334                 break;
 335
 336         case 114 : /* LISUB */
 337                 M[ a1 ] = M[ a2 ]-M[ a3 ];
 338                 break;
 339
 340         case 115 : /* LIMULT */
 341                 M[ a1 ] = M[ a2 ] * M[ a3 ];
 342                 break;
 343
 344         case 116 : /* LSHIFT */
 345                 M[ a1 ] = shift(M[ a2 ], M[ a3 ]);
 346                 break;
 347
 348         case 117 : /* LIDIVE */
 349                 if (M[ a3 ] == 0) errsignal(RTEDIVBZ);
 350                 else M[ a1 ] = M[ a2 ] / M[ a3 ];
 351                 break;
 352
 353         case 118 : /* LIMODE */
 354                 if (M[ a3 ] == 0) errsignal(RTEDIVBZ);
 355                 else M[ a1 ] = M[ a2 ] % M[ a3 ];
 356                 break;
 357
 358         case 119 : /* LRADD */
 359                 MR(a1) = MR(a2)+MR(a3);
 360                 break;
 361
 362         case 120 : /* LRSUB */
 363                 MR(a1) = MR(a2)-MR(a3);
 364                 break;
 365
 366         case 121 : /* LRMULT */
 367                 MR(a1) = MR(a2) * MR(a3);
 368                 break;
 369
 370         case 122 : /* LRDIVE */
 371                 if (MR(a3) == (real)0.0) errsignal(RTEDIVBZ);
 372                 else MR(a1) = MR(a2) / MR(a3);
 373                 break;
 374
 375         case 123 : /* LEQREF */
 376                 loadvirt(virt2, a2);
 377                 loadvirt(virt3, a3);
 378                 if (member(&virt2, &t1))
 379                     M[ a1 ] = lbool(member(&virt3, &t2) && t1 == t2);
 380                 else M[ a1 ] = lbool(!member(&virt3, &t2));
 381                 break;
 382
 383         case 124 : /* LNEREF */
 384                 loadvirt(virt2, a2);
 385                 loadvirt(virt3, a3);
 386                 if (member(&virt2, &t1))
 387                     M[ a1 ] = lbool(!member(&virt3, &t2) || t1 != t2);
 388                 else M[ a1 ] = lbool(member(&virt3, &t2));
 389                 break;
 390
 391         case 125 : /* LREQ */
 392                 M[ a1 ] = lbool(MR(a2) == MR(a3));
 393                 break;
 394
 395         case 126 : /* LRNE */
 396                 M[ a1 ] = lbool(MR(a2) != MR(a3));
 397                 break;
 398
 399         case 127 : /* LRLT */
 400                 M[ a1 ] = lbool(MR(a2) < MR(a3));
 401                 break;
 402
 403         case 128 : /* LRLE */
 404                 M[ a1 ] = lbool(MR(a2) <= MR(a3));
 405                 break;
 406
 407         case 129 : /* LRGT */
 408                 M[ a1 ] = lbool(MR(a2) > MR(a3));
 409                 break;
 410
 411         case 130 : /* LRGE */
 412                 M[ a1 ] = lbool(MR(a2) >= MR(a3));
 413                 break;
 414
 415         case 131 : /* LXOR */
 416                 M[ a1 ] = M[ a2 ] ^ M[ a3 ];
 417                 break;
 418
 419         case 132 : /* LCALLPROCSTAND */
 420 #if USE_ALARM
 421                 alarm(0);     /* reschedule forced so alarm may be switched off */
 422 #endif
 423       reschedule=TRUE;
 424                 standard(a1);
 425                 break;
 426
 427         case 143 : /* LKILL */
 428                 loadvirt(virt1, a1);
 429                 disp(&virt1);
 430                 break;
 431
 432         case 144 : /* LHEADS */
 433                 loadvirt(virt1, a1);
 434                 heads(&virt1, a2);
 435                 break;
 436
 437         case 145 : /* LIPARINP */
 438                 param[ a3 ].xword = M[ a1 ];
 439                 break;
 440
 441         case 146 : /* LGKILL */
 442                 loadvirt(virt1, a1);
 443                 gkill(&virt1);
 444                 break;
 445
 446         case 147 : /* LVPARINP */
 447                 loadvirt(param[ a3 ].xvirt, a1);
 448                 break;
 449
 450         case 148 : /* LRPARINP */
 451                 param[ a3 ].xreal = MR(a1);
 452                 break;
 453
 454         case 149 : /* LQUATEST */
 455                 loadvirt(virt1, a1);
 456                 qua(&virt1, a2);
 457                 break;
 458
 459         case 150 : /* LSTYPE */
 460                 loadvirt(virt1, a1);
 461                 typref(&virt1, a2);
 462                 break;
 463
 464         case 151 : /* LIFFALSE */
 465                 if (M[ a1 ] == LFALSE) ic = a2;
 466                 break;
 467
 468         case 152 : /* LIFTRUE */
 469                 if (M[ a1 ] == LTRUE) ic = a2;
 470                 break;
 471
 472         case 159 : /* LGO */
 473                 go(M[ a2 ], M[ a1 ]);
 474                 break;
 475
 476         case 160 : /* LGOLOCAL */
 477                 goloc(M[ a2 ], M[ a1 ]);
 478                 break;
 479
 480         case 170 : /* LDTYPE */
 481                 loadvirt(virt1, a1);    /* left side type */
 482                 loadvirt(virt2, a2);
 483                 loadvirt(virt3, a3);    /* right side type */
 484                 typed(virt1.addr, virt1.mark, virt3.addr, virt3.mark, &virt2);
 485                 break;
 486
 487         case 172 : /* LTERMINATE */
 488                 term();
 489                 break;
 490
 491         case 173 : /* LWIND */
 492                 wind();
 493                 break;
 494
 495         case 174 : /* LBLOCK2 */
 496                 goloc(thisp->blck1, thisp->blck2);
 497                 break;
 498
 499         case 176 : /* LBLOCK3 */
 500                 disp(&thisp->backobj);
 501                 break;
 502
 503         case 177 : /* LTRACE */
 504                 trace(a1);
 505                 break;
 506
 507         case 178 : /* LINNER */
 508                 inner(a1);
 509                 break;
 510
 511         case 180 : /* LBACKHD */
 512                 backhd(&thisp->backobj, &M[ temporary ]);
 513                 break;
 514
 515         case 182 : /* LJUMP */
 516                 ic = a1;
 517                 break;
 518
 519         case 186 : /* LBLOCK1 */
 520                 openobj(a1, &thisp->blck1, &thisp->blck2);
 521                 break;
 522
 523         case 187 : /* LDETACH */
 524                 detach();
 525                 break;
 526
 527         case 188 : /* LATTACH */
 528                 loadvirt(virt1, a1);
 529                 attach(&virt1);
 530                 break;
 531
 532         case 191 : /* LBACKBL */
 533                 backbl(&thisp->backobj, &M[ temporary ]);
 534                 break;
 535
 536         case 192 : /* LBACKPR */
 537              /* backpr(&thisp->backobj, &M[ temporary ]); */
 538                 back(&thisp->backobj, &M[ temporary ], (word) 0);
 539                 break;
 540
 541         case 193 : /* LBACK */
 542                 back(&thisp->backobj, &M[ temporary ], (word) 0);
 543                 break;
 544
 545         case 194 : /* LFIN */
 546                 fin(ic-APOPCODE, &thisp->backobj, &M[ temporary ]);
 547                 break;
 548
 549         case 195 : /* LCASE */
 550                 /* a2 = address of case description : */
 551                 /* minimal value, number of branches, */
 552                 /* remaining branches followed by "otherwise" code */
 553                 t1 = M[ a1 ]-M[ a2 ];   /* in 0..number of branches-1 */
 554                 if (t1 < 0 || t1 >= M[ a2+1 ])
 555                     ic = a2+2+M[ a2+1 ];  /* otherwise */
 556                 else
 557                     ic = M[ a2+2+t1 ];  /* indirect jump */
 558                 break;
 559
 560         case 220 : /* LRESUME */
 561                 loadvirt(virt1, a1);
 562                 resume(&virt1);
 563                 break;
 564
 565         case 221 : /* LSTOP */
 566                 passivate(STOPPED);
 567                 break;
 568
 569         case 222 : /* LKILLTEMP */
 570                 disp(&thisp->template);
 571                 break;
 572
 573         case 223 : /* LENABLE */
 574                 for (i = 0;  i < a1;  i++)
 575                     enable(thispix, virtprot(M[ ic++ ]));
 576                 evaluaterpc(thispix);
 577                 break;
 578
 579         case 224 : /* LDISABLE */
 580                 for (i = 0;  i < a1;  i++)
 581                     disable(thispix, virtprot(M[ ic++ ]));
 582                 break;
 583
 584         case 225 : /* LACCEPT1 */
 585                 rpc_accept(a1);
 586                 break;
 587
 588         case 226 : /* LACCEPT2 */
 589                 popmask(thispix);
 590                 rpc3();
 591                 break;
 592
 593         case 227 : /* LBACKRPC */
 594                 back(&thisp->backobj, &M[ temporary ], a1);
 595                 break;
 596
 597         case 228 : /* LASKPROT */
 598                 loadvirt(virt1, a1);
 599                 askprot(&virt1);
 600                 break;
 601
 602         case 240 : /* LSTEP */
 603                 if (M[ a1 ] < 0) errsignal(RTENEGST);
 604                 break;
 605
 606         default  :
 607                 break;
 608     }
 609 }
 610
 611