1 /* Loglan82 Compiler&Interpreter
2 Copyright (C) 1993 Institute of Informatics, University of Warsaw
3 Copyright (C) 1993, 1994 LITA, Pau
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.
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.
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.
19 contacts: Andrzej.Salwicki@univ-pau.fr
22 LITA Departement d'Informatique
24 Avenue de l'Universite
26 tel. ++33 59923154 fax. ++33 59841696
28 =======================================================================
40 /* Execute one L-code instruction */
48 virtaddr virt1, virt2, virt3;
51 fprintf(stderr,"pix %d,ic %d,opcode %d\n",thispix,ic,opcode);fflush(stderr);
56 case 1 : /* LOPENRC */
57 openrc(a3, &virt2, &t2);
62 case 2 : /* LBACKADDR */
63 storevirt(thisp->backobj, a1);
64 M[ a2 ] = M[ temporary ];
68 ic++; /* skip the address */
69 raise_signal(a3, M[ ic-1 ], &t1, &t2);
75 openobj(M[ a3 ], &t1, &t2);
80 case 5 : /* LSLOPEN */
82 slopen(M[ a3+APREF ], &virt3, &t1, &t2);
88 virt1.addr = M[ display2+a2 ];
89 virt1.mark = M[ virt1.addr+1 ];
93 case 20 : /* LVIRTDISPL */
96 M[ a1 ] = M[ prototype[ t1 ]->virtlist+a3 ];
99 case 21 : /* LSTATTYPE */
104 case 23 : /* LIPAROUT */
105 M[ a1 ] = param[ a3 ].xword;
108 case 24 : /* LRPAROUT */
109 MR(a1) = param[ a3 ].xreal;
112 case 25 : /* LVPAROUT */
113 storevirt(param[ a3 ].xvirt, a1);
116 case 31 : /* LSIGN */
117 if (M[ a2 ] == 0) M[ a1 ] = 0;
119 if (M[ a2 ] < 0) M[ a1 ] = -1;
123 case 33 : /* LLOWER */
126 if (member(&virt2, &t1))
128 switch ((int) M[ t1+PROTNUM ])
130 case AINT : t2 = APINT; break;
131 case AREAL : t2 = APREAL; break;
132 case AVIRT : t2 = APREF; break;
134 M[ a1 ] = (M[ t1+2 ]+3)/t2;
136 else errsignal(RTEREFTN);
139 case 35 : /* LUPPER */
142 if (member(&virt2, &t1))
144 switch ((int) M[ t1+PROTNUM ])
146 case AINT : t2 = APINT; break;
147 case AREAL : t2 = APREAL; break;
148 case AVIRT : t2 = APREF; break;
150 M[ a1 ] = (M[ t1+2 ]+M[ t1 ])/t2-1;
152 else errsignal(RTEREFTN);
155 case 40 : /* LGETTYPE */
156 typep(M[ a2 ], a3, &virt1.addr, &virt1.mark);
157 storevirt(virt1, a1);
160 case 41 : /* LCOPY */
162 copy(&virt2, &virt1);
163 storevirt(virt1, a1);
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);
176 case 44 : /* LVIRTDOT */
178 M[ a1 ] = M[ prototype[ M[ temporary ] ]->virtlist+a2 ];
181 case 46 : /* LADDRPH */
182 case 47 : /* LADDRPH2 */
184 if (!member(&virt2, &M[ a1 ])) errsignal(RTEREFTN);
187 case 48 : /* LIABS */
189 M[ a1 ] = absolute(t2);
192 case 49 : /* LINEG */
196 case 50 : /* LRABS */
203 case 51 : /* LRNEG */
207 case 52 : /* LPARAMADDR */
209 M[ a1 ] = t2+M[ prototype[ M[ t2+PROTNUM ] ]->parlist+a3 ];
212 case 54 : /* LLOADT */
213 t1 = M[ ic++ ]; /* offset */
214 t2 = t1+loadt(M[ M[ a2 ] ], a3); /* object address */
216 storevirt(virt1, a1);
221 M[ a1 ] = lbool(is(&virt2, a3));
226 M[ a1 ] = lbool(inl(&virt2, a3));
231 if (member(&virt2, &M[ a1 ]))
233 else errsignal(RTEREFTN);
236 case 58 : /* LIFIX */
237 M[ a1 ] = (word)( MR(a2) );
240 case 59 : /* LFLOAT */
241 MR(a1) = (real)( M[ a2 ] );
244 case 60 : /* LIMOVE */
248 case 61 : /* LVMOVE */
250 storevirt(virt1, a1);
253 case 62 : /* LRMOVE */ /* WARNING: these areas may overlap! */
258 case 63 : /* LFPMOVE */ /* WARNING: these areas may overlap! */
259 loadvirt(virt1, a2); /* MACHINE DEPENDENT */
261 storevirt(virt1, a1);
265 case 82 : /* LEQNONE */
266 M[ a1 ] = lbool(M[ a2+1 ] != M[ M[ a2 ]+1 ]);
269 case 83 : /* LNENONE */
270 M[ a1 ] = lbool(M[ a2+1 ] == M[ M[ a2 ]+1 ]);
273 case 87 : /* LMDFTYPE */ /* modify the formal type */
275 virt1.addr += a3; /* number of "arrayof" */
276 storevirt(virt1, a1);
280 M[ a1 ] = M[ a2 ] | M[ a3 ];
283 case 101 : /* LAND */
284 M[ a1 ] = M[ a2 ] & M[ a3 ];
287 case 102 : /* LARRAY */
291 if (member(&virt2, &t2))
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;
297 else errsignal(RTEREFTN);
300 case 105 : /* LFARRAY */ /* without any tests */
301 t1 = M[ M[ a2 ] ]; /* physical address */
302 M[ a1 ] = t1+M[ a3 ]-M[ t1+2 ];
305 case 106 : /* LIEQUAL */
306 M[ a1 ] = lbool(M[ a2 ] == M[ a3 ]);
309 case 107 : /* LINEQUAL */
310 M[ a1 ] = lbool(M[ a2 ] != M[ a3 ]);
313 case 108 : /* LILT */
314 M[ a1 ] = lbool(M[ a2 ] < M[ a3 ]);
317 case 109 : /* LILE */
318 M[ a1 ] = lbool(M[ a2 ] <= M[ a3 ]);
321 case 110 : /* LIGT */
322 M[ a1 ] = lbool(M[ a2 ] > M[ a3 ]);
325 case 111 : /* LIGE */
326 M[ a1 ] = lbool(M[ a2 ] >= M[ a3 ]);
329 case 112 : /* LCOMBINE */
332 storevirt(virt2, a1);
336 case 113 : /* LIADD */
337 M[ a1 ] = M[ a2 ]+M[ a3 ];
340 case 114 : /* LISUB */
341 M[ a1 ] = M[ a2 ]-M[ a3 ];
344 case 115 : /* LIMULT */
345 M[ a1 ] = M[ a2 ] * M[ a3 ];
348 case 116 : /* LSHIFT */
349 M[ a1 ] = shift(M[ a2 ], M[ a3 ]);
352 case 117 : /* LIDIVE */
353 if (M[ a3 ] == 0) errsignal(RTEDIVBZ);
354 else M[ a1 ] = M[ a2 ] / M[ a3 ];
357 case 118 : /* LIMODE */
358 if (M[ a3 ] == 0) errsignal(RTEDIVBZ);
359 else M[ a1 ] = M[ a2 ] % M[ a3 ];
362 case 119 : /* LRADD */
363 MR(a1) = MR(a2)+MR(a3);
366 case 120 : /* LRSUB */
367 MR(a1) = MR(a2)-MR(a3);
370 case 121 : /* LRMULT */
371 MR(a1) = MR(a2) * MR(a3);
374 case 122 : /* LRDIVE */
375 if (MR(a3) == (real)0.0) errsignal(RTEDIVBZ);
376 else MR(a1) = MR(a2) / MR(a3);
379 case 123 : /* LEQREF */
382 if (member(&virt2, &t1))
383 M[ a1 ] = lbool(member(&virt3, &t2) && t1 == t2);
384 else M[ a1 ] = lbool(!member(&virt3, &t2));
387 case 124 : /* LNEREF */
390 if (member(&virt2, &t1))
391 M[ a1 ] = lbool(!member(&virt3, &t2) || t1 != t2);
392 else M[ a1 ] = lbool(member(&virt3, &t2));
395 case 125 : /* LREQ */
396 M[ a1 ] = lbool(MR(a2) == MR(a3));
399 case 126 : /* LRNE */
400 M[ a1 ] = lbool(MR(a2) != MR(a3));
403 case 127 : /* LRLT */
404 M[ a1 ] = lbool(MR(a2) < MR(a3));
407 case 128 : /* LRLE */
408 M[ a1 ] = lbool(MR(a2) <= MR(a3));
411 case 129 : /* LRGT */
412 M[ a1 ] = lbool(MR(a2) > MR(a3));
415 case 130 : /* LRGE */
416 M[ a1 ] = lbool(MR(a2) >= MR(a3));
419 case 131 : /* LXOR */
420 M[ a1 ] = M[ a2 ] ^ M[ a3 ];
423 case 132 : /* LCALLPROCSTAND */
425 alarm(0); /* reschedule forced so alarm may be switched off */
431 case 143 : /* LKILL */
436 case 144 : /* LHEADS */
441 case 145 : /* LIPARINP */
442 param[ a3 ].xword = M[ a1 ];
445 case 146 : /* LGKILL */
450 case 147 : /* LVPARINP */
451 loadvirt(param[ a3 ].xvirt, a1);
454 case 148 : /* LRPARINP */
455 param[ a3 ].xreal = MR(a1);
458 case 149 : /* LQUATEST */
463 case 150 : /* LSTYPE */
468 case 151 : /* LIFFALSE */
469 if (M[ a1 ] == LFALSE) ic = a2;
472 case 152 : /* LIFTRUE */
473 if (M[ a1 ] == LTRUE) ic = a2;
477 go(M[ a2 ], M[ a1 ]);
480 case 160 : /* LGOLOCAL */
481 goloc(M[ a2 ], M[ a1 ]);
484 case 170 : /* LDTYPE */
485 loadvirt(virt1, a1); /* left side type */
487 loadvirt(virt3, a3); /* right side type */
488 typed(virt1.addr, virt1.mark, virt3.addr, virt3.mark, &virt2);
491 case 172 : /* LTERMINATE */
495 case 173 : /* LWIND */
499 case 174 : /* LBLOCK2 */
500 goloc(thisp->blck1, thisp->blck2);
503 case 176 : /* LBLOCK3 */
504 disp(&thisp->backobj);
507 case 177 : /* LTRACE */
511 case 178 : /* LINNER */
515 case 180 : /* LBACKHD */
516 backhd(&thisp->backobj, &M[ temporary ]);
519 case 182 : /* LJUMP */
523 case 186 : /* LBLOCK1 */
524 openobj(a1, &thisp->blck1, &thisp->blck2);
527 case 187 : /* LDETACH */
531 case 188 : /* LATTACH */
536 case 191 : /* LBACKBL */
537 backbl(&thisp->backobj, &M[ temporary ]);
540 case 192 : /* LBACKPR */
541 /* backpr(&thisp->backobj, &M[ temporary ]); */
542 back(&thisp->backobj, &M[ temporary ], (word) 0);
545 case 193 : /* LBACK */
546 back(&thisp->backobj, &M[ temporary ], (word) 0);
549 case 194 : /* LFIN */
550 fin(ic-APOPCODE, &thisp->backobj, &M[ temporary ]);
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 */
561 ic = M[ a2+2+t1 ]; /* indirect jump */
564 case 220 : /* LRESUME */
569 case 221 : /* LSTOP */
573 case 222 : /* LKILLTEMP */
574 disp(&thisp->template);
577 case 223 : /* LENABLE */
578 for (i = 0; i < a1; i++)
579 enable(thispix, virtprot(M[ ic++ ]));
580 evaluaterpc(thispix);
583 case 224 : /* LDISABLE */
584 for (i = 0; i < a1; i++)
585 disable(thispix, virtprot(M[ ic++ ]));
588 case 225 : /* LACCEPT1 */
592 case 226 : /* LACCEPT2 */
597 case 227 : /* LBACKRPC */
598 back(&thisp->backobj, &M[ temporary ], a1);
601 case 228 : /* LASKPROT */
606 case 240 : /* LSTEP */
607 if (M[ a1 ] < 0) errsignal(RTENEGST);
611 fprintf( stderr, "Invalid opcode\n" );