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 =======================================================================
37 /* Transfer of control routines */
40 static void att2(virtaddr *, word, word);
41 static void back1(word, word, virtaddr *, word *);
47 /* Transfer control to the newly created object.
54 word pnum, plen, node, apt;
57 ptr = prototype[ M[ am+PROTNUM ] ];
59 if (ptr->kind == PROCESS) /* new process creation */
61 thisp->template.addr = ah; /* save template address */
62 thisp->template.mark = M[ ah+1 ];
63 msg.control.type = CREATE;
64 msg.control.par = M[ am+PROTNUM ];
65 moveparams(thispix, am, &msg, PARIN, LOADPAR);
66 msg.control.receiver.pix = 0; /* pix will create receiver */
67 msg.control.receiver.mark= 0; /* mark will create receiver */
68 msg.control.receiver.node = getnode(am); /* node we decided */
69 sendmsg1( &msg); /* send create request */
72 stderr, "send new process from %d to node %d\n",
74 msg.control.receiver.node
77 passivate(WAITFORNEW); /* and wait for return from process */
80 if (isprocess((virtaddr*)(M+apt+SL))) /* remote procedure call */
82 thisp->backobj.addr = ah; /* save template address */
83 thisp->backobj.mark = M[ ah+1 ];
84 thisp->M[ temporary ] = am; /* physical address also */
87 loadvirt( v, apt+SL );
88 obj2mess( M, &v, &msg.control.receiver );
91 stderr, "send rpc from process %d to (%d,%d,%d)\n",
93 msg.control.receiver.node,
94 msg.control.receiver.pix,
95 msg.control.receiver.mark
99 msg.control.type = RPCALL;
100 msg.control.par = M[ am+PROTNUM ];
101 moveparams(thispix, am, &msg, PARIN, LOADPAR);
102 sendmsg1( &msg); /* send RPC request */
103 passivate(WAITFORRPC); /* and wait for RP return */
107 M[ c1+M[ c1 ]+LSC ] = ic; /* save local control */
108 loosen(); /* release DISPLAY */
109 update(am, ah); /* update DISPLAY */
110 c1 = am; /* new current */
112 pnum = ptr->preflist;
113 plen = ptr->lthpreflist;
114 while (TRUE) /* search for executable prefix */
122 ptr = prototype[ M[ pnum ] ];
125 if (ptr->kind != RECORD) plen = 0;
131 /* Transfer control to a local unprefixed procedure, function, block,
132 * class or coroutine.
141 M[ c1+M[ c1 ]+LSC ] = ic; /* save local control */
142 c1 = am; /* new current */
143 t1 = M[ am+PROTNUM ];
144 ptr = prototype[ t1 ];
147 M[ display+t1 ] = am; /* simulate update display */
148 M[ display2+t1 ] = ah;
149 M[ am+M[ am ]+STATSL ]++;
153 void backbl(virt, am) /* Return from block. */
159 t1 = M[ c1+PROTNUM ];
160 virt->addr = M[ display2+t1 ];
161 virt->mark = M[ virt->addr+1 ]; /* prepare old address */
162 *am = c1; /* am of old */
163 M[ display+t1 ] = 0; /* simulate loosen */
165 M[ t1+STATSL ]--; /* remove from SL chain */
166 c1 = M[ t1+SL ]; /* return up along SL */
167 if (c1 == DUMMY) endprocess(0); /* return from main */
168 c1 = M[ c1 ]; /* am of new current */
169 c2 = c1+prototype[ M[ c1+PROTNUM ] ]->span;
170 ic = M[ c1+M[ c1 ]+LSC ];
171 storevirt(*virt, *am+M[ *am ]+DL); /* force DL consistency */
175 static void back1(at1, at2, virt, am) /* Common code for some backs below. */
183 if (at1 == 0) endprocess(0);
184 t1 = M[ c1+PROTNUM ];
185 virt->addr = M[ display2+t1 ]; /* ah of old */
186 virt->mark = M[ virt->addr+1 ];
187 *am = c1; /* am of old */
188 storevirt(*virt, at2); /* loop up DL */
189 at2 = M[ at1 ]; /* am of DL */
192 c2 = c1 + prototype[ M[ c1+PROTNUM ] ]->span;
193 ic = M[ c1+M[ c1 ]+LSC ];
197 /* Return from classes, coroutines and by end from procedures.
200 void back(virt, am, length)
211 t1 = M[ t2+DL ]; /* ah of DL */
212 ptr = prototype[ M[ c1+PROTNUM ] ]; /* prototype of current */
213 if (ptr->kind == PROCESS) /* RETURN in process */
216 fprintf( stderr, "return from process %d\n", thispix );
218 if (M[ c1+PROTNUM ] == MAINBLOCK) endprocess(0);
221 loadvirt( v, t2+DL );
222 obj2mess( M, &v, &msg.control.receiver ); /* father process */
224 msg.control.type = CREACK;
225 moveparams(thispix, c1, &msg, PAROUT, LOADPAR);
226 sendmsg1(&msg); /* send create acknowledge */
227 M[ t2+DL ] = 0; /* cut DL of new process head */
228 passivate(STOPPED); /* and suspend new process */
231 if (ptr->kind == COROUTINE)
233 if (t1 != 0) /* nothing if detached */
236 back1(t1, t2+DL, virt, am);
241 plist = ic; /* save begining of prototype list */
242 if (ptr->lthpreflist==1 && t1==M[t2+SL] && M[t2+DL+1]==M[t2+SL+1])
245 back1(t1, t2+DL, virt, am);
250 stderr, "back (thisp=%d) from %s to %s\n",
253 (ptr->kind==PROCEDURE) ?
255 (ptr->kind==FUNCTION) ?
259 isprocess((virtaddr*)(M+t2+RPCDL)) ? "PROCESS" : "OBJECT"
263 if ((ptr->kind == PROCEDURE || ptr->kind == FUNCTION) &&
264 isprocess((virtaddr*)(M+t2+RPCDL)))
268 loadvirt( v, t2+RPCDL );
269 obj2mess( M, &v, &msg.control.receiver ); /* remote DL */
273 stderr, "send rpc ack from process %d to (%d,%d,%d)\n",
275 msg.control.receiver.node,
276 msg.control.receiver.pix,
277 msg.control.receiver.mark
280 msg.control.type = RPCACK;
281 moveparams(thispix, *am, &msg, PAROUT, LOADPAR);
282 sendmsg1(&msg); /* send RP return - acknowledge */
283 gkill(virt); /* kill procedure object manualy */
284 popmask(thispix); /* restore RPC mask from stack */
285 for (i = 0; i < length; i++) /* and modify it */
287 t1 = virtprot(M[ plist++ ]); /* prototype number */
288 if (t1 > 0) enable(thispix, t1);
289 else disable(thispix, -t1);
291 evaluaterpc(thispix); /* check for enabled RPCs */
297 /* Return, end in procedures and functions without prefix.
300 void backpr(virt, am)
306 t2 = c1+M[ c1 ]+DL; /* DL pointer of current */
307 t1 = M[ t2 ]; /* ah of DL */
308 t3 = c1+M[ c1 ]+SL; /* SL pointer */
309 if (t1 == M[ t3 ] && M[ t2+1 ] == M[ t3+1 ]) backbl(virt, am); /* SL=DL */
310 else back1(t1, t2, virt, am);
314 void fin(backic, virt, am) /* End in classes and coroutines. */
321 knd = prototype[ M[ c1+PROTNUM ] ]->kind;
322 if (knd != COROUTINE && knd != PROCESS)
323 back(virt, am, (word) 0); /* a class - exit as above */
326 ic = backic; /* backspace ic */
328 t1 = M[ t2+DL ]; /* ah of DL */
331 if (M[ t2+SL ] == DUMMY) endprocess(0);
332 ic = 0; /* coroutine terminated */
339 back1(t1, t2+DL, virt, am);
345 static void att2(virt, ax, at1) /* Helper for attach/detach */
351 t1 = M[ display2+M[ c1+PROTNUM ] ]; /* ah of current */
352 t2 = at1+M[ at1 ]+DL; /* DL of coroutine head */
353 M[ t2 ] = t1; /* loop up DL */
354 M[ t2+1 ] = M[ t1+1 ];
355 M[ c1+M[ c1 ]+LSC ] = ic; /* preserve local control */
357 phead = thisp->prochead;
358 storevirt(*virt, phead+M[ phead ]+CHD);
360 if (t2 == 0) errsignal(RTECORAC); /* coroutine active */
361 M[ ax+DL ] = 0; /* cut DL of new coroutine head */
364 c2 = c1+prototype[ M[ c1+PROTNUM ] ]->span;
365 ic = M[ c1+M[ c1 ]+LSC ];
366 if (ic == 0) errsignal(RTECORTM); /* coroutine terminated */
373 word t1, ax, phead, chead;
376 if (M[ virt->addr+1 ] != virt->mark) errsignal(RTEILLAT);
377 else ax = M[ virt->addr ]; /* am */
378 t1 = M[ ax+PROTNUM ];
379 if (t1 == AINT || t1 == AREAL || t1 == AVIRT || t1 == FILEOBJECT)
381 knd = prototype[ t1 ]->kind;
382 if (knd != COROUTINE && knd != PROCESS) errsignal(RTEILLAT);
384 phead = thisp->prochead;
385 chead = phead+M[ phead ]+CHD;
386 if (virt->addr != M[ chead ] || virt->mark != M[ chead+1 ])
388 M[ ax+CL ] = M[ chead ];
389 M[ ax+CL+1 ] = M[ chead+1 ];
390 att2(virt, ax, M[ M[ chead ] ]);
400 phead = thisp->prochead;
401 t1 = M[ M[ phead+M[ phead ]+CHD ] ]; /* am of coroutine head */
402 loadvirt(virt, t1+M[ t1 ]+CL); /* coroutine link */
403 if (M[ virt.addr+1 ] != virt.mark) errsignal(RTEILLDT);
404 att2(&virt, M[ virt.addr ]+M[ M[ virt.addr ] ], t1);
408 void inner(level) /* Simulate execution of inner */
414 ptr = prototype[ M[ c1+PROTNUM ] ]; /* prototype of current */
415 t1 = ptr->lthpreflist;
417 if (level == t1-1) ic = ptr->codeaddr;
418 else ic = prototype[ M[ ptr->preflist+level ] ]->codeaddr;