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