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