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 case 1 : /* LOPENRC */
52 openrc(a3, &virt2, &t2);
57 case 2 : /* LBACKADDR */
58 storevirt(thisp->backobj, a1);
59 M[ a2 ] = M[ temporary ];
63 ic++; /* skip the address */
64 raise_signal(a3, M[ ic-1 ], &t1, &t2);
70 openobj(M[ a3 ], &t1, &t2);
75 case 5 : /* LSLOPEN */
77 slopen(M[ a3+APREF ], &virt3, &t1, &t2);
83 virt1.addr = M[ display2+a2 ];
84 virt1.mark = M[ virt1.addr+1 ];
88 case 20 : /* LVIRTDISPL */
91 M[ a1 ] = M[ prototype[ t1 ]->virtlist+a3 ];
94 case 21 : /* LSTATTYPE */
99 case 23 : /* LIPAROUT */
100 M[ a1 ] = param[ a3 ].xword;
103 case 24 : /* LRPAROUT */
104 MR(a1) = param[ a3 ].xreal;
107 case 25 : /* LVPAROUT */
108 storevirt(param[ a3 ].xvirt, a1);
111 case 31 : /* LSIGN */
112 if (M[ a2 ] == 0) M[ a1 ] = 0;
114 if (M[ a2 ] < 0) M[ a1 ] = -1;
118 case 33 : /* LLOWER */
121 if (member(&virt2, &t1))
123 switch ((int) M[ t1+PROTNUM ])
125 case AINT : t2 = APINT; break;
126 case AREAL : t2 = APREAL; break;
127 case AVIRT : t2 = APREF; break;
129 M[ a1 ] = (M[ t1+2 ]+3)/t2;
131 else errsignal(RTEREFTN);
134 case 35 : /* LUPPER */
137 if (member(&virt2, &t1))
139 switch ((int) M[ t1+PROTNUM ])
141 case AINT : t2 = APINT; break;
142 case AREAL : t2 = APREAL; break;
143 case AVIRT : t2 = APREF; break;
145 M[ a1 ] = (M[ t1+2 ]+M[ t1 ])/t2-1;
147 else errsignal(RTEREFTN);
150 case 40 : /* LGETTYPE */
151 typep(M[ a2 ], a3, &virt1.addr, &virt1.mark);
152 storevirt(virt1, a1);
155 case 41 : /* LCOPY */
157 copy(&virt2, &virt1);
158 storevirt(virt1, a1);
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);
171 case 44 : /* LVIRTDOT */
173 M[ a1 ] = M[ prototype[ M[ temporary ] ]->virtlist+a2 ];
176 case 46 : /* LADDRPH */
177 case 47 : /* LADDRPH2 */
178 /* fprintf(stderr, "co ja tu robie?"); */
180 if (!member(&virt2, &M[ a1 ])) errsignal(RTEREFTN);
183 case 48 : /* LIABS */
185 M[ a1 ] = absolute(t2);
188 case 49 : /* LINEG */
192 case 50 : /* LRABS */
199 case 51 : /* LRNEG */
203 case 52 : /* LPARAMADDR */
205 M[ a1 ] = t2+M[ prototype[ M[ t2+PROTNUM ] ]->parlist+a3 ];
208 case 54 : /* LLOADT */
209 t1 = M[ ic++ ]; /* offset */
210 t2 = t1+loadt(M[ M[ a2 ] ], a3); /* object address */
212 storevirt(virt1, a1);
217 M[ a1 ] = lbool(is(&virt2, a3));
222 M[ a1 ] = lbool(inl(&virt2, a3));
227 if (member(&virt2, &M[ a1 ]))
229 else errsignal(RTEREFTN);
232 case 58 : /* LIFIX */
233 M[ a1 ] = (word)( MR(a2) );
236 case 59 : /* LFLOAT */
237 MR(a1) = (real)( M[ a2 ] );
240 case 60 : /* LIMOVE */
244 case 61 : /* LVMOVE */
246 storevirt(virt1, a1);
249 case 62 : /* LRMOVE */ /* WARNING: these areas may overlap! */
254 case 63 : /* LFPMOVE */ /* WARNING: these areas may overlap! */
255 loadvirt(virt1, a2); /* MACHINE DEPENDENT */
257 storevirt(virt1, a1);
261 case 82 : /* LEQNONE */
262 M[ a1 ] = lbool(M[ a2+1 ] != M[ M[ a2 ]+1 ]);
265 case 83 : /* LNENONE */
266 M[ a1 ] = lbool(M[ a2+1 ] == M[ M[ a2 ]+1 ]);
269 case 87 : /* LMDFTYPE */ /* modify the formal type */
271 virt1.addr += a3; /* number of "arrayof" */
272 storevirt(virt1, a1);
276 M[ a1 ] = M[ a2 ] | M[ a3 ];
279 case 101 : /* LAND */
280 M[ a1 ] = M[ a2 ] & M[ a3 ];
283 case 102 : /* LARRAY */
287 if (member(&virt2, &t2))
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;
293 else errsignal(RTEREFTN);
296 case 105 : /* LFARRAY */ /* without any tests */
297 t1 = M[ M[ a2 ] ]; /* physical address */
298 M[ a1 ] = t1+M[ a3 ]-M[ t1+2 ];
301 case 106 : /* LIEQUAL */
302 M[ a1 ] = lbool(M[ a2 ] == M[ a3 ]);
305 case 107 : /* LINEQUAL */
306 M[ a1 ] = lbool(M[ a2 ] != M[ a3 ]);
309 case 108 : /* LILT */
310 M[ a1 ] = lbool(M[ a2 ] < M[ a3 ]);
313 case 109 : /* LILE */
314 M[ a1 ] = lbool(M[ a2 ] <= M[ a3 ]);
317 case 110 : /* LIGT */
318 M[ a1 ] = lbool(M[ a2 ] > M[ a3 ]);
321 case 111 : /* LIGE */
322 M[ a1 ] = lbool(M[ a2 ] >= M[ a3 ]);
325 case 112 : /* LCOMBINE */
328 storevirt(virt2, a1);
332 case 113 : /* LIADD */
333 M[ a1 ] = M[ a2 ]+M[ a3 ];
336 case 114 : /* LISUB */
337 M[ a1 ] = M[ a2 ]-M[ a3 ];
340 case 115 : /* LIMULT */
341 M[ a1 ] = M[ a2 ] * M[ a3 ];
344 case 116 : /* LSHIFT */
345 M[ a1 ] = shift(M[ a2 ], M[ a3 ]);
348 case 117 : /* LIDIVE */
349 if (M[ a3 ] == 0) errsignal(RTEDIVBZ);
350 else M[ a1 ] = M[ a2 ] / M[ a3 ];
353 case 118 : /* LIMODE */
354 if (M[ a3 ] == 0) errsignal(RTEDIVBZ);
355 else M[ a1 ] = M[ a2 ] % M[ a3 ];
358 case 119 : /* LRADD */
359 MR(a1) = MR(a2)+MR(a3);
362 case 120 : /* LRSUB */
363 MR(a1) = MR(a2)-MR(a3);
366 case 121 : /* LRMULT */
367 MR(a1) = MR(a2) * MR(a3);
370 case 122 : /* LRDIVE */
371 if (MR(a3) == (real)0.0) errsignal(RTEDIVBZ);
372 else MR(a1) = MR(a2) / MR(a3);
375 case 123 : /* LEQREF */
378 if (member(&virt2, &t1))
379 M[ a1 ] = lbool(member(&virt3, &t2) && t1 == t2);
380 else M[ a1 ] = lbool(!member(&virt3, &t2));
383 case 124 : /* LNEREF */
386 if (member(&virt2, &t1))
387 M[ a1 ] = lbool(!member(&virt3, &t2) || t1 != t2);
388 else M[ a1 ] = lbool(member(&virt3, &t2));
391 case 125 : /* LREQ */
392 M[ a1 ] = lbool(MR(a2) == MR(a3));
395 case 126 : /* LRNE */
396 M[ a1 ] = lbool(MR(a2) != MR(a3));
399 case 127 : /* LRLT */
400 M[ a1 ] = lbool(MR(a2) < MR(a3));
403 case 128 : /* LRLE */
404 M[ a1 ] = lbool(MR(a2) <= MR(a3));
407 case 129 : /* LRGT */
408 M[ a1 ] = lbool(MR(a2) > MR(a3));
411 case 130 : /* LRGE */
412 M[ a1 ] = lbool(MR(a2) >= MR(a3));
415 case 131 : /* LXOR */
416 M[ a1 ] = M[ a2 ] ^ M[ a3 ];
419 case 132 : /* LCALLPROCSTAND */
421 alarm(0); /* reschedule forced so alarm may be switched off */
427 case 143 : /* LKILL */
432 case 144 : /* LHEADS */
437 case 145 : /* LIPARINP */
438 param[ a3 ].xword = M[ a1 ];
441 case 146 : /* LGKILL */
446 case 147 : /* LVPARINP */
447 loadvirt(param[ a3 ].xvirt, a1);
450 case 148 : /* LRPARINP */
451 param[ a3 ].xreal = MR(a1);
454 case 149 : /* LQUATEST */
459 case 150 : /* LSTYPE */
464 case 151 : /* LIFFALSE */
465 if (M[ a1 ] == LFALSE) ic = a2;
468 case 152 : /* LIFTRUE */
469 if (M[ a1 ] == LTRUE) ic = a2;
473 go(M[ a2 ], M[ a1 ]);
476 case 160 : /* LGOLOCAL */
477 goloc(M[ a2 ], M[ a1 ]);
480 case 170 : /* LDTYPE */
481 loadvirt(virt1, a1); /* left side type */
483 loadvirt(virt3, a3); /* right side type */
484 typed(virt1.addr, virt1.mark, virt3.addr, virt3.mark, &virt2);
487 case 172 : /* LTERMINATE */
491 case 173 : /* LWIND */
495 case 174 : /* LBLOCK2 */
496 goloc(thisp->blck1, thisp->blck2);
499 case 176 : /* LBLOCK3 */
500 disp(&thisp->backobj);
503 case 177 : /* LTRACE */
507 case 178 : /* LINNER */
511 case 180 : /* LBACKHD */
512 backhd(&thisp->backobj, &M[ temporary ]);
515 case 182 : /* LJUMP */
519 case 186 : /* LBLOCK1 */
520 openobj(a1, &thisp->blck1, &thisp->blck2);
523 case 187 : /* LDETACH */
527 case 188 : /* LATTACH */
532 case 191 : /* LBACKBL */
533 backbl(&thisp->backobj, &M[ temporary ]);
536 case 192 : /* LBACKPR */
537 /* backpr(&thisp->backobj, &M[ temporary ]); */
538 back(&thisp->backobj, &M[ temporary ], (word) 0);
541 case 193 : /* LBACK */
542 back(&thisp->backobj, &M[ temporary ], (word) 0);
545 case 194 : /* LFIN */
546 fin(ic-APOPCODE, &thisp->backobj, &M[ temporary ]);
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 */
557 ic = M[ a2+2+t1 ]; /* indirect jump */
560 case 220 : /* LRESUME */
565 case 221 : /* LSTOP */
569 case 222 : /* LKILLTEMP */
570 disp(&thisp->template);
573 case 223 : /* LENABLE */
574 for (i = 0; i < a1; i++)
575 enable(thispix, virtprot(M[ ic++ ]));
576 evaluaterpc(thispix);
579 case 224 : /* LDISABLE */
580 for (i = 0; i < a1; i++)
581 disable(thispix, virtprot(M[ ic++ ]));
584 case 225 : /* LACCEPT1 */
588 case 226 : /* LACCEPT2 */
593 case 227 : /* LBACKRPC */
594 back(&thisp->backobj, &M[ temporary ], a1);
597 case 228 : /* LASKPROT */
602 case 240 : /* LSTEP */
603 if (M[ a1 ] < 0) errsignal(RTENEGST);