1 /* $Id: cgenpar.c,v 1.24 1994/11/03 08:41:00 cim Exp $ */
2 
3 /* Copyright (C) 1994, 1998 Sverre Hvammen Johansen and Terje Mj�s,
4  * Department of Informatics, University of Oslo.
5  *
6  * This program is free software; you can redistribute it and/or modify
7  * it under the terms of the GNU General Public License as published by
8  * the Free Software Foundation; version 2.
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 #include "gen.h"
20 #include "extspec.h"
21 
22 #define ADDNOTH 0
23 
24 /******************************************************************************
25                                                               GEN_CONV_AND_Q */
26 
27 static gen_conv_and_q (rex, procedure, transported, copied_all)
28      struct EXP *rex;
29      char procedure,
30        transported,
31        copied_all;
32 {
33   char writetest = TRUE;
34   if ((rex->rd->prefqual == rex->left->qual) ||
35       (procedure && subclass (rex->left->qual, rex->rd->prefqual)))
36     {
37       /* AKTUELL OG FORMELL HAR SAMME KVALIFIKASJON
38        * eller FOR PROSEDYRE AKTUELL HAR LIK QUAL ELLER ER EN
39        * SUBKLASSE AV FORMELL QUAL.
40        * FP.CONV = AP.CONV -- FP.Q = AP.Q */
41       writetest = FALSE;
42       goto nextcase;
43     }
44   else
45     /* END-LIK AKTUELL OG FORMELL KVALIFIKASJON */
46     if (subclass (rex->left->qual, rex->rd->prefqual) && !procedure)
47     {
48       /* AKTUELL kval. er en subklasse av FORMELL kval.
49       * FP.CONV = AP.CONV || writetest -- FP.Q = AP.Q */
50     nextcase:
51       if (!transported || !copied_all || writetest)
52 	fprintf (ccode, "((__bs%d *)__pb)->%s.conv",
53 			rex->rd->encl->blno, rex->rd->ident);
54       if (transported)
55 	{
56 	  if (copied_all)
57 	    if (writetest)
58 	      fprintf (ccode, "|= __WRITETEST;",
59 			      rex->left->value.ident);
60 	    else;
61 	  else
62 	    {
63 	      gensl (rex->left, TRUE, ON);
64 	      if (writetest)
65 		fprintf (ccode, "=%s.conv | __WRITETEST;",
66 				rex->left->value.ident);
67 	      else
68 		fprintf (ccode, "=%s.conv;", rex->left->value.ident);
69 	    }
70 	}
71       else if (writetest)
72 	fprintf (ccode, "=__WRITETEST;");
73       else
74 	fprintf (ccode, "=__NOTEST;");
75 
76       fprintf (ccode, "((__bs%d *)__pb)->%s.q=", rex->rd->encl->blno,
77 		      rex->rd->ident);
78 
79       if (transported)
80 	{
81 	  gensl (rex->left, TRUE, ON);
82 	  fprintf (ccode, "%s.q", rex->left->value.ident);
83 	}
84       else
85 	gen_adr_prot (ccode, rex->left->qual);
86       fprintf (ccode, ";");
87     }
88   else
89     /* END-AKTUELL KVAL. EN SUBKLASSE AV FORMELL KVAL. */
90     if (subclass (rex->rd->prefqual, rex->left->qual))
91     {
92       if (transported)
93 	{
94 	  /* FORMELL kval. er en subklasse av AKTUELL kval.
95 	   * if(FORMELL kval. sub AP.kval)
96 	   * {
97 	   *    FP.CONV=readtest;FP.Q=FORMELL kval.
98 	   * }else
99 	   * if(AP.kval sub FORMELL kval.)
100 	   * {
101 	   *    FP.CONV=AP.CONV;FP.Q=AP.Q
102 	   *  }else
103 	   * __rerror();
104            *
105 	   * rrin() er en runtime som utf|rer en in test
106 	   * Den skal ha to prototype pekerer som parametere
107 	   * i motsetning til rin() som skal ha en objektpeker
108 	   * og en prototype peker
109 	   * Tester alts} om par1 in par2 */
110 
111 	  fprintf (ccode, "if(__rrin(");
112 	  gen_adr_prot (ccode, rex->rd->prefqual);
113 	  fprintf (ccode, ",");
114 
115 	  gensl (rex->left, TRUE, ON);
116 	  fprintf (ccode, "%s.q)){", rex->left->value.ident);
117 	}
118       fprintf (ccode, "((__bs%d *)__pb)->%s.conv=__READTEST;"
119 	       "((__bs%d *)__pb)->%s.q= ",
120 	       rex->rd->encl->blno, rex->rd->ident,
121 	       rex->rd->encl->blno, rex->rd->ident);
122       gen_adr_prot (ccode, rex->rd->prefqual);
123       fprintf (ccode, ";");
124 
125       if (transported)
126 	{
127 	  fprintf (ccode, "}else if(__rrin(");
128 	  gensl (rex->left, TRUE, ON);
129 	  fprintf (ccode, "%s.q,",
130 			  rex->left->value.ident);
131 	  gen_adr_prot (ccode, rex->rd->prefqual);
132 	  fprintf (ccode, ")){");
133 	  if (!copied_all)
134 	    {
135 	      fprintf (ccode, "((__bs%d *)__pb)->%s.conv=",
136 			      rex->rd->encl->blno, rex->rd->ident);
137 	      gensl (rex->left, TRUE, ON);
138 	      fprintf (ccode, "%s.conv;((__bs%d *)__pb)->%s.q=",
139 		       rex->left->value.ident,
140 		       rex->rd->encl->blno, rex->rd->ident);
141 	      gensl (rex->left, TRUE, ON);
142 	      fprintf (ccode, "%s.q;", rex->left->value.ident);
143 	    }
144 	  fprintf (ccode, "}else __rerror(__errqual);");
145 	}
146     }
147 /*** END-FORMELL KVAL. ER EN SUBKLASSE AV AKTUELL KVAL.            ****/
148 }
149 
150 /******************************************************************************
151                                                                GEN_ARIT_CONV */
152 
153 static gen_arit_conv (rex, transported, copied_all)
154      struct EXP *rex;
155      char transported,
156        copied_all;
157 {
158   if (transported != copied_all || rex->left->type != rex->rd->type)
159     {
160       fprintf (ccode, "((__bs%d *)__pb)->%s.conv=",
161 		      rex->rd->encl->blno, rex->rd->ident);
162 
163       if (transported)
164 	fprintf (ccode, "__ctab[");
165 
166       if (rex->left->type == TINTG && rex->rd->type == TREAL)
167 	fprintf (ccode, "__INTREAL");
168       else if (rex->left->type == TREAL && rex->rd->type == TINTG)
169 	fprintf (ccode, "__REALINT");
170       else
171 	fprintf (ccode, "__NOCONV");
172 
173       if (transported)
174 	{
175 	  fprintf (ccode, "][");
176 	  gensl (rex->left, TRUE, ON);
177 	  fprintf (ccode, "%s.conv]", rex->left->value.ident);
178 	}
179       fprintf (ccode, ";");
180     }
181 }
182 
183 /******************************************************************************
184                                                                     GEN_CONV */
185 
186 static gen_conv (rex, procedure, copied_all)
187      struct EXP *rex;
188      char procedure,
189        copied_all;
190 {
191   if (rex->rd->categ == CVAR || rex->rd->categ == CNAME	)
192     {
193       if (rex->left->token == MIDENTIFIER &&
194 	  (rex->left->rd->categ == CVAR || rex->left->rd->categ == CNAME))
195 	{
196 	  if (rex->rd->type == TINTG || rex->rd->type == TREAL)
197 	    gen_arit_conv (rex, TRUE, copied_all);
198 	  else if (rex->rd->type == TREF)
199 	    gen_conv_and_q (rex, procedure, TRUE, copied_all);
200 	}
201       else
202 	{
203 	  if (rex->rd->type == TINTG || rex->rd->type == TREAL)
204 	    gen_arit_conv (rex, FALSE, copied_all);
205 	  else if (rex->rd->type == TREF)
206 	    gen_conv_and_q (rex, procedure, FALSE, copied_all);
207 	}
208     }
209 }
210 
211 /******************************************************************************
212                                                        SEND_TO_FORMAL_PAR    */
213 
214 /* Overf|rer namekind, thunk adressen, statisk link, og evt. __conv og q
215  * til den formelle nameparameter structen ved generering av thunker for
216  * den aktuelle parameteren. */
217 
218 static send_to_formal_par (rex, addressthunk)
219      struct EXP *rex;
220      char addressthunk;
221 {
222   /* Hvis hdot = FALSE er denne rutinen kalt for en label     eller array
223    * name. Structen for disse har ikke et .h felt som finnes i structene for
224    * enkle name-parametere. */
225 
226   if (addressthunk)
227     fprintf (ccode, "((__bs%d *)__pb)->%s.namekind=__ADDRESS_THUNK;",
228 		    rex->rd->encl->blno, rex->rd->ident);
229   else
230     fprintf (ccode, "((__bs%d *)__pb)->%s.namekind=__VALUE_THUNK;",
231 		    rex->rd->encl->blno, rex->rd->ident);
232 
233 /***** OVERF\RER THUNKENS ADRESSE OG THUNKENS STATISKE OMGIVELSE  ****/
234   fprintf (ccode, "((__bs%d *)__pb)->%s.adr.ment=",
235 		    rex->rd->encl->blno, rex->rd->ident);
236   genmodulemark(NULL);
237 
238   fprintf (ccode, ";((__bs%d *)__pb)->%s.adr.ent=%d;"
239 	   "((__bs%d *)__pb)->%s.sl=__lb",
240 	   rex->rd->encl->blno, rex->rd->ident, rex->value.thunk.label,
241 	   rex->rd->encl->blno, rex->rd->ident);
242   if (inthunk)
243     fprintf (ccode, "->sl");
244   fprintf (ccode, ";");
245   if (rex->rd->kind != KARRAY)
246     gen_conv (rex, FALSE, FALSE);
247 }
248 
249 /******************************************************************************
250                                                     GEN_THUNK_SIMPLE_ADDRESS */
251 
252 /* Genererer kode som for ADDRESS_THUNK avgj|r om thunken skal returnere
253  * med en adresse eller en verdi. Dersom en verdi skal returners
254  * genereres det ogs} kode som utf|rer evt. konverteringer og
255  * kvalifikasjonstester */
256 
257 gen_thunk_simple_address (rex)
258      struct EXP *rex;
259 {
260   switch (rex->left->token)
261     {
262     case MARRAYARG:
263     case MARRAYADR:
264       fprintf (ccode, "__er=__r[%d];__ev.i=__v[%d].i;",
265 	       (int) rex->left->value.stack.ref_entry,
266 	       (int) rex->left->value.stack.val_entry);
267       break;
268     default:
269       fprintf (ccode, "__er=");
270       if (nonetest == ON)
271 	fprintf (ccode, "((__bp=");
272       genvalue (rex->left->left);
273       if (nonetest == ON)
274 	fprintf (ccode,
275 			")==__NULL?(__dhp)__rerror(__errnone):__bp)");
276       fprintf
277 	(ccode, ";__ev.i=((char *)&((__bs%d *)__p)->%s) - (char *)__p;",
278 	 rex->left->right->rd->encl->blno,
279 	 rex->left->right->rd->ident);
280       break;
281     }
282   if (rex->rd->type == TBOOL || rex->rd->type == TCHAR)
283     /* Leser verdien hvis det ikke er skrive-aksess. */
284     fprintf (ccode, "if(!((__thunkp)__pb)->writeaccess)"
285 	     "__ev.c= *(char *)(((char *)__er)+__ev.i);");
286   else if (rex->rd->type == TINTG || rex->rd->type == TREAL)
287     {				/* Leser og konverterer verdien hvis det ikke
288 				 * er skrive aksess. */
289       fprintf (ccode, "if(!((__thunkp)__pb)->writeaccess)"
290 	       "   if(((__thunkp)__pb)->ftype==__TINTG)");
291       if (rex->left->type == TINTG)
292 	fprintf (ccode, "__ev.i= *(long *)(((char *)__er)+__ev.i);");
293       else
294 	fprintf (ccode, "__ev.i= *(double *)(((char *)__er)+__ev.i);");
295       fprintf (ccode, "   else ");
296       if (rex->left->type == TINTG)
297 	fprintf (ccode, "__ev.f= *(long *)(((char *)__er)+__ev.i);");
298       else
299 	  fprintf (ccode, "__ev.f=(((__thunkp)__pb)->conv==__REALINTREAL)?"
300 		   "__rintrea(*(double *)(((char *)__er)+__ev.i)):"
301 		   "*(double *)(((char *)__er)+__ev.i);");
302     }
303   if (rex->rd->type == TTEXT)
304     /* Leser verdien hvis det ikke er skrive-aksess. */
305     fprintf (ccode, "if(!((__thunkp)__pb)->writeaccess)"
306 	     "__et= *(__txt *)(((char *)__er)+__ev.i);");
307   else if (rex->rd->type == TREF)
308     fprintf (ccode, "if(!((__thunkp)__pb)->writeaccess)"
309 	     "   if((((__thunkp)__pb)->conv==__READTEST ||"
310 	     " ((__thunkp)__pb)->conv==__READWRITETEST) &&"
311 	     " !__rin(*(__dhp *)(((char *)__er)+__ev.i),"
312 	     "((__thunkp)__pb)->q))__rerror(__errqual);"
313 	     "else __er= *(__dhp *)(((char *)__er)+__ev.i);");
314   fprintf (ccode, "__reth();");
315 }
316 
317 /******************************************************************************
318                                                     GEN_THUNK_SIMPLE_VALUE   */
319 
320 gen_thunk_simple_value (rex)
321      struct EXP *rex;
322 {
323   switch (rex->left->type)
324     {
325     case TINTG:
326       fprintf (ccode, "__ev.i=");
327       break;
328     case TREAL:
329       fprintf (ccode, "__ev.f=");
330       break;
331     case TBOOL:
332     case TCHAR:
333       fprintf (ccode, "__ev.c=");
334       break;
335     case TREF:
336       fprintf (ccode, "__er=");
337       break;
338     case TTEXT:
339       fprintf (ccode, "__et= *");
340       break;
341     }
342 
343   genvalue (rex->left);
344   fprintf (ccode, ";");
345 
346   /* KONVERTERING OG KVAL. TESTER */
347   if (rex->rd->type == TINTG || rex->rd->type == TREAL)
348     {				/* Leser og konverterer verdien hvis det ikke
349 				 * er skrive aksess. */
350       fprintf (ccode, "if(((__thunkp)__pb)->ftype==__TINTG)");
351       if (rex->left->type == TINTG)
352 	fprintf (ccode, "/*OK*/;");
353       else
354 	fprintf (ccode, "__ev.i=__ev.f;");
355       fprintf (ccode, "else ");
356       if (rex->left->type == TINTG)
357 	fprintf (ccode, "__ev.f=__ev.i;");
358       else
359 	fprintf
360 	  (ccode,
361 	   "if(((__thunkp)__pb)->conv==__REALINTREAL)__ev.f=__rintrea(__ev.f);");
362     }
363   else if (rex->rd->type == TREF)
364     fprintf (ccode, "if((((__thunkp)__pb)->conv==__READTEST ||"
365 	     " ((__thunkp)__pb)->conv==__READWRITETEST) &&"
366 	     " !__rin(__er,((__thunkp)__pb)->q))"
367 	     "__rerror(__errqual);");
368   fprintf (ccode, "__reth();");
369 }
370 
371 /******************************************************************************
372                                                        GENSIMPLEPAR          */
373 
374 static gensimplepar (rex)
375      struct EXP *rex;
376 {
377   int i;
378 /***** ENKEL INTEGER, REAL, CHAR, REF,TEXT ELLER BOOL  PARAMETER     ****/
379   struct EXP *re;
380   char index_is_const = TRUE;
381 
382   if (rex->rd->categ == CVALUE && rex->rd->type == TTEXT)
383     {
384       /* T E X T  V A L U E  P A R A M E T E R */
385       fprintf (ccode, "((__bs%d *)__pb)->%s= *__rcopy(%ldL,",
386 	       rex->rd->encl->blno, rex->rd->ident,
387 	       ant_stack (rex, rex->left));
388       genvalue (rex->left);
389       fprintf (ccode, ");");
390     }
391   else if (rex->rd->categ == CDEFLT)
392     {
393       /* S T A N D A R D   O V E R F \ R I N G */
394 
395       if (rex->rd->type == TTEXT)
396 	{
397 	  fprintf
398 	    (ccode, "((__bs%d *)__pb)->%s= *", rex->rd->encl->blno,
399 	     rex->rd->ident);
400 	  genvalue (rex->left);
401 	  fprintf (ccode, ";");
402 	}
403       else
404 	{
405 	  fprintf (ccode, "((__bs%d *)__pb)->%s=", rex->rd->encl->blno,
406 			  rex->rd->ident);
407 	  genvalue (rex->left);
408 	  fprintf (ccode, ";");
409 	}
410     }
411   else if (rex->rd->categ == CVAR)
412     {
413       /* V A R  P A R A M E T E R */
414 
415       if (rex->left->rd->categ == CVAR)
416 	{
417 	  /* AKTUELL PARAMETER ER EN FORMELL VAR  PARAMETER I EN YTRE
418 	   * PROSEDYRE. VIDEREF\RING AV EN ENKEL VAR PARAMETER. */
419 
420 	  /* Tilordner bp */
421 	  fprintf (ccode, "((__bs%d *)__pb)->%s=",
422 			  rex->rd->encl->blno, rex->rd->ident);
423 	  gensl (rex->left, TRUE, ON);
424 	  fprintf (ccode, "%s;", rex->left->value.ident);
425 	  gen_conv (rex, FALSE, TRUE);
426 	} /* END VIDEREF�RING AV ENKEL VAR-PARAMETER */
427       else if (rex->left->rd->categ == CNAME)
428 	{
429 	  /* Aktuell parameter er en formell NAME-par i
430 	   * en ytre prosedyre. Kallet p} transcall som
431 	   * legger ut kode for kall p} __rgetsa. Den
432 	   * returnerer adressen til variabelen i er og
433 	   * ev. */
434 	  fprintf (ccode, "((__bs%d *)__pb)->%s.bp=__er;"
435 		   "((__bs%d *)__pb)->%s.ofs=__ev.i;",
436 		   rex->rd->encl->blno, rex->rd->ident,
437 		   rex->rd->encl->blno, rex->rd->ident);
438 	  gen_conv (rex, FALSE, FALSE);
439 	}
440       else
441 	{
442 	  /* ENKEL VAR PARAMETER, IKKE VIDEREF\RING  Tilordner bp */
443 	  fprintf (ccode, "((__bs%d *)__pb)->%s.bp=",
444 		   rex->rd->encl->blno, rex->rd->ident);
445 
446 	  switch (rex->left->token)
447 	    {
448 	    case MDOT:
449 	      if (nonetest == ON)
450 		fprintf (ccode, "((__bp=");
451 	      genvalue (rex->left->left);
452 	      if (nonetest == ON)
453 		fprintf (ccode,
454 			      ")==__NULL?(__dhp)__rerror(__errnone):__bp)");
455 	      break;
456 	    case MARRAYADR:
457 	      /* Peker til array ligger p} stakken */
458 	      fprintf (ccode, "__r[%d]", rex->left->value.stack.ref_entry);
459 	      break;
460 	    case MIDENTIFIER:
461 	      gensl (rex->left, FALSE, ON);
462 	      break;
463 	    }
464 	  fprintf (ccode, ";((__bs%d *)__pb)->%s.ofs=",
465 		   rex->rd->encl->blno,rex->rd->ident);
466 
467 	  if (rex->left->token == MARRAYADR)
468 	    fprintf (ccode, "__v[%d].i;", rex->left->value.stack.val_entry);
469 	  else
470 	    fprintf (ccode, "((char *)&((__bs%d *)__p)->%s)"
471 		     "-(char *)__p;",
472 		     rex->left->rd->encl->blno, rex->left->rd->ident,
473 		     rex->rd->encl->blno, rex->rd->ident);
474 	  gen_conv (rex, FALSE, FALSE);
475 	}			/* END IKKE VIDEREF\RING AV ENKEL
476 				 * VAR-PARAMETER */
477     }
478   else
479     /* END-if(rex->rd->categ == CVAR) */ if (rex->rd->categ == CNAME)
480     {
481       /* N A M E   P A R A M E T E R */
482       switch (rex->left->token)
483 	{
484 	case MTEXTKONST:
485 	  /* VALUE NOTHUNK  Overf|rer peker til textvariabelen for konstanten
486 	   */
487 	  fprintf (ccode, "((__bs%d *)__pb)->%s.tp=",
488 		   rex->rd->encl->blno, rex->rd->ident);
489 	  genvalue (rex->left);
490 	  /* namekind = VALUE_NOTHUNK */
491 	  fprintf (ccode, ";((__bs%d *)__pb)->%s.namekind=__VALUE_NOTHUNK;",
492 		   rex->rd->encl->blno, rex->rd->ident);
493 	  break;
494 	case MINTEGERKONST:
495 	case MREALKONST:
496 	case MCHARACTERKONST:
497 	case MBOOLEANKONST:
498 	case MNONE:
499 	  /* VALUE NOTHUNK Overf|rer verdien. */
500 	  fprintf (ccode, "((__bs%d *)__pb)->%s.v.",
501 		   rex->rd->encl->blno, rex->rd->ident);
502 	  switch (rex->rd->type)
503 	    {
504 	    case TINTG:
505 	      fprintf (ccode, "i=");
506 	      break;
507 	    case TREAL:
508 	      fprintf (ccode, "f=");
509 	      break;
510 	    case TBOOL:
511 	    case TCHAR:
512 	      fprintf (ccode, "c=");
513 	      break;
514 	    case TREF:
515 	      fprintf (ccode, "r=");
516 	      break;
517 	    default:;
518 	    }
519 	  genvalue (rex->left);
520 	  fprintf (ccode, ";");
521 
522 	  /* namekind = VALUE_NOTHUNK */
523 
524 	  fprintf (ccode, "((__bs%d *)__pb)->%s.namekind=__VALUE_NOTHUNK;",
525 		   rex->rd->encl->blno, rex->rd->ident);
526 
527 	  if (rex->rd->type == TREAL || rex->rd->type == TINTG)
528 	    /* __conv = NOCONV */
529 	    fprintf (ccode, "((__bs%d *)__pb)->%s.conv=__NOCONV;",
530 		     rex->rd->encl->blno, rex->rd->ident);
531 	  else if (rex->rd->type == TREF)
532 	    /* __conv = notest */
533 	    fprintf (ccode, "((__bs%d *)__pb)->%s.conv=__NOTEST;",
534 		     rex->rd->encl->blno, rex->rd->ident);
535 	  break;
536 	case MIDENTIFIER:
537 	  if (rex->left->rd->categ == CNAME)
538 	    {
539 	      /* AKTUELL PARAMETER ER EN FORMELL NAME-PARAMETER I EN YTRE
540 	       * PROSEDYRE. VIDERF\RING  Setter bp, en hjelpevariabel, til }
541 	       * peker p} den aktuelle parameterens blokk. Dermed blir
542 	       * aksessveien kortere under kopieringen. */
543 
544 	      fprintf (ccode, "((__bs%d *)__pb)->%s=",
545 		       rex->rd->encl->blno, rex->rd->ident);
546 	      gensl (rex->left, TRUE, ON);
547 	      fprintf (ccode, "%s;", rex->left->value.ident);
548 	      gen_conv (rex, FALSE, TRUE);
549 	    }
550 	    /* END-VIDEREF\RING AV FORMELL NAME-PARAMETER I EN YTRE
551 	     * PROSEDYRE. */
552 	  else if (rex->left->rd->categ == CVAR)
553 	    {
554 	      /* AKTUELL PARAMETER ER EN FORMELL VAR-PARAMETER I EN YTRE
555 	       * PROSEDYRE. Setter bp, en hjelpevariabel, til } peker p} den
556 	       * aktuelle parameterens blokk. Dermed blir aksessveien kortere
557 	       * under kopieringen. */
558 
559 	      fprintf (ccode, "__bp=");
560 	      gensl (rex->left, FALSE, ON);
561 
562 	      /* Tilordner den formelle name-parameterens bp og ofs */
563 	      fprintf (ccode, ";((__bs%d *)__pb)->%s.bp="
564 		"((__bs%d *)__bp)->%s.bp;((__bs%d *)__pb)->%s.v.ofs="
565 		"((__bs%d *)__bp)->%s.ofs;",
566 		       rex->rd->encl->blno, rex->rd->ident,
567 		       rex->left->rd->encl->blno,
568 		       rex->left->value.ident,
569 		       rex->rd->encl->blno, rex->rd->ident,
570 		       rex->left->rd->encl->blno,
571 		       rex->left->value.ident);
572 #if ADDNOTH
573 	      fprintf (ccode, "((__bs%d *)__pb)->%s.namekind"
574 		       "=__ADDRESS_NOTHUNK;",
575 		       rex->rd->encl->blno, rex->rd->ident);
576 #endif
577 	      gen_conv (rex, FALSE, FALSE);
578 	    }
579 	    /* END-AKTUELL PAR ER EN FORMELL VAR-PAR. */
580 	  else
581 	    {
582 	      /* ADDRESS NOTHUNK Tilordner den formelle name-parameterens bp
583 	       * og ofs */
584 	      fprintf (ccode, "((__bs%d *)__pb)->%s.bp=",
585 			      rex->rd->encl->blno, rex->rd->ident);
586 	      gensl (rex->left, FALSE, OFF);
587 	      fprintf (ccode, ";((__bs%d *)__pb)->%s.v.ofs="
588 		       "((char *)&((__bs%d *)__p)->%s)-(char *)__p;",
589 		       rex->rd->encl->blno, rex->rd->ident,
590 		       rex->left->rd->encl->blno,
591 		       rex->left->rd->ident, rex->left->rd->encl->blno);
592 #if ADDNOTH
593 	      fprintf (ccode, "((__bs%d *)__pb)->%s.namekind"
594 		       "=__ADDRESS_NOTHUNK;",
595 		       rex->rd->encl->blno, rex->rd->ident);
596 #endif
597 	      gen_conv (rex, FALSE, FALSE);
598 	    }
599 	  break;
600 	case MARRAYADR:
601 	  /* ARRAY HVOR ALLE INDEKSENE BEST]R AV KONSTANTER  ADDRESS
602 	   * NOTHUNK  Tilordner den formelle name-parameterens bp og ofs */
603 
604 	  fprintf (ccode, "((__bs%d *)__pb)->%s.bp=__r[%d];"
605 		   "((__bs%d *)__pb)->%s.v.ofs=__v[%d].i;",
606 		   rex->rd->encl->blno, rex->rd->ident,
607 		   (int) rex->left->value.stack.ref_entry,
608 		   rex->rd->encl->blno, rex->rd->ident,
609 		   (int) rex->left->value.stack.val_entry);
610 #if ADDNOTH
611 	  fprintf (ccode, "((__bs%d *)__pb)->%s.namekind"
612 		   "=__ADDRESS_NOTHUNK;",
613 		   rex->rd->encl->blno, rex->rd->ident);
614 #endif
615 	  gen_conv (rex, FALSE, FALSE);
616 	  break;
617 	}			/* END SWITCH */
618     }				/* END-if(rex->rd->categ == CNAME) */
619   else				/* FEIL */
620     ;
621 }				/* END GENSIMPLEPAR */
622 
623 /******************************************************************************
624                                                               GENLABELPAREXP */
625 
626 static genlabelparexp (rex, formellpar, thunk)
627      struct EXP *rex,
628       *formellpar;
629      char thunk;
630 {
631   /* Denne rutinen kalles i forbindelse med } generere kode for  label
632    * parameteroverf|ring hvor den aktuelle parameteren er et uttrykk (eks.
633    * p(if a then l1 else l2)).Rutinen kalles istedenfor genvalue, og
634    * genererer kode for et uttrykk av "if-i-uttrykk"-setninger som skal
635    * gi labelens adresse og objekt-peker. Genvalue ville lagd kode
636    * for } hoppe til labelen.
637    * Parameteren rex peker til en node i uttrykks-treet (enten
638    * MIFE, MELSEE eller MIDENTIFIER) mens formellpar  peker p} noden for
639    * den formelle parameteren. Hvis den formelle parameteren har
640    * categ==CNAME, skal det genereres en thunk. Parameteren exit er
641    * labelen etter hele uttrykket. Hvis det skal genereres en thunk (dvs,
642    * formellpar->rd->categ==CNAME) legges det ikke ned hopp til denne
643    * labelen siden kall p} RT-rutinen reth() avslutter hver gren. */
644 
645   if (rex->token == MIFE)
646     {
647       fprintf (ccode, "if(");
648       genvalue (rex->left);
649       fprintf (ccode, "){");
650       genlabelparexp (rex->right->left, formellpar, thunk);
651       fprintf (ccode, "}else{");
652       genlabelparexp (rex->right->right, formellpar, thunk);
653       fprintf (ccode, "}");
654     }
655   else
656     {				/* rex->token==MIDENTIFIER Hvis det ikke er
657 				 * tatt av en label i systemet, s} gj|res det
658 				 * her, og den legges i plev attributtet */
659 
660       if (rex->token == MARRAYARG)
661 	{
662 	  fprintf (ccode, "__swv=");
663 	  genvalue (rex->right->left);
664 	  fprintf (ccode, ";");
665 	}
666 
667       if (rex->rd->plev == 0)
668 	rex->rd->plev = newlabel ();
669 
670       if (thunk)
671 	fprintf (ccode, "__ev.adr.ent=");
672       else
673 	fprintf (ccode, "((__bs%d *)__pb)->%s.adr.ent=",
674 			formellpar->rd->encl->blno, formellpar->rd->ident);
675       fprintf (ccode, "%d;", rex->rd->plev);
676 
677       if (thunk)
678 	fprintf (ccode, "__ev.adr.ment=");
679       else
680 	fprintf (ccode, "((__bs%d *)__pb)->%s.adr.ment=",
681 			formellpar->rd->encl->blno, formellpar->rd->ident);
682       genmodulemark(NULL);
683 
684       if (thunk)
685 	fprintf (ccode, ";__er=");
686       else
687 	fprintf (ccode, ";((__bs%d *)__pb)->%s.ob=",
688 		 formellpar->rd->encl->blno, formellpar->rd->ident);
689 
690       gensl (rex, FALSE, ON);
691       fprintf (ccode, ";");
692     }
693 }
694 
695 /******************************************************************************
696                                                              GEN_THUNK_LABLE */
697 
698 gen_thunk_lable (rex)
699      struct EXP *rex;
700 {
701   /* genlabelparexp skriver ut uttrykket, og tilordner ment, ent og ob for
702    * hver gren i uttrykket. (if-i-uttrykk) Den skriver ogs} ut kallet for
703    * reth() til slutt */
704   genlabelparexp (rex->left, rex, TRUE);
705   fprintf (ccode, "__reth();");
706 }
707 
708 /******************************************************************************
709                                                            GENLABELSWITCHPAR */
710 
711 static genlabelswitchpar (rex)
712      struct EXP *rex;
713 {
714   int i;
715 
716   if (rex->left->token == MIDENTIFIER)
717     {
718       switch (rex->left->rd->categ)
719 	{
720 	case CNAME:
721 	  if (rex->rd->kind != KARRAY && rex->rd->categ != CNAME)
722 	    {
723 	      /* Label par og ikke switch par. Aktuell parameter er en name
724 	       * parameter i en ytre prosedyre.       M} kalle p} transcall
725 	       * som genererer kode for kall p} __rgetlab() . og som
726 	       * returnerer med adressen i modul og ev, og objekt peker i
727 	       * er. */
728 	      fprintf (ccode, "((__bs%d *)__pb)->%s.adr=__ev.adr;"
729 		       "((__bs%d *)__pb)->%s.ob=__er;",
730 		       rex->rd->encl->blno, rex->rd->ident,
731 		       rex->rd->encl->blno, rex->rd->ident);
732 	      break;
733 	    }
734 	  goto other;
735 	case CDEFLT:
736 	case CVAR:
737 	  if (rex->rd->kind != KARRAY && rex->rd->categ == CNAME)
738 	    {
739 	      /* Viderf|ring av en label parameter  Kopierer aktuell
740 	       * parameter spesifikasjon som er en formell parameter
741 	       * spesifikasjon i ytre en prosedyre. (ment, ent ,ob,( sl og
742 	       * namekind i tillegg for NAME) Setter bp, en hjelpevariabel,
743 	       * til } peker p} den   aktuelle parameterens blokk. Dermed
744 	       * blir aksessveien kortere under kopieringen. */
745 	      fprintf (ccode, "__bp=");
746 	      gensl (rex->left, FALSE, ON);
747 	      fprintf (ccode, ";((__bs%d *)__pb)->%s.adr="
748 		       "((__bs%d *)__bp)->%s.adr;"
749 		       "((__bs%d *)__pb)->%s.ob=((__bs%d *)__bp)->%s.ob;",
750 		       rex->rd->encl->blno, rex->rd->ident,
751 		       rex->left->rd->encl->blno, rex->left->value.ident,
752 		       rex->rd->encl->blno, rex->rd->ident,
753 		       rex->left->rd->encl->blno, rex->left->value.ident);
754 #if ADDNOTH
755 	      fprintf (ccode, "((__bs%d *)__pb)->%s.namekind"
756 		       "=__ADDRESS_NOTHUNK;",
757 		       rex->rd->encl->blno, rex->rd->ident);
758 #endif
759 	      break;
760 	    }
761 	other:
762 	  /* VIDEREF\RING AV FORMELL CDEFLT ELLER CVAR (eller NAME for
763 	   * switch) I EN YTRE PROSEDYRE  KOPIERER ment, ent og ob. Setter
764 	   * bp, en hjelpevariabel, til } peker p} den  aktuelle
765 	   * parameterens blokk. Dermed blir aksessveien under kopieringen.
766 	   */
767 
768 	  fprintf (ccode, "((__bs%d *)__pb)->%s=",
769 		   rex->rd->encl->blno, rex->rd->ident);
770 	  gensl (rex->left, TRUE, ON);
771 	  fprintf (ccode, "%s;", rex->left->value.ident);
772 	  break;
773 	case CVIRT:
774 	  fprintf (ccode, "((__bs%d *)__pb)->%s.ob=",
775 		   rex->rd->encl->blno, rex->rd->ident);
776 	  gensl (rex->left, FALSE, ON);
777 	  /* ment og ent er gitt av virt tabellen */
778 	  fprintf (ccode, ";((__bs%d *)__pb)->%s.adr="
779 		   "((__bs%d *)__pb)->%s.ob->pp->virtlab[%d];",
780 		   rex->rd->encl->blno, rex->rd->ident,
781 		   rex->rd->encl->blno, rex->rd->ident,
782 		   rex->left->rd->virtno - 1);
783 #if ADDNOTH
784 	  if (rex->rd->kind != KARRAY && rex->rd->categ == CNAME)
785 	    fprintf (ccode, "((__bs%d *)__pb)->%s.namekind=__ADDRESS_NOTHUNK;",
786 		     rex->rd->encl->blno, rex->rd->ident);
787 #endif
788 	  break;
789 	case CLOCAL:
790 	  fprintf (ccode, "((__bs%d *)__pb)->%s.adr.ment=",
791 		   rex->rd->encl->blno, rex->rd->ident);
792 
793 	  /* Bestemmer modulnavnet */
794 
795 	  genmodulemark(rex->left->rd->encl->timestamp);
796 	  fprintf (ccode, ";");
797 
798 	  /* Hvis det ikke er tatt av en label i systemet, s} gj|res det
799 	   * her, og den legges i plev attributtet */
800 
801 	  if (rex->left->rd->plev == 0)
802 	    rex->left->rd->plev = newlabel ();
803 
804 	  fprintf (ccode, "((__bs%d *)__pb)->%s.adr.ent=%d;"
805 		   "((__bs%d *)__pb)->%s.ob=",
806 		   rex->rd->encl->blno, rex->rd->ident,
807 		   rex->left->rd->plev,
808 		   rex->rd->encl->blno, rex->rd->ident);
809 	  gensl (rex->left, FALSE, ON);
810 	  fprintf (ccode, ";");
811 #if ADDNOTH
812 	  if (rex->rd->kind != KARRAY && rex->rd->categ == CNAME)
813 	    fprintf (ccode, "((__bs%d *)__pb)->%s.namekind=__ADDRESS_NOTHUNK;",
814 		     rex->rd->encl->blno, rex->rd->ident);
815 #endif
816 	  break;
817 	}
818     }
819   else
820     /* FORMELL CATEG LIK CDEFLT eller CVAR for label eller       CATEG LIK
821      * CDEFLT, CVAR eller CNAME for switch. Alle disse tilfellene skal
822      * behandles likt. Aktuell token kan enten   v{re MIDENTIFIER eller
823      * MIFE. Hvis det er MIFE, kalles     genlabelparexp som legger ut kode
824      * slik at overf|ringen    gj|res i hver gren. */
825     genlabelparexp (rex->left, rex, FALSE);
826 }
827 
828 /******************************************************************************
829                                                              GEN_THUNK_ARRAY */
830 
831 gen_thunk_array (rex)
832      struct EXP *rex;
833 {
834   fprintf (ccode, "__er=(__dhp)");
835   genvalue (rex->left);
836   fprintf (ccode, ";__reth();");
837 }
838 
839 /******************************************************************************
840                                                                  GENARRAYPAR */
841 
842 static genarraypar (rex)
843      struct EXP *rex;
844 {
845   int i;
846   switch (rex->rd->categ)
847     {
848     case CVALUE:
849       /* V A L U E   P A R A M E T E R */
850 
851       fprintf (ccode, "__ap=(__arrp)__rca(");
852       if (rex->left->token == MIDENTIFIER)
853 	{
854 	  if (rex->left->rd->categ == CNAME)
855 	    fprintf (ccode, "__er");
856 	  else
857 	    {
858 	      gensl (rex->left, TRUE, OFF);
859 	      fprintf (ccode, "%s", rex->left->rd->ident);
860 	    }
861 	}
862       else
863 	genvalue (rex->left);
864       fprintf (ccode, ");");
865       fprintf (ccode, "((__bs%d *)__pb)->%s=__ap;"
866 		      ,rex->rd->encl->blno, rex->rd->ident);
867       break;
868     case CDEFLT:
869     case CVAR:
870       /* STANDARD ELLER VAR OVERF\RING */
871 
872       fprintf (ccode, "((__bs%d *)__pb)->%s=", rex->rd->encl->blno,
873 		      rex->rd->ident);
874       if (rex->left->token == MIDENTIFIER)
875 	{
876 	  if (rex->left->rd->categ == CNAME)
877 	    fprintf (ccode, "(__arrp)__er");
878 	  else
879 	    {
880 	      gensl (rex->left, TRUE, OFF);
881 	      fprintf (ccode, "%s", rex->left->rd->ident);
882 	    }
883 	}
884       else
885 	genvalue (rex->left);
886       fprintf (ccode, ";");
887       break;
888     case CNAME:
889       if (rex->left->token == MIDENTIFIER)
890 	{
891 	  if (rex->left->rd->categ == CNAME)
892 	    {
893 	      /* Viderf|ring av en array parameter Kopierer aktuell parameter
894 	       * spesifikasjon som er en  formell parameter spesifikasjon i
895 	       * ytre en prosedyre. (ment, ent ,sl, ap og namekind) Setter
896 	       * bp, en hjelpevariabel, til } peker p} den  aktuelle
897 	       * parameterens blokk. Dermed blir aksessveien kortere under
898 	       * kopieringen. */
899 
900 	      fprintf (ccode, "((__bs%d *)__pb)->%s=",
901 			      rex->rd->encl->blno, rex->rd->ident);
902 	      gensl (rex->left, TRUE, ON);
903 	      fprintf (ccode, "%s;", rex->left->value.ident);
904 	    }
905 	  else
906 	    {
907 	      /* ADDRESS_NOTHUNK */
908 	      fprintf (ccode, "((__bs%d *)__pb)->%s.ap=",
909 			      rex->rd->encl->blno, rex->rd->ident
910 		);
911 	      gensl (rex->left, TRUE, ON);
912 	      fprintf (ccode, "%s;", rex->left->rd->ident);
913 #if ADDNOTH
914 	      fprintf (ccode, "((__bs%d *)__pb)->%s.namekind"
915 		       "=__ADDRESS_NOTHUNK;",
916 		       rex->rd->encl->blno, rex->rd->ident);
917 #endif
918 	    }
919 	}
920       break;
921     }				/* END SWITCH */
922 }				/* END-GENARRAYPAR */
923 
924 /******************************************************************************
925                                                          GEN_THUNK_PROCEDURE */
926 
927 gen_thunk_procedure (rex)
928      struct EXP *rex;
929 {
930   fprintf (ccode, "__sl=");
931   if (nonetest == ON)
932     fprintf (ccode, "((__bp=");
933   genvalue (rex->left->left);
934   if (nonetest == ON)
935     fprintf (ccode, ")==__NULL?(__dhp)__rerror(__errnone):__bp)");
936   fprintf (ccode, ";");
937 
938   fprintf (ccode, "__pp= ");
939   if (rex->left->rd->categ == CVIRT)
940     fprintf (ccode, "__sl->pp->virt[%d]", rex->left->right->rd->virtno - 1);
941   else
942     gen_adr_prot (ccode, rex->left->right->rd);
943   fprintf (ccode, ";__reth();");
944 }
945 
946 /******************************************************************************
947                                                              GENPROCEDUREPAR */
948 
949 static genprocedurepar (rex)
950      struct EXP *rex;
951 {
952   int i;
953   /* OVERF\RING AV PROSEDYRER SOM PARAMETERE */
954 
955   if (rex->left->token == MIDENTIFIER)
956     {
957       switch (rex->left->rd->categ)
958 	{
959 	case CDEFLT:
960 	case CVAR:
961 	  /* Kopiere psl (prosedyrens statiske omgivelse) og  pp
962 	   * (prosedyrens prototype) og overf|rer evt. __conv og q */
963 	  fprintf (ccode, "__bp=");
964 	  gensl (rex->left, FALSE, ON);
965 	  fprintf (ccode, ";((__bs%d *)__pb)->%s.psl=((__bs%d *)__bp)->%s.psl;"
966 		   "((__bs%d *)__pb)->%s.pp=((__bs%d *)__bp)->%s.pp;",
967 		   rex->rd->encl->blno, rex->rd->ident,
968 		   rex->left->rd->encl->blno, rex->left->rd->ident,
969 		   rex->rd->encl->blno, rex->rd->ident,
970 		   rex->left->rd->encl->blno, rex->left->rd->ident);
971 	  gen_conv (rex, TRUE, FALSE);
972 	  break;
973 	case CNAME:
974 	  if (rex->rd->categ == CNAME)
975 	    {
976 	      /* Videresending av NAME-par. Kopierer hele den aktuelle
977 	       * beskrivelsen, dvs. sl,pp,psl,adr.men, adr.ent og namekind
978 	       * pluss evt. __conv og q. */
979 
980 	      fprintf (ccode, "((__bs%d *)__pb)->%s=",
981 		       rex->rd->encl->blno, rex->rd->ident);
982 	      gensl (rex->left, TRUE, ON);
983 	      fprintf (ccode, "%s;", rex->left->value.ident);
984 	      gen_conv (rex, TRUE, TRUE);
985 	    }
986 	  else
987 	    {
988 	      /* AKTUELL PARAMETER ER EN NAME-PAR I EN YTRE PROSEDYRE
989 	       * Kallerp} transcall som skriver ut koden for kallet
990 	       * __rgetproc. Den rutinen returnerer med statisk
991 	       * omgivelse i sl og prototypen i pp.
992 	       * Disse overf|res til den formelle parameteren */
993 
994 	      fprintf (ccode, "((__bs%d *)__pb)->%s.psl=__sl;"
995 		       "((__bs%d *)__pb)->%s.pp=__pp;",
996 		       rex->rd->encl->blno, rex->rd->ident,
997 		       rex->rd->encl->blno, rex->rd->ident);
998 	      gen_conv (rex, TRUE, FALSE);
999 	    }
1000 	  break;
1001 	case CVIRT:
1002 	case CLOCAL:
1003 	  fprintf (ccode, "((__bs%d *)__pb)->%s.psl=",
1004 		   rex->rd->encl->blno, rex->rd->ident);
1005 	  gensl (rex->left, FALSE, OFF);
1006 	  fprintf (ccode, ";");
1007 	  if (rex->left->rd->categ == CVIRT)
1008 	    /* M} teste under RUN-TIME om
1009 	     * virtuell-tabbelen er null */
1010 	    fprintf (ccode, "if((__pp=((__bs%d *)__pb)->%s.psl->"
1011 		     "pp->virt[%d])==__NULL)__rerror(__errvirt);",
1012 		     rex->rd->encl->blno, rex->rd->ident,
1013 		     rex->left->rd->virtno - 1);
1014 	  fprintf (ccode, "((__bs%d *)__pb)->%s.pp= ",
1015 		   rex->rd->encl->blno, rex->rd->ident);
1016 	  if (rex->left->rd->categ == CVIRT)
1017 	    fprintf (ccode, "__pp;");
1018 	  else
1019 	    {
1020 	      gen_adr_prot (ccode, rex->left->rd);
1021 	      fprintf (ccode, ";");
1022 	    }
1023 	  gen_conv (rex, TRUE, FALSE);
1024 	  break;
1025 	}			/* END-SWITCH */
1026 #if ADDNOTH
1027       if (rex->rd->categ == CNAME && rex->left->rd->categ != CNAME)
1028 	fprintf (ccode, "((__bs%d *)__pb)->%s.namekind=__ADDRESS_NOTHUNK;",
1029 		 rex->rd->encl->blno, rex->rd->ident);
1030 #endif
1031     }			/* END aktuell par.token = MIDENTIFIER */
1032   else
1033     {
1034       /* Aktuell par.token = MDOT */
1035 
1036       fprintf (ccode, "((__bs%d *)__pb)->%s.psl=",
1037 	       rex->rd->encl->blno, rex->rd->ident);
1038       if (nonetest == ON)
1039 	fprintf (ccode, "((__bp=");
1040       genvalue (rex->left->left);
1041       if (nonetest == ON)
1042 	fprintf (ccode, ")==__NULL?(__dhp)__rerror(__errnone):__bp)");
1043       fprintf (ccode, ";");
1044 
1045       if (rex->left->rd->categ == CVIRT)
1046 	/* M} teste under RUN-TIME om
1047 	 * virtuell-tabbelen er null */
1048 	fprintf (ccode, "if((__pp=((__bs%d *)__pb)->%s.psl->"
1049 		 "pp->virt[%d])==__NULL)__rerror(__errvirt);",
1050 		 rex->rd->encl->blno, rex->rd->ident,
1051 		 rex->left->right->rd->virtno - 1);
1052       fprintf (ccode, "((__bs%d *)__pb)->%s.pp= ",
1053 	       rex->rd->encl->blno, rex->rd->ident);
1054       if (rex->left->right->rd->categ == CVIRT)
1055 	fprintf (ccode, "__pp;");
1056       else
1057 	{
1058 	  gen_adr_prot (ccode, rex->left->right->rd);
1059 	  fprintf (ccode, ";");
1060 	}
1061       gen_conv (rex, TRUE, FALSE);
1062     }
1063 }
1064 
1065 /******************************************************************************
1066                                                                 GENPROCPARAM */
1067 
1068 genprocparam (re)
1069      struct EXP *re;
1070 {
1071   struct EXP *rex;
1072 
1073   for (rex = re->right; rex->token != MENDSEP; rex = rex->right)
1074     {
1075       if(rex->token == MSENTCONC)
1076 	{
1077 	  genvalue (rex->left); fprintf (ccode, ";");
1078 	}
1079       else if (rex->token == MSENDADDRESSTHUNKTOFORMALPAR)
1080 	{
1081 	  send_to_formal_par (rex, TRUE);
1082 	}
1083       else if (rex->token == MSENDVALUETHUNKTOFORMALPAR)
1084 	{
1085 	  send_to_formal_par (rex, FALSE);
1086 	}
1087       else if (rex->rd->kind == KSIMPLE)
1088 	{
1089 	  /* ENKEL PARAMETER */
1090 
1091 	  if (rex->rd->type == TLABEL)	/* LABEL PARAMETER */
1092 	    genlabelswitchpar (rex);
1093 	  else
1094 	    gensimplepar (rex);	/* INTEGER, REAL, CHARACTER,REF */
1095 	  /* TEXT ELLER BOOLEAN PARAMETER */
1096 	}
1097       else
1098 	/* END-ENKEL PARAMETER */
1099 	if (rex->rd->kind == KARRAY)
1100 	  {
1101 	    if (rex->rd->type != TLABEL)	/* ARRAY  PARAMETER */
1102 	      genarraypar (rex);
1103 	    else
1104 	      genlabelswitchpar (rex);
1105 	  }
1106 	else if (rex->rd->kind == KPROC)
1107 	  genprocedurepar (rex);
1108 	else			/* FEIL */;
1109     }/* END FOR L\KKE */
1110 }			/* END GENPROCPARAM */
1111 
1112 /******************************************************************************
1113                                                       GENPREDEFPROCCALL      */
1114 
1115 void
genpredefproccall(re)1116 genpredefproccall (re)
1117      struct EXP *re;
1118 {
1119   int i;
1120   /* Hvis danger = TRUE s} skal returverdien legges p} stakken */
1121 
1122   struct EXP *rex;
1123 
1124   if (re->danger)
1125     {
1126       switch (re->type)
1127 	{
1128 	case TREF:
1129 	  fprintf (ccode, "__r[%d]=(__dhp)", re->value.combined_stack.entry);
1130 	  break;
1131 	case TNOTY:
1132 	  break;		/* Skal ikke forekomme som 'danger' */
1133 	case TTEXT:
1134 	  fprintf (ccode, "__t[%d]= *", re->value.combined_stack.entry);
1135 	  break;
1136 	case TREAL:
1137 	  fprintf (ccode, "__v[%d].f=", re->value.combined_stack.entry);
1138 	  break;
1139 	case TINTG:
1140 	  fprintf (ccode, "__v[%d].i=", re->value.combined_stack.entry);
1141 	  break;
1142 	default:
1143 	  fprintf (ccode, "__v[%d].c=", re->value.combined_stack.entry);
1144 	}
1145     }			/* END-if(danger */
1146 
1147   if (re->rd->descr->codeclass != CCEXIT)
1148     fprintf (ccode, "%s(", re->rd->descr->rtname);
1149 
1150   switch (re->rd->descr->codeclass)
1151     {
1152     case CCRANDOMRUTDANGER:
1153     case CCSIMPLEDANGER:
1154     case CCSIMPLE:
1155       break;
1156     case CCDETACH:	/* Detach *//* gensl */
1157 
1158       if (is_after_dot (re) || seen_th_insp (re))
1159 	gensl (re, FALSE, nonetest);
1160       else
1161 	genchain (firstclass (), FALSE);
1162 
1163       fprintf (ccode, ",");
1164 
1165       /* No break at end of this case */
1166     case CCCALLRESUME:	/* CALL  og RESUME  */
1167       for (rex = re->right; rex->token != MENDSEP; rex = rex->right)
1168 	{
1169 	  genvalue (rex->left);
1170 	  fprintf (ccode, ",");
1171 	}
1172       fprintf (ccode, "%d,", i = newlabel ());
1173       genmodulemark(NULL);
1174       fprintf (ccode, ");");
1175       exitlabel (i);	/* Reentrings punkt */
1176       return;
1177       break;
1178     case CCEXIT:		/* TERMINATE_PROGRAM */
1179       if (separat_comp)
1180 	fprintf
1181 	  (ccode, "__goto.ent=%d,__goto.ment=__NULL;return;",
1182 	   STOPLABEL);
1183       else
1184 	gotolabel (STOPLABEL);
1185       not_reached = TRUE;
1186       return;
1187       break;
1188     case CCTEXTDANGER:
1189     case CCTEXT:
1190       /* TEXT-attributt prosedyre. F|rste parameter skal v{re
1191        * en peker til tekstvariabelen */
1192 	genvalue (re->up->left);
1193       if (re->right->token != MENDSEP)
1194 	fprintf (ccode, ",");
1195       break;
1196     case CCBLANKSCOPY:
1197     case CCFILEBLANKSCOPY:
1198       fprintf (ccode, "%ldL", re->value.combined_stack.n_of_stack_elements);
1199       if (re->right->token != MENDSEP
1200 	  || re->rd->descr->codeclass == CCFILEBLANKSCOPY)
1201 	fprintf (ccode, ",");
1202       if (re->rd->descr->codeclass == CCBLANKSCOPY)
1203 	break;
1204     case CCFILEDANGER:
1205     case CCFILE:
1206       /* En av fil-prosedyrene. F|rste parameter er peker til fil
1207        * klasse objektet */
1208       gensl (re, FALSE, nonetest);
1209 
1210       if (re->right->token != MENDSEP)
1211 	fprintf (ccode, ",");
1212       break;
1213     }			/* END-SWITCH */
1214 
1215   /* Overf|rer bruker parameterene */
1216 
1217   for (rex = re->right; rex->token != MENDSEP; rex = rex->right)
1218     {
1219       if (rex->rd->categ == CVAR)
1220 	{
1221 	  /* Siste parameter til random drawing */
1222 	  /* Som er en NAME (VAR) parameter */
1223 	  fprintf (ccode, "&");
1224 	}
1225       genvalue (rex->left);
1226 
1227       if (rex->right->token != MENDSEP)
1228 	fprintf (ccode, ",");
1229     }
1230   fprintf (ccode, ")");
1231 
1232 }				/* END-Genpredefproccall */
1233 
1234 
1235 /******************************************************************************
1236   GETFIRSTCLASSATTRIBUT */
1237 
1238 /* Hjelperutine som retunerer med en peker til DECL-objektet til f|rste
1239  * attributtet i klassen som parameteren peker p}. Den leter f|rst rekursivt
1240  * i prefiks klassene. Rutinen brukes under overf|ring av referanse
1241  * parametere til eksterne C-prosedyrer. */
1242 
1243 
1244 static struct DECL *
getfirstclassattribut(rd)1245 getfirstclassattribut (rd) struct DECL *rd;
1246 {
1247   struct DECL *rdd;
1248 
1249   if (rd->plev != 0
1250       && (rdd = getfirstclassattribut (rd->prefqual)) != NULL)
1251     return (rdd);
1252 
1253   for (rdd = rd->descr->parloc; rdd != NULL &&
1254        !(rdd->categ == CLOCAL && (rdd->kind == KSIMPLE
1255 				  || rdd->kind == KARRAY));
1256        rdd = rdd->next);
1257   return (rdd);
1258 }
1259 
1260 /******************************************************************************
1261   PAR_TO_CPROC */
1262 
1263 /* Overf|rer parameter til en ekstern C-prosedyre.
1264  * rex->left->rd angir den aktuelle parameteren, mens rex->rd angir den
1265  * formelle. */
1266 
1267 static par_to_cproc (rex) struct EXP *rex;
1268 {
1269   struct DECL *rd;
1270   switch (rex->rd->kind)
1271     {
1272     case KSIMPLE:
1273       if (rex->rd->type == TTEXT)
1274 	{
1275 	  if (rex->rd->categ == CVALUE)
1276 	    {
1277 	      /* By value, Kopierer teksten over i C-space */
1278 	      fprintf (ccode, "__rcopytexttoc(");
1279 	      genvalue (rex->left);
1280 	      fprintf (ccode, ")");
1281 	    }
1282 	  else if (rex->rd->categ == CDEFLT)
1283 	    {
1284 	      /* By referanse, Overf|rer en peker til f|rste character.
1285 	       * (dette gj|res av rt-rutienen raddroffirstchar */
1286 	      fprintf (ccode, "__raddroffirstchar(");
1287 	      genvalue (rex->left);
1288 	      fprintf (ccode, ")");
1289 	    }
1290 	}
1291       else if (rex->rd->categ == CVAR || rex->rd->categ == CNAME)
1292 	{			/* Enkel parameter (ikke TEXT) by name */
1293 	  fprintf (ccode, "&");
1294 	  genvalue (rex->left);
1295 	}
1296       else
1297 	{
1298 	  /* Overf|rt p} standard m}te. (IKKE TEXT */
1299 	  if (rex->rd->type == TREF)
1300 	    {
1301 	      /* Skal overf|re adressen til f|rste attributt Setter rd
1302 	       * til } peke p} f|rste attributt i klassen
1303 	       * rex->left->qual eller i en av dens prefiks-klasser.
1304 	       * Hvis klassen ikke har noen attributter overf|res NULL */
1305 
1306 	      rd = getfirstclassattribut (rex->left->qual);
1307 	      if (rd == NULL)
1308 		fprintf (ccode, "__NULL");
1309 	      else
1310 		{
1311 		  fprintf (ccode, "&((__bs%d *)", rd->encl->blno);
1312 		  genvalue (rex->left);
1313 		  fprintf (ccode, ")->%s", rd->ident);
1314 		}
1315 	    }
1316 	  else
1317 	    genvalue (rex->left);
1318 	}
1319       break;
1320     case KARRAY:
1321       /* Overef|ring av array som parameter. Lovlige
1322        * overf|ringsmodus er
1323        * For TEXT: by value = Lager et array av (char
1324        * i C-space, kopierer alle
1325        * tekster til C-space
1326        * by referense (categ = CDEFLT
1327        * Lager et (char *) array i
1328        * C-space, og setter disse til
1329        * peke p} tekstene i SIMULA
1330        * space. (f}rste tegn i teksten
1331        * by name -> ulovlig
1332        * For REF:  by referanse (categ = CDEFLT
1333        * Overf|rer peker til f|rste
1334        * element i arrayet
1335        * by name -> ulovlig
1336        * For andre by value   Kopierer arrayet til C-space
1337        * by referanse (categ = CDEFLT
1338        * by name (og var) : Peker til f|rste
1339        * element */
1340       if (rex->rd->type == TTEXT)
1341 	{
1342 	  fprintf (ccode, "__rcopytextarrtoc(");
1343 	  genvalue (rex->left);
1344 	  if (rex->rd->categ == CVALUE)
1345 	    fprintf (ccode, ",__TRUE)");
1346 	  else
1347 	    fprintf (ccode, ",__FALSE)");
1348 	}
1349       else
1350 	{
1351 	  if (rex->rd->categ == CVALUE)
1352 	    fprintf (ccode, "__rcopyarrtoc(");
1353 	  else
1354 	    fprintf (ccode, "__raddroffirstelem(");
1355 	  genvalue (rex->left);
1356 	  fprintf (ccode, ")");
1357 	}
1358       break;
1359     case KPROC:
1360       /* Bare lovlig } overf|re C-prosedyrer */
1361       fprintf (ccode, "(&%s)()",
1362 		      (rex->left->token == MDOT ?
1363 		       rex->left->right->rd->descr->rtname :
1364 		       rex->left->rd->descr->rtname));
1365       break;
1366 
1367     }
1368 }
1369 
1370 
1371 
1372 /******************************************************************************
1373   GENCPROCCALL      */
1374 gencproccall (re) struct EXP *re;
1375 {
1376   struct EXP *rex;
1377 
1378   fprintf (ccode, "%s(", re->rd->descr->rtname);
1379 
1380   /* Overf|rer parameterene */
1381 
1382   for (rex = re->right; rex->token != MENDSEP; rex = rex->right)
1383     {
1384       par_to_cproc (rex);
1385       if (rex->right->token != MENDSEP)
1386 	fprintf (ccode, ",");
1387 
1388     }			/* END-OVERF\RING AV PARAMETERE */
1389 
1390   fprintf (ccode, ")");
1391 
1392 }
1393