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 =======================================================================
23 static void makereflist (protaddr);
24 static void makeprefseq (protaddr);
25 static void makeparlist (protaddr);
26 static void makevirtlist(protaddr);
27 static void makeit (int,protaddr);
31 static void makereflist();
32 static void makeprefseq();
33 static void makeparlist();
34 static void makevirtlist();
40 /* strongly implementation dependent, */
41 /* given the address in symbol table */
42 /* returns the kind of loglan item */
54 trick.t=iand(n,15); /* 000f */
55 /* bits 12..15 in 16-bits word */
57 trick.zp=ishft(iand(n,15*16),-4); /* 00f0 */
58 /* bits 8..11 in 16-bits word */
60 trick.s=ishft(iand(n,7*256),-8); /* 0700 */
62 /* bits 5.. 7 in 16-bits word */
66 case 2 : return(IRECORD) ;
68 case 3 : return(ICLASS) ;
70 case 5 : return(IPROCESS) ;
72 case 6 : return(IFMTYPE) ;
74 case 7 : return(ICOROUT) ;
77 /* 4,8,9,10,11,12,13,14,15 */ break;
79 case 1 : switch(trick.zp)
81 case 2 : return(IFMFUNC) ;
83 case 3 : return(IFMPROC);
85 case 5 : return(IPARIN);
87 case 6 : return(IPAROUT);
89 case 7 : return(IVAR);
91 case 8 : return(ICONST);
93 case 9 : return(IPARINOUT);
95 case 11 : return(ISIGNAL);
99 case 0 : switch(trick.s)
101 case 0 : return(IBLOCK);
103 case 1 : return(IPREFBLOCK);
105 case 2 : return(IFUNC);
107 case 4 : return(IPROC);
109 case 7 : return(IHANDLER);
112 default /* 3,5,6*/ : break ;
113 } /* switch trick.s */
115 /* 1,4,10,12,13,14,15 */ break ;
117 } /* switch trick.zp */
118 } /* switch trick.t */;
125 void reserve(n) address n;{ /* TEST IF THERE IS AT LEAST N EMPTY CELLS IN 'M' */
126 if((fre + n) > MEMLIMIT) generror(TLDESCR);
131 static void makereflist(prot) protaddr prot;{
132 /* PREPARES THE TABLE WITH OFFSETS OF REFERENCE VARIABLES */
133 /* FOR THE PROTOTYPE PROT */
139 pointprdsc curr ; /* cmb */
141 curr = prototype[ prot ] ;
142 if (curr->lthreflist > 0){
144 pref = prefix[ prot ] ;
146 if (pref != DUMMY) /* prefixed unit */
147 if(( prototype[ pref ]->span != 0 )
148 && ( prototype[ pref ]->lthreflist == curr->lthreflist )){
150 /* prefix already processed and the same reference attributes */
153 curr->reflist = prototype[ pref ]->reflist ;
157 reserve(curr->lthreflist) ;
158 elem = listofref[ prot ] ;
160 /* COPY THESE OFFSETS */
161 for (n = curr->lthreflist-1; n>=0; n--)
163 m [ fre+n ] = ipmem[ (elem->ip) - 2 ] ; /* offset */
165 elem = elem->prevelem ;
168 curr->reflist = fre + base ;
169 fre += curr->lthreflist ;
172 } /* IF NON EMPTY REFLIST */
177 static void makeprefseq(prot) protaddr prot;{
182 /* WITH PROTOTYPE[ PROT ]^ DO */
184 curr = prototype[ prot ] ;
185 reserve(curr->lthpreflist) ;
188 for (n = (curr->lthpreflist) - 1; n >= 0 ; n--)
195 curr->preflist = fre + base ;
196 fre += curr->lthpreflist ;
202 static void makeparlist(prot) protaddr prot;{
203 /* PREPARES TABLES WITH PARAMETERS OFFSETS AND DESCRIPTION ADDRESSES
204 FOR PROTOTYPE PROT */
207 int ip , /* address in ipmem */
213 /* WITH PROTOTYPE[ PROT ] ^ DO */
214 { curr = prototype[ prot ] ;
215 if (curr->lthparlist > 0)
217 /* TABLE WITH PARAMETERS OFFSETS */
218 reserve(curr->lthparlist) ;
219 curr->parlist = fre + base ;
221 if (curr->kind == HANDLER)
223 /* NO PARAMETER LIST IN IPMEM, USE ATTRIBUTE LIST*/
224 ip = ipmem[(curr->codeaddr) + 6 ] ;
225 /* FIRST ELEM. OF ATTRIBUTE LIST */
226 for (n = 0; (n <=(curr->lthparlist-1 )); n++)
228 m[ fre + n ] = ipmem[(ipmem[ ip ])-2 ] ; /* offset */
232 ip = ipmem[ ip+1 ]; /* next */
235 fre += curr->lthparlist;
238 else /* not handler */
241 pref = prefix[ prot ];
244 if (( prototype[ pref ]->span != 0 ) /* prefix already processed */
245 && ( prototype[ pref ]->lthparlist == curr->lthparlist ))
246 /* the same parameters */
248 curr->parlist=prototype[ pref ]->parlist;
254 /* COPY THESE OFFSETS USING PARAMETERS LIST FROM IPMEM */
255 ip=ipmem[ curr->codeaddr+3 ]; /* first parameter indirect address */
257 for (n=0;n <= (curr->lthparlist) - 1; n++)
258 m [ fre + n ] = ipmem[ ipmem[ ip+n ] - 2 ]; /* offset */
261 fre += curr->lthparlist;
262 } /* mb if anytodo (?) */
264 /* FOR PROCEDURE OR FUNCTION PREPARE TABLE WITH PARAMETERS
265 DESCRIPTIONS ADDRESSES */
266 if( (curr->kind == LFUNCTION) || (curr->kind == LPROCEDURE)
267 || (curr->kind == PROCESS) )
269 reserve(curr->lthparlist);
270 curr->pfdescr=fre+base;
271 elem = listofpar[ prot ];
273 for (n=curr->lthparlist-1; n >= 0; n--)
275 m [ fre + n ] = elem->ip; /* description's address */
280 fre += curr->lthparlist;
281 } /* FUNCTION,PROCEDURE,PROCESS */
283 } /* mb if lthparlist>0 ?? */
288 static void makeit(ipr,prot)
291 /* mb added passing ipr,prot as parameters rather than globals */
292 /* for the ipmem prototype 'ipr' creates the table with virtuals
293 prototypes numbers and assignes its address to virtlist of
298 l=ipmem[ ipr+25 ]; /* length */
299 f=ipmem[ ipr+24 ]; /* first element address */
301 prototype[ prot ]->virtlist=fre + base;
302 for (k=0; k<=l-1; k++)
303 m[ fre+k ]=ipmem[ (ipmem[ f+k ])-1 ]; /* virtual's prototype */
308 static void makevirtlist(prot) protaddr prot;{
309 /* MAKES A TABLE WITH PROTOTYPES NUMBERS FOR VIRTUAL */
310 /* PROCEDURES OR FUNCTIONS (IF NOT MADE YET). */
311 /* PROPAGATES ITS ADDRESS THRU THE PREFIX SEQUENCE. */
318 curr = (prototype[prot]);
319 ipr = (int)(curr->codeaddr); /* address in ipmem */
320 if( ((curr->kind == CLASS) || (curr->kind == LRECORD) ||
321 (curr->kind ==COROUTINE) || (curr->kind ==PROCESS) ||
322 (curr->kind == PREFBLOCK) || (curr->kind ==LFUNCTION) ||
323 (curr->kind ==LPROCEDURE)) /* VIRTUALS ALLOWED */
324 && (curr->virtlist == 0) /* not processed yet */
325 && (ipmem[ ipr + 25 ] != 0))
326 { /* not empty virtuals list */
327 while (ipmem[ ipr + 25 ] < 0)
328 /* LIST INHERITED FROM PREFIX, GO THERE */
329 ipr=ipmem[ ipr + 21 ];
330 /* THE OWN LIST OF IPR */
331 n = prototype[ ipmem[ ipr - 1 ] ]->virtlist ;
332 if (!n) /* TABLE NOT MADE YET */
335 { curr->virtlist = n ;}
336 /* PROPAGATE IT UP THE PREFIX SEQUENCE TILL THE OWNER OF THE LIST */
337 ipr=(int)(curr->codeaddr); /* ipmem address for prot */
338 while (ipmem[ ipr+25 ] < 0)
340 ipr = (int)(ipmem[ ipr+21 ]); /* prefix */
341 prototype[ ipmem[ ipr-1 ] ]->virtlist = curr->virtlist;
343 } /* VIRTUALS ALLOWED AND EXIST, UNIT NOT PROCESSED */
349 /* PREPARATION OF : REFLIST, PARLIST, PARDESCRLIST, PREFLIST */
350 /* UNITS ARE PROCESSED IN A REVERSED ORDER */
356 pointprdsc curr ; /* gsg auxiliary for the Pascal WITH */
358 for(pr = lastprot; pr >= MAINBLOCK; pr--){
359 curr = prototype[pr] ;
360 if(curr->span == 0){ /* ALREADY PROCESSED ? */
361 /* NOT PROCESSED YET */
363 if(curr->kind == LFUNCTION){ /* SUPPLEMENT FUNCTION TYPE */
364 n = m[ curr->pfdescr - base + curr->lthparlist - 1 ] - base; /* result */
365 curr->nrarray = m[ n+1 ] ;
366 curr->finaltype = m[ n+2 ] ;
367 } /* SUPPLEMENT OF FUNCTION TYPE */
371 curr->span = 1 ; /* ==> processed */
373 /* GO UP THE PREFIX SEQUENCE */
374 prfx = prefix[ pr ] ;
376 while (prfx != DUMMY)
377 { pref = prototype[ prfx ] ;
380 prfx = DUMMY ; /* FORCE EXIT */
382 { /* prefix not processed yet */
383 pref->span = 1 ; /* ==> processed */
384 pref->reflist = curr->reflist ;
385 pref->parlist = curr->parlist ;
386 pref->preflist = curr->preflist ;
387 /*CBC added copying of PFDESCR (formal parameter description list) */
388 pref->pfdescr = curr->pfdescr ;
389 prfx = prefix[ prfx ] ;
390 } /* PREFIX NOT PROCESSED */
393 } /* NOT PROCESSED */
403 address pip,listfrompref;
406 for (prot = MAINBLOCK; prot <= lastprot; prot++)
407 /* WITH PROTOTYPE[ PROT ] ^ DO */
408 { if (prototype[prot]->kind == HANDLER) /* SURELY NO OWN HANDLERS */
409 prototype[prot]->handlerlist = 0 ;
412 if (prototype[prot]->lthpreflist == 1) /* NO PREFIX */
415 listfrompref = prototype[ prefix[ prot ] ]->handlerlist ;
417 pip = prototype[prot]->codeaddr ; /* prototype in ipmem */
419 if (ipmem[ pip + 19 ] == 0) /* NO OWN HANDLERS */
420 prototype[prot]->handlerlist = listfrompref ;
422 { /* mb own handlers possible */
423 reserve( 3 * ( ipmem[ pip + 19 ]) ) ;
424 prototype[prot]->handlerlist = fre + base ;
425 h = ipmem[ pip + 20 ] ;
426 /* first element of handler list in ipmem */
430 m[ fre ] = ipmem[ h ] ; /*signal identifier */
432 m[ fre + 1 ] = ipmem[ (int)(ipmem[ h + 1 ]) - 1 ] ;
435 /* handler prototype */
436 m[ fre + 2 ] = fre + 3 + base ; /* next */
442 m[ fre - 1 ] = listfrompref ;
453 /* DESCRIPTIONS OF PRIMITIVE TYPES */
455 /*printf("primdescr: fre = %d\n", fre) ; */
456 assert(fre == 0 && base > 0);
458 m[ fre + TINT ] = PRIMITIVETYPE ;
459 m[ fre + TREAL ] = PRIMITIVETYPE ;
460 m[ fre + TBOOLEAN ] = PRIMITIVETYPE ;
461 m[ fre + TCHAR ] = PRIMITIVETYPE ;
462 m[ fre + TCOROUT ] = PURECOROUTINE ;
463 m[ fre + TPROCESS ]= PUREPROCESS ;
464 m[ fre + TSTRING ] = PRIMITIVETYPE ;
465 m[ fre + TFUNC2 ] = FORMFUNC ;
466 m[ fre + TPROC2 ] = FORMPROC ;
467 m[ fre + TFILE ] = FILETYPE ; /*DSW*/
469 /*dsw*/ /* fre=fre+TPROC2+1; */
471 fre = fre + TFILE + 1 ; /*dsw*/
473 /* STORE ADDRESSES OF THESE TYPES DESCRIPTIONS */
476 if (ipradr + TFILE > MAXINT - 1) generror(TLDESCR) ;
478 ipmem[ nrint + 2 ] = -(ipradr + TINT) ;
479 ipmem[ nrre + 2 ] = -(ipradr + TREAL) ;
480 ipmem[ nrbool + 2 ] = -(ipradr + TBOOLEAN) ;
481 ipmem[ nrchr + 2 ] = -(ipradr + TCHAR) ;
482 ipmem[ nrcor + 2 ] = -(ipradr + TCOROUT) ;
483 ipmem[ nrproc + 2 ] = -(ipradr + TPROCESS) ;
484 ipmem[ nrtext + 2 ] = -(ipradr + TSTRING) ;
490 void addtolist(head, i) /* gsg ATTENTION !!! head is "var" parameter !!! */
491 /* ADD THE NEW ELEMENT WITH VALUE "I" TO THE LIST
493 /* head is passed by reference - it is an "inout" parameter */
494 /* so it is pointer to pointer to first item */
496 pointer * head ; /* i.e item **head */
502 (*head) = (pointer) new(*head) ;
504 (*head)->prevelem = elem ;
509 void longaddtolist(head, i) /* gsg ATTENTION !!! head is "var" parameter !!! */
510 /* ADD THE NEW ELEMENT WITH VALUE "I" TO THE LIST
518 (*head) = (longpointer) new(*head);
520 (*head)->prevelem = elem ;
522 } /* longaddtolist */
525 void backpatch(i, a) int i; address a;{
527 /* SATISFY REFERENCES (IF ANY) TO THE TYPE WITH IPMEM ADDRESS I */
528 /* WITH THE VALUE A . */
529 /* IPMEM(I+2) >= 0 ==> NO DESCRIPTION YET, */
530 /* IF IPMEM(I-2) >= 0 THEN NOT REFERED YET, */
531 /* OTHERWISE = -LINK TO THE FIRST ELEMENT OF LIST */
532 /* IPMEM(I+2) < 0 ==> DESCRIPTION ALREADY MADE */
533 /* AT ADDRESS = -IPMEM(I+2) */
537 /*DSW&BC...*/ if(a > MAXINT - 1) generror(TLDESCR);
539 /* ANY REFERENCES ? */
540 if(ipmem[ i - 2 ] < 0){
551 ipmem[ i + 2 ] = -a ; /* DESCR. ALREADY MADE */
556 /* FILLS THE PROTOTYPE OF UNIT. */
557 /* FOR THE CLASS ALSO CREATES CLASS TYPE DESCRIPTION */
559 pointprdsc prfx ; /* POINTER TO PREFIX DESCRIPTION */
560 int ip ; /* ADDRESS IN IPMEM */
561 pointprdsc curr ; /* gsg translation of the Pascal WITH */
563 /* WITH PROTOTYPE[ LASTPROT ]^ DO */
564 { curr = prototype[ lastprot ] ;
565 ip = curr->codeaddr ;
567 if (lastprot == MAINBLOCK)
568 curr->slprototype = DUMMY ;
570 curr->slprototype = ipmem[ ipmem[ip-1]-1 ] ; /*PROTOTYPE NUMBER FOR SL*/
572 ipmem[ ip - 1 ] = lastprot ;
573 curr->appetite = APINT + APINT ; /* 2 CELLS: OBJECT'S APPETITE, */
574 /* PROTOTYPE ADDRESS */
576 listofref[ lastprot ] = NULL ;
577 curr->lthreflist = 0 ;
578 listofpar[ lastprot ] = NULL ;
579 curr->lthparlist = 0 ;
581 curr->lthpreflist = 1 ;
583 curr->handlerlist = 0 ;
586 /*CBC added virtual number ...*/
587 if (iand(ipmem[ ip ], 8 * 256) != 0) /* virtual ? 0800 */
588 curr->virtnumber = ipmem[ ip + 27 ] ; /* yes, store virtual number */
590 curr->virtnumber = -1 ; /* no, flag that not virtual */
593 prefix[ lastprot ] = DUMMY ;
595 if ( (curr->kind == CLASS) || (curr->kind == LRECORD) ||
596 (curr->kind ==COROUTINE) || (curr->kind ==PROCESS) ||
597 (curr->kind == PREFBLOCK) || (curr->kind ==LFUNCTION) ||
598 (curr->kind ==LPROCEDURE) )
600 { /* POSSIBLY PREFIXED */
601 if (ipmem[ ip + 21 ] != 0)
602 { /* PREFIXED UNIT */
603 prefix[ lastprot ] = ipmem[ ipmem[ ip + 21 ] - 1 ] ;
604 prfx = prototype[ prefix[ lastprot ] ] ;
605 curr->lthpreflist = prfx->lthpreflist + 1 ;
606 listofref[ lastprot ] = listofref[ prefix[ lastprot ] ] ;
607 curr->lthreflist = prfx->lthreflist ;
608 listofpar[ lastprot ] = listofpar[ prefix[ lastprot ] ] ;
609 curr->lthparlist = prfx->lthparlist ;
610 curr->appetite = prfx->appetite ;
611 } /* PREFIXED UNIT */
613 if ( (curr->kind == CLASS) || (curr->kind == LRECORD) ||
614 (curr->kind ==COROUTINE) || (curr->kind ==PROCESS) )
615 { /* CREATE CLASS TYPE */
617 backpatch(ip, fre + base) ;
618 m[ fre++ ] = CLASSTYPE ;
620 m[ fre++ ]= lastprot ;
624 } /* POSSIBLE PREFIXED */