1 /* $Id: cdekl.c,v 1.10 1997/01/08 09:49:13 cim Exp $ */
2
3 /* Copyright (C) 1994, 1998 Sverre Hvammen Johansen,
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 /* Deklarasjonslager for Simula */
20
21 #include "const.h"
22 #include "dekl.h"
23 #include "const.h"
24 #include "lex.h"
25 #include "name.h"
26
27 #include <stdio.h>
28 #include <obstack.h>
29
30 char *xmalloc();
31 void free();
32
33 #define obstack_chunk_alloc xmalloc
34 #define obstack_chunk_free free
35
36 static struct obstack osDecl;
37 static struct obstack osPref;
38
39
40 /*****************************************************************************/
41 /* INITIELT */
42 /*****************************************************************************/
43
44
45
46 /* KONTAKT MED YACC, LEX OG FEILSYSTEMET */
47
48 /* Bruker bufferet til lex da det garantert er stort nokk
49 * Dette blir brukt i det tilfellet at det m} lages en ny tag
50 * for identen til en parameter som har navnkonflikt med en lokal variabel */
51
52 char yaccerror;
53
54 char *prefquantident;
55 int localused;
56 int arrdim;
57
58
59 struct BLOCK *ssblock; /* First system block
60 (The outermost system block with blev=0)
61 the system environment is conected to this block */
62
63 struct BLOCK *cblock; /* Current block */
64 struct BLOCK *sblock; /* First non system block
65 (The outermost block with blev=1)
66 sblock is connected with ssblock through
67 two INSP blocks (sysin and sysout) */
68
69 struct BLOCK *seenthrough; /* Settes av findGlobal og findLocal og peker
70 * p} en utenforliggende inspect blokk(hvis
71 * den finnes). Det er fordi jeg onsker
72 * } vite n}r en variable er sett gjennom
73 * inspect. Trenger denne informasjon i
74 * kode genereringen for } aksessere
75 * variable fra den inspiserte klassen
76 * gjennom inspect variabelen */
77 struct DECL *classtext;
78
79
80 int cblev;
81
82 struct DECL *cprevdecl;
83
84 /* Har en peker som peker p} en array deklarasjon som ikke har f}tt
85 * satt sin dim verdi. */
86 struct DECL *lastArray;
87
88 /* Under sjekkingen og innlesingen av deklarasjonene
89 * trenger jeg � merke de ulike objektene
90 * Lar atributter peke paa ulike objekter for merkeingen */
91 static struct DECL *sjekkdeklcalled;
92 static struct DECL *lastunknowns;
93 static struct BLOCK *unknowns;
94 struct DECL *commonprefiks; /* Felles prefiks til alle ikke prefiksede
95 * klasser Inneholder prosedyren DETACH */
96 static struct DECL *switchparam;
97 static struct DECL *procparam;
98 static struct DECL *sluttparam;
99 static struct DECL *arrayparam;
100
101 /******************************************************************************
102 PCLEAN, PPUSH and PPOP */
103 static ppush(rd)struct DECL *rd;
104 {
105 #if 0
106 obstack_ptr_grow (&osPref, rd);
107 #else
108 obstack_grow(&osPref, &rd, sizeof (void *));
109 #endif
110 }
111
pclean()112 static pclean()
113 {
114 void *p;
115 p= obstack_finish (&osPref);
116 obstack_free (&osPref, p);
117 }
118
ppop()119 static struct DECL *ppop()
120 {
121 struct DECL *rd;
122 if (obstack_next_free (&osPref) == obstack_base (&osPref))
123 return (NULL);
124
125 rd= * ((struct DECL * *) obstack_next_free (&osPref) - 1);
126 obstack_blank (&osPref, - sizeof (void *));
127 return (rd);
128 }
129
130 /******************************************************************************
131 NEW-DECL/BLOCK */
132
133
newDecl()134 struct DECL *newDecl()
135 {
136 struct DECL *rd;
137 rd= (struct DECL *) obstack_alloc (&osDecl, sizeof (struct DECL));
138 memset (rd, 0, sizeof (struct DECL));
139 return rd;
140 }
141
newBlock()142 static struct BLOCK *newBlock()
143 {
144 struct BLOCK *rb;
145 rb= (struct BLOCK *)obstack_alloc (&osDecl, sizeof (struct BLOCK));
146 memset (rb, 0, sizeof (struct BLOCK));
147 rb->quant.descr = rb;
148 return rb;
149 }
150
151 /******************************************************************************
152 INITDECL */
153
154 /* InitDecl kalles f�r selve innlesingen */
155
initDecl()156 initDecl ()
157 {
158 struct BLOCK *rb;
159 struct DECL *rd;
160
161 obstack_init(&osDecl);
162 obstack_init(&osPref);
163 cblev= -1;
164 sjekkdeklcalled = newDecl ();
165 unknowns = newBlock ();
166 unknowns->quant.kind = KERROR;
167
168 beginBlock (KBLOKK);
169 ssblock=cblock;
170
171 /* ssblock->quant.encl= ssblock; Dersom denne er med g�r kompilatoren inn
172 i en evig l�kke dersom det er noe som er udeklarert. Er ikke sikker
173 p� om � bare kommentere det ut er riktig l�sning */
174
175 lesinn_external_spec (tag ("TEXTOBJ*"), "simenvir");
176
177 commonprefiks = findGlobal (tag ("COMMON*"), TRUE);
178 commonprefiks->plev = -1;
179 classtext = findGlobal (tag ("TEXTOBJ*"), TRUE);
180
181 beginBlock (KINSP);
182 beginBlock (KINSP);
183 rd = findGlobal (tag ("MAXLONGREAL"), TRUE);
184 rd->value.rval = MAX_DOUBLE;
185 rd = findGlobal (tag ("MINLONGREAL"), TRUE);
186 rd->value.rval = -MAX_DOUBLE;
187 rd = findGlobal (tag ("MAXREAL"), TRUE);
188 rd->value.rval = MAX_DOUBLE;
189 rd = findGlobal (tag ("MINREAL"), TRUE);
190 rd->value.rval = -MAX_DOUBLE;
191 rd = findGlobal (tag ("MAXRANK"), TRUE);
192 rd->value.ival = MAXRANK;
193 rd = findGlobal (tag ("MAXINT"), TRUE);
194 rd->value.ival = MAX_INT;
195 rd = findGlobal (tag ("MININT"), TRUE);
196 rd->value.ival = -MAX_INT - 1;
197 }
198
199 /******************************************************************************
200 REINIT */
201
202 /* Reinit kalles f�r sjekkingen starter */
203
reinit()204 reinit ()
205 {
206 struct DECL *rd;
207 endBlock (NULL,CCNO);
208 endBlock (NULL,CCNO);
209 endBlock (NULL,CCNO);
210 /* M} gj|re et hack for } f} satt kvalifikasjon p} inspect sysin */
211 /* og inspect sysout, da neste blokk ikke er en connection blokk */
212 inBlock ();
213 inBlock (findGlobal (tag ("INFILE"), TRUE));
214 cblock->when = findGlobal (tag ("INFILE"), TRUE);
215 inBlock (findGlobal (tag ("PRINTFILE"), TRUE));
216 cblock->when = findGlobal (tag ("PRINTFILE"), TRUE);
217 sblock = cblock = cblock->next_block;
218
219 switchparam = newDecl ();
220 switchparam->type = TINTG;
221 switchparam->kind = KSIMPLE;
222 switchparam->categ = CDEFLT;
223 switchparam->encl = unknowns;
224
225 switchparam->next = newDecl ();
226 switchparam->next->type = TINTG;
227 switchparam->next->kind = KSIMPLE;
228 switchparam->next->categ = CDEFLT;
229 switchparam->next->encl = unknowns;
230 switchparam->next->next = switchparam->next;
231
232 procparam = newDecl ();
233 procparam->type = TERROR;
234 procparam->kind = TERROR;
235 procparam->categ = CNAME;
236 procparam->encl = unknowns;
237 procparam->next = procparam;
238
239 sluttparam = newDecl ();
240 sluttparam->encl = unknowns;
241 sluttparam->next = sluttparam;
242
243 arrayparam = newDecl ();
244 arrayparam->type = TINTG;
245 arrayparam->kind = KSIMPLE;
246 arrayparam->categ = CDEFLT;
247 arrayparam->encl = unknowns;
248 arrayparam->next = arrayparam;
249 }
250
251 /*****************************************************************************/
252 /* HJELPE-PROSEDYRER */
253 /*****************************************************************************/
254
255 /******************************************************************************
256 SETARRAYDIM */
257
258 /* LastArray peker p� f�rste array i siste arraydeklarasjon og setArrayDim
259 * settes disse arrayenes dimensjon (dim). S� lengde next ogs� er en array
260 * skal ogs� denne ha dimmensjonen arrdim.( integer array a,b(...); */
261
setArrayDim(arrdim)262 setArrayDim (arrdim) int arrdim;
263 {
264 while (lastArray != NULL)
265 {
266 lastArray->dim = arrdim;
267 lastArray = (lastArray->next == NULL ? NULL :
268 (lastArray->next->kind == KARRAY ? lastArray->next : NULL));
269 }
270 arrdim = 0;
271 }
272
273 /******************************************************************************
274 NEWNOTSEEN */
275
276 /* Newnotseen kalles hver gang det er noe udeklarert
277 * Den legger alle disse inn i en liste med de ukjente */
278
279 static struct DECL *
newnotseen(ident)280 newnotseen (ident)
281 char *ident;
282 {
283 if (lastunknowns == NULL)
284 unknowns->parloc = lastunknowns = newDecl ();
285 else
286 lastunknowns = lastunknowns->next = newDecl ();
287 lastunknowns->ident = ident;
288 lastunknowns->type = TERROR;
289 lastunknowns->kind = KERROR;
290 lastunknowns->categ = CNEW;
291 lastunknowns->dim = 1;
292 lastunknowns->encl = unknowns;
293 lastunknowns->descr = unknowns;
294 return (lastunknowns);
295 }
296
297 /******************************************************************************
298 FINDDECL */
299
300 /* FindDecl leter etter deklarasjonen ident lokalt i blokken og langs
301 * den prefikskjede.Den kalles rekursivt for hvert BLOCK objekt langs
302 * prefikskjeden.Ved en inspect blokk kalles den for den ispiserte
303 * klassen og dens prefikser.Finnes den returneres en peker til
304 * deklarasjonspakka, hvis ikke returneres NULL
305 * HVIS virt==TRUE skal det f�rst letes i evt. virtuell liste */
306
307 struct DECL *
findDecl(ident,rb,virt)308 findDecl (ident, rb, virt)
309 char *ident;
310 struct BLOCK *rb;
311 char virt;
312 {
313 struct DECL *rd;
314 if ((rb->quant.kind == KINSP) && (rb->when != NULL))
315 {
316 seenthrough = rb;
317 if ((rd = findDecl (ident, rb->when->descr, virt)) != NULL
318 && rd->type != TLABEL)
319 return (rd);
320 seenthrough = NULL;
321 }
322 else
323 {
324 if (virt && rb->quant.kind == KCLASS)
325 for (rd = rb->virt; rd != NULL; rd = rd->next)
326 if (rd->ident == ident && rd->protected == FALSE)
327 return (rd);
328
329 for (rd = rb->parloc; rd != NULL; rd = rd->next)
330 if (rd->ident == ident && rd->protected == FALSE)
331 return (rd);
332 }
333 /* G�r ogs� gjennom prefikskjeden */
334 if (rb->quant.kind == KCLASS || rb->quant.kind == KINSP || rb->quant.kind == KPRBLK
335 || rb->quant.kind == KFOR || rb->quant.kind == KCON)
336 if (rb->quant.plev > -1 && rb->quant.prefqual != NULL)
337 if ((rd = findDecl (ident, rb->quant.prefqual->descr,
338 rb->quant.kind == KCLASS | rb->quant.kind == KPRBLK ? FALSE : virt)) != NULL)
339 return (rd);
340
341 return (NULL);
342 }
343
344 /******************************************************************************
345 FINDGLOBAL */
346
347 /* FindGlobal finner den deklarasjonen som svarer til et navn
348 * Den leter for hvert blokknivaa, i prefikskjeden og lokalt
349 * Stopper ved f\rste forekomst, fins den ikke kalles newnotseen
350 * Hvis virt==true skal det f�rst letes i evt. virtuell liste */
351
352 struct DECL *
findGlobal(ident,virt)353 findGlobal (ident, virt)
354 char *ident;
355 char virt;
356 {
357 struct DECL *rd;
358 struct BLOCK *rb;
359
360 seenthrough = NULL;
361 for (rb= cblock; rb; rb= rb->quant.encl)
362 if ((rd= findDecl (ident, rb, virt)) != NULL)
363 {
364 if (rd->encl->blev == cblock->blev &&
365 (rd->categ == CLOCAL || rd->categ == CVIRT))
366 localused = TRUE;
367 return (rd);
368 }
369
370 for (rd = unknowns->parloc; rd != NULL; rd = rd->next)
371 if (rd->ident == ident)
372 return (rd);
373 return (newnotseen (ident));
374 }
375
376 /******************************************************************************
377 SAMEPARAM */
378
379 /* Sjekker om parameterene er de samme */
380
381 sameParam (rb1, rb2)
382 struct BLOCK *rb1,
383 *rb2;
384 {
385 struct DECL *rd1,
386 *rd2;
387 int i;
388 if (rb1 == NULL || rb2 == NULL)
389 return (FALSE);
390 if (rb1->quant.kind != KPROC || rb2->quant.kind != KPROC)
391 return (FALSE);
392 if (rb1->napar != rb2->napar)
393 return (FALSE);
394 rd1 = rb1->parloc;
395 rd2 = rb2->parloc;
396 for (i = 1; i <= rb1->napar; i++)
397 {
398 if (rd1->type != rd2->type && rd1->type != TNOTY)
399 return (FALSE);
400 if (rd1->kind != rd2->kind)
401 return (FALSE);
402 if (rd1->categ != rd2->categ)
403 return (FALSE);
404
405 if (rd1->prefqual != rd2->prefqual && rd1->type !=TNOTY)
406 {
407 if (subclass (rd2->prefqual, rd1->prefqual))
408 {
409 if (rd1->categ == CNAME) return (FALSE);
410 if (rd1->kind == KPROC) return (FALSE);
411 } else
412 if (subclass (rd1->prefqual, rd2->prefqual)) ;
413 else return (FALSE);
414 }
415 if (rd1->kind == KPROC &&
416 sameParam (rd2->descr, rd1->descr) == FALSE)
417 return (FALSE);
418 rd1 = rd1->next;
419 rd2 = rd2->next;
420 }
421 return (TRUE);
422 }
423
424 /******************************************************************************
425 MAKEEQUAL */
426
427 /* Gj�r rd1 lik rd2 ved � kopiere atributter */
428
429 static makeequal (rd1, rd2)
430 struct DECL *rd1,
431 *rd2;
432 {
433 rd1->ident = rd2->ident;
434 rd1->line = rd2->line;
435 rd1->plev = rd2->plev;
436 rd1->identqual = rd2->identqual;
437 rd1->dim = rd2->dim;
438 rd1->virtno = rd2->virtno;
439 rd1->type = rd2->type;
440 rd1->kind = rd2->kind;
441 rd1->categ = rd2->categ;
442 rd1->encl = rd2->encl;
443 rd1->descr = rd2->descr;
444 rd1->match = rd2->match;
445 rd1->next = NULL;
446 rd1->prefqual = rd2->prefqual;
447 rd1->protected = rd2->protected;
448 }
449
450 /******************************************************************************
451 COMMONQUAL */
452 /* Finner felles kvalifikasjon for to klasser
453 * NULL hviss ingen slik finnes */
454
455 struct DECL *
commonqual(rdx,rdy)456 commonqual (rdx, rdy)
457 struct DECL *rdx,
458 *rdy;
459 { /* Hvis rdx eller rdy peker p�
460 * commonprefiks (som har plev=-1) s} vil
461 * den leveres som felles kvalifikasjon, som
462 * er �nskelig i den situasjonen. Men hvis
463 * ikke en av dem peker dit s� vil IKKE
464 * commonprefiks v�re felles kvalifikasjon.
465 * Dette betyr at det ikke er n�dvendig
466 * med spesialbehandling for parametere til
467 * call, resume. Hvis rdx eller rdy er lik
468 * NULL, returneres den andre. */
469 if (rdx == NULL) return (rdy);
470 if (rdy == NULL) return (rdx);
471 if (rdx == rdy) return (rdx);
472 while (rdx != NULL && rdx->plev > rdy->plev)
473 rdx = rdx->prefqual;
474 if(rdx == NULL) return(rdy);
475 while (rdy != NULL && rdy->plev > rdx->plev)
476 rdy = rdy->prefqual;
477 while (rdx != rdy && rdx!=NULL && rdy != NULL && rdx->plev > 0)
478 {
479 rdx = rdx->prefqual;
480 rdy = rdy->prefqual;
481 }
482 return (rdx == rdy ? rdx : NULL);
483 }
484
485 /******************************************************************************
486 SUBCLASS */
487
488 /* Er rdx en subklasse til rdy, returnerer TRUE eller FALSE */
489
490 char
subclass(rdx,rdy)491 subclass (rdx, rdy)
492 struct DECL *rdx,
493 *rdy;
494 {
495 if (rdx == rdy)
496 return (TRUE);
497 if (rdx == NULL || rdy == NULL) return(FALSE);
498 if (rdx->plev < rdy->plev)
499 return (0);
500 while (rdx != NULL && rdx->plev > rdy->plev)
501 rdx = rdx->prefqual;
502 return (rdx == rdy);
503 }
504
505 /******************************************************************************
506 SUBORDINATE */
507
508 char
subordinate(rda,rdb)509 subordinate (rda, rdb)
510 struct DECL *rda,
511 *rdb;
512 {
513 return ((rda->type != TREF && rda->type == rdb->type)
514 || rdb->type == TNOTY || (rda->type == TREF && rdb->type == TREF
515 && subclass (rda->prefqual, rdb->prefqual)));
516 }
517
518
519 /*****************************************************************************/
520 /* INNLESING */
521 /*****************************************************************************/
522
523
524 /******************************************************************************
525 BEGINBLOCK */
526
527 /* Kalles fra syntakssjekkeren hver gang en ny blokk entres */
528
529 void
beginBlock(kind)530 beginBlock (kind)
531 char kind;
532 {
533 static int cblno = STARTBLNO;
534 static struct BLOCK *lblock;
535 struct DECL *rd2;
536 if (yaccerror)
537 return;
538 #ifdef DEBUG
539 if (option_input)
540 printf (
541 "beginBlock---line:%ld type:%c kind:%c categ:%c\t"
542 ,lineno, type, kind, categ);
543 #endif
544
545 {
546 struct BLOCK *lastcblock= cblock;
547
548 if (kind == KPROC || kind == KCLASS)
549 {
550 cblock = (struct BLOCK *) cprevdecl;
551 cprevdecl->match = cprevdecl;
552 }
553 else
554 {
555 cblock = newBlock ();
556 cblock->quant.line = lineno;
557 cblock->quant.kind = kind;
558 #if 1
559 if (lastcblock != NULL)
560 {
561 if (lastcblock->lastparloc == NULL)
562 cprevdecl= lastcblock->parloc=lastcblock->lastparloc=
563 &cblock->quant;
564 else
565 cprevdecl= lastcblock->lastparloc=
566 lastcblock->lastparloc->next= &cblock->quant;
567 cblock->quant.type= TNOTY;
568 cblock->quant.categ= CLOCAL;
569 }
570 #endif
571 }
572 cblock->quant.encl= lastcblock;
573 }
574
575 if (lblock != NULL)
576 lblock = lblock->next_block = cblock;
577 else
578 lblock = cblock;
579
580 cblock->blno = cblno++;
581 switch (kind)
582 {
583 case KPROC:
584 case KCLASS:
585 cblev++;
586 if (staticblock && cblock->quant.categ == CLOCAL)
587 cblock->stat = TRUE;
588 break;
589 case KFOR:
590 case KINSP:
591 case KCON:
592 cblock->quant.ident = NULL;
593 /* cblock->quant.encl = NULL;*/
594 cblock->quant.descr = cblock;
595 rd2 = &cblock->quant.encl->quant;
596
597 cblock->quant.prefqual = rd2;
598 cblock->quant.plev = rd2->plev + 1;
599 if (rd2->kind != KCON && rd2->kind != KINSP &&
600 rd2->kind != KFOR)
601 cblock->quant.match = rd2;
602 else
603 cblock->quant.match = rd2->match;
604
605 switch (cblock->quant.prefqual->kind)
606 {
607 case KFOR:
608 case KCON:
609 case KINSP:
610 cblock->fornest= cblock->quant.prefqual->descr->fornest;
611 cblock->connest= cblock->quant.prefqual->descr->connest;
612 break;
613 }
614 switch (kind)
615 {
616 case KFOR:
617 cblock->fornest+= 1;
618 if (cblock->quant.match->descr->fornest < cblock->fornest)
619 cblock->quant.match->descr->fornest++;
620 break;
621 case KINSP:
622 cblock->connest+= 1;
623 if (cblock->quant.match->descr->connest < cblock->connest)
624 cblock->quant.match->descr->connest++;
625 break;
626 }
627
628 if (staticblock)
629 cblock->stat = TRUE;
630 break;
631 case KPRBLK:
632 cblev++;
633 /* cblock->quant.ident= tag ("blokk");*/
634 cblock->quant.descr= cblock;
635 cblock->quant.identqual= prefquantident;
636 if (staticblock)
637 cblock->stat= TRUE;
638 break;
639 default:
640 cblev++;
641 if (staticblock)
642 cblock->stat = TRUE;
643 break;
644 }
645 cblock->blev = cblev;
646 #ifdef DEBUG
647 if (option_input)
648 printf ("---end\n");
649 #endif
650 }
651
652 /******************************************************************************
653 ENDBLOCK */
654
655 /* Kalles fra syntakssjekkeren hver gang en blokk terminerer */
656
657 /*VARARGS0 */
658 void
endBlock(rtname,codeclass)659 endBlock (rtname, codeclass)
660 char *rtname;
661 char codeclass;
662 {
663 #ifdef DEBUG
664 if (option_input)
665 printf ("endBlock---line:%ld type:%c kind:%c categ:%c\t"
666 ,lineno, type, kind, categ);
667 #endif
668 if (yaccerror)
669 return;
670 switch (cblock->quant.kind)
671 {
672 case KFOR:
673 case KINSP:
674 case KCON:
675 break;
676 default:
677 if (codeclass)
678 {
679 cblock->rtname = rtname;
680 cblock->codeclass = codeclass;
681 }
682 cblev--;
683 }
684 cblock = cblock->quant.encl;
685 #ifdef DEBUG
686 if (option_input)
687 printf ("---end\n");
688 #endif
689 }
690
691 /******************************************************************************
692 REGDECL */
693
694 /* RegDecl kalles fra syntakssjekkeren
695 * hver gang vi leser en deklarasjon */
696
697 void
regDecl(ident,type,kind,categ)698 regDecl (ident, type, kind, categ)
699 char *ident, type, kind, categ;
700 {
701 struct DECL *pd,
702 *pdx = NULL;
703 #ifdef DEBUG
704 if (option_input)
705 printf ("regDecl---line:%ld navn:%s type:%c kind:%c categ:%c\n"
706 ,lineno, ident, type, kind, categ);
707 #endif
708 if (yaccerror)
709 return;
710 switch (categ)
711 {
712 case CVALUE:
713 case CNAME:
714 case CVAR: /* Denne er kun satt for eksterne moduler */
715 if (kind == KNOKD)
716 {
717 for (pd = cblock->parloc;
718 pd != NULL && pd->ident != ident; pd = pd->next);
719 if (pd != NULL || type != TVARARGS)
720 {
721 cprevdecl = pd;
722 if (pd == NULL)
723 d1error (34, ident);
724 else
725 {
726 if (pd->categ != CDEFLT)
727 d1error (35, ident);
728 pd->categ = categ;
729 if (categ == CNAME && nameasvar == ON)
730 pd->categ = CVAR;
731 }
732 break;
733 }
734 }
735 case CDEFLT:
736 cblock->napar++;
737 case CLOCAL:
738 case CCONSTU:
739 case CCONST:
740 case CEXTR:
741 case CEXTRMAIN:
742 case CCPROC:
743 proceed:
744 if (kind == KCLASS || kind == KPROC)
745 {
746 pd = (struct DECL *) newBlock ();
747 }
748 else
749 {
750 pd = newDecl ();
751 }
752 if (cblock->lastparloc == NULL)
753 cprevdecl = cblock->parloc = cblock->lastparloc = pd;
754 else
755 cprevdecl = cblock->lastparloc = cblock->lastparloc->next = pd;
756 cblock->lastparloc->ident = ident;
757 cblock->lastparloc->line = lineno;
758 cblock->lastparloc->type = type;
759 cblock->lastparloc->kind = kind;
760 cblock->lastparloc->categ = categ;
761 if (categ == CNAME && nameasvar == ON)
762 cblock->lastparloc->categ = CVAR;
763 cblock->lastparloc->encl = cblock;
764 if ((type == TREF || kind == KCLASS)
765 && (categ == CLOCAL || categ == CEXTR /* ||
766 * categ==CEXTRMAIN */
767 || categ == CCPROC || categ == CDEFLT
768 || (categ == CVALUE || categ == CNAME
769 || categ == CVAR) && kind != KNOKD))
770 {
771 if (kind == KCLASS && cblock->quant.kind == KCLASS)
772 cblock->localclasses = TRUE;
773 cblock->lastparloc->identqual = prefquantident;
774 }
775 break;
776 case CSPEC:
777 for (pd = cblock->parloc; pd != NULL && pd->ident != ident; pd = pd->next)
778 pdx = pd;
779 cprevdecl = pd;
780 if (pd == NULL)
781 d1error (34, ident);
782 else
783 {
784 if (pd->kind != KNOKD)
785 d1error (36, ident);
786 pd->type = type;
787 pd->kind = kind;
788 if (type == TREF)
789 {
790 pd->identqual = prefquantident;
791 }
792 if (kind == KPROC)
793 {
794 /* Bytter ut dette objektet med et st|rre */
795 cprevdecl = &newBlock ()->quant;
796 if (cblock->lastparloc == pd)
797 cblock->lastparloc = cprevdecl;
798 makeequal (cprevdecl, pd);
799 cprevdecl->descr = (struct BLOCK *) cprevdecl;
800 cprevdecl->next = pd->next;
801 if (pdx == NULL)
802 cblock->parloc = cprevdecl;
803 else
804 pdx->next = cprevdecl;
805 }
806 }
807 break;
808 case CHIDEN:
809 case CPROT:
810 case CHIPRO:
811 pd = cblock->hiprot;
812 if (pd != NULL)
813 while (pd->next != NULL && pd->ident != ident)
814 pd = pd->next;
815 if (pd != NULL && pd->ident == ident)
816 {
817 if (pd->categ != categ && pd->categ != CHIPRO
818 && categ != CHIPRO)
819 pd->categ = CHIPRO;
820 else
821 {
822 d1error (41, ident);
823 if (categ == CHIPRO)
824 pd->categ = CHIPRO;
825 }
826 cprevdecl = pd;
827 }
828 else
829 {
830 if (pd == NULL)
831 cblock->hiprot = pd = newDecl ();
832 else
833 pd = pd->next = newDecl ();
834 pd->ident = ident;
835 pd->line = lineno;
836 pd->type = TNOTY;
837 pd->kind = KNOKD;
838 pd->categ = categ;
839 pd->encl = cblock;
840 }
841 break;
842 case CVIRT:
843 if (kind == KCLASS || kind == KPROC)
844 {
845 pd = (struct DECL *) newBlock ();
846 }
847 else
848 {
849 pd = newDecl ();
850 }
851 if (cblock->lastvirt == NULL)
852 cblock->virt = pd = cblock->lastvirt= pd;
853 else
854 pd = cblock->lastvirt = cblock->lastvirt->next = pd;
855 cprevdecl = pd;
856 pd->ident = ident;
857 pd->line = lineno;
858 pd->type = type;
859 pd->kind = kind;
860 pd->categ = categ;
861 pd->encl = cblock;
862 if (type == TREF)
863 {
864 pd->identqual = prefquantident;
865 }
866 break;
867 default:
868 d1error (37);
869 break;
870 }
871 #ifdef DEBUG
872 if (option_input)
873 printf ("---end\n");
874 #endif
875 }
876
877 /******************************************************************************
878 REGINNER */
879
880 /* Kalles fra syntakssjekkeren hver gang
881 * inner oppdages, sjekker da lovligheten */
882
regInner()883 regInner ()
884 {
885 #ifdef DEBUG
886 if (option_input)
887 printf ("regInner---line:%ld cblev:%d\t"
888 ,lineno, cblev);
889 #endif
890 if (cblock->quant.kind != KCLASS)
891 d1error (38);
892 else
893 {
894 if (cblock->inner)
895 d1error (39);
896 else
897 cblock->inner = TRUE;
898 }
899 #ifdef DEBUG
900 if (option_input)
901 printf ("---end\n");
902 #endif
903 }
904
905 /*****************************************************************************/
906 /* SJEKKING AV DEKLARASJONER */
907 /*****************************************************************************/
908
909 /******************************************************************************
910 DUMPDEKL */
911
912 /* Dumpdekl skriver ut tilstanden til en deklarasjon
913 * brukes ved uttesting av kompilatoren */
914
915 #ifdef DEBUG
916
917 static dumpdekl (rd)
918 struct DECL *rd;
919 {
920 printf (" --DECL:%s=%d, k:%c,t:%c,c:%c, plev:%d, dim:%d, virtno:%d, line:%ld", rd->ident, rd->ident, rd->kind, rd->type, rd->categ, rd->plev, rd->dim, rd->virtno, rd->line);
921 if (rd->protected == TRUE)
922 printf (" PROTECTED");
923 printf ("\n");
924 if (rd->descr != NULL)
925 printf (" Blokk:(%d,%d)\n", rd->descr->blno, rd->descr->blev);
926
927 if (rd->match != NULL && rd->categ == CVIRT)
928 {
929 if (rd->match != rd)
930 {
931 if (rd->kind == KPROC)
932 printf (" match:Blokk(%d,%d) navn:%s\n",
933 rd->match->descr->blno, rd->match->descr->blev,
934 rd->match->ident);
935 else
936 printf (" match:%s i Blokk(%d,%d)\n",
937 rd->match->ident, rd->match->encl->blno, rd->match->encl->blev);
938 }
939 else
940 printf (" match:INGEN MATCH\n");
941 }
942 else if (rd->match == NULL && rd->categ == CVIRT)
943 printf (" match:INGEN MATCH\n");
944
945 if (rd->prefqual != NULL && rd->type == TREF)
946 printf (" kvalifikasjon:%s\n", rd->prefqual->ident);
947 if (rd->descr != NULL && (rd->categ == CDEFLT || rd->categ == CVIRT))
948 {
949 if (rd->categ == CVIRT)
950 {
951 printf (" Virtuell spec:\n");
952 printf (">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n");
953 dumpblock (rd->descr);
954 printf ("<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n");
955 }
956 else
957 {
958 printf (" Formell procedure spec:\n");
959 printf (">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n");
960 dumpblock (rd->descr);
961 printf ("<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n");
962 }
963 }
964 }
965
966 /******************************************************************************
967 DUMPBLOCK */
968
969 /* Dumpblock skriver ut tilstanden til en blokk
970 * Den gj�r i sin tur en rekke kall paa dumpdekl */
971
972 static dumpblock (rb)
973 struct BLOCK *rb;
974 {
975 struct DECL *rd;
976 printf
977 ("->BLOCK:(%d,%d) k:%c, np:%d, nv:%d, nvl:%d, f:%d, c:%d, l:%ld, ",
978 rb->blno, rb->blev, rb->quant.kind,
979 rb->napar, rb->navirt, rb->navirtlab, rb->fornest,
980 rb->connest, rb->quant.line);
981 if (rb->localclasses)
982 printf ("l:YES ");
983 else
984 printf ("l:NO ");
985 if (rb->thisused)
986 printf ("t:YES ");
987 else
988 printf ("t:NO ");
989 printf ("\n");
990
991 if (rb->quant.categ == CEXTR || rb->quant.categ == CEXTRMAIN)
992 {
993 if (rb->quant.kind == KCLASS)
994 printf (" Extern klasse %s timestampandfilename:%s %s\n",
995 rb->quant.ident, rb->timestamp, rb->filename);
996 else
997 printf (" Extern prosedyre %s timestampandfilename:%s %s\n",
998 rb->quant.ident, rb->timestamp, rb->filename);
999 }
1000 else if (rb->quant.categ == CCPROC)
1001 printf (" C-Prosedyre %s\n", rb->rtname);
1002
1003 if (rb->timestamp != 0)
1004 printf (" I extern modul : timestampandfilename:%s %s\n",
1005 rb->timestamp, rb->filename);
1006
1007
1008 printf (" quant:%s plev:%d\n",
1009 rb->quant.ident, rb->quant.plev);
1010
1011 if (rb->quant.prefqual != NULL)
1012 {
1013 printf (" Prefikskjeden:\n");
1014 for (rd = rb->quant.prefqual; rd != NULL; rd = rd->prefqual)
1015 {
1016 printf (" Blokk:(%d,%d) ", rd->descr->blno,
1017 rd->descr->blev);
1018 if (rd->ident != 0)
1019 printf (" navn : %s\n", rd->ident);
1020 else
1021 printf ("\n");
1022 }
1023
1024 }
1025
1026 if (rb->parloc != NULL && rb->parloc->encl != rb)
1027 {
1028
1029 }
1030 else if (rb->parloc != NULL)
1031 {
1032 printf (" Parametere:\n");
1033 for (rd = rb->parloc; rd != NULL &&
1034 (rd->categ == CDEFLT || rd->categ == CVALUE ||
1035 rd->categ == CNAME || rd->categ == CVAR);
1036 rd = rd->next)
1037 dumpdekl (rd);
1038 printf (" Deklarasjoner:\n");
1039 for (; rd != NULL; rd = rd->next)
1040 dumpdekl (rd);
1041
1042 }
1043 if (rb->virt != NULL && rb->virt->encl != rb)
1044 {
1045 }
1046 else if (rb->virt != NULL)
1047 {
1048 printf (" Virtuelle:\n");
1049 for (rd = rb->virt; rd != NULL; rd = rd->next)
1050 dumpdekl (rd);
1051 }
1052 if (rb->hiprot != NULL && rb->hiprot->encl != rb)
1053 {
1054 }
1055 else if (rb->hiprot != NULL)
1056 {
1057 printf (" Hidden/Protected:\n");
1058 for (rd = rb->hiprot; rd != NULL; rd = rd->next)
1059 dumpdekl (rd);
1060 }
1061 printf ("\n");
1062 }
1063
1064 /******************************************************************************
1065 DUMP */
1066
1067 /* Dump skriver ut tilstanden til hele strukturen
1068 * Den gj�r et kall p� dumpblock for hver blokk */
1069
dump()1070 static dump ()
1071 {
1072 struct BLOCK *rb;
1073 printf ("BLOKK:Blno,Blev,kind,napar,navirt,navirtlab,");
1074 printf ("fornest,connest,line1,line2,localclasses,thisused\n\n");
1075 printf ("DECL:navn,kind,type,categ,plev,dim,virtno,line\n\n");
1076 for (rb = sblock; rb != NULL; rb = rb->next_block)
1077 if (!(rb->quant.kind == KPROC && (rb->quant.categ == CDEFLT ||
1078 rb->quant.categ == CVIRT)))
1079 dumpblock (rb);
1080 printf ("---UNKNOWNS---\n");
1081 dumpblock (unknowns);
1082 fflush (stdout);
1083 }
1084
1085 #endif
1086
1087 /******************************************************************************
1088 SETPROTECTED */
1089
1090 /* Setter/fjerner protected merket n�r klasser entres/forlates */
1091
1092 static setprotectedvirt (rb, rd, protected)
1093 struct BLOCK *rb;
1094 struct DECL *rd;
1095 char protected;
1096 {
1097 struct BLOCK *rbx;
1098 struct DECL *rdx;
1099 rbx = rb;
1100 /* Den virtuelle listen for innerste prefiksniv} er ikke akkumulert opp */
1101 if (rb->navirt == 0 & rb->navirtlab == 0)
1102 goto neste;
1103 while (TRUE)
1104 {
1105 if (rd->kind == KPROC && rbx->navirt < rd->virtno)
1106 break;
1107 if (rd->kind != KPROC && rbx->navirtlab < rd->virtno)
1108 break;
1109 for (rdx = rbx->virt; rdx->virtno != rd->virtno |
1110 rdx->kind != rd->kind; rdx = rdx->next);
1111 rdx->protected = protected;
1112 if (rdx->match != NULL)
1113 rdx->match->protected = protected;
1114 neste:if (rbx->quant.plev > 0)
1115 rbx = rbx->quant.prefqual->descr;
1116 else
1117 break;
1118 }
1119 }
1120
1121 static setprotected (rb, protected)
1122 struct BLOCK *rb;
1123 char protected;
1124 {
1125 struct BLOCK *rbx;
1126 struct DECL *rd;
1127 for (rd = rb->hiprot; rd != NULL; rd = rd->next)
1128 if (rd->match != NULL && rd->match->encl == rb)
1129 {
1130 if (rd->match->categ == CVIRT)
1131 setprotectedvirt (rb, rd->match, protected);
1132 else
1133 rd->match->protected = protected;
1134 }
1135 rbx = rb;
1136 while (rbx->quant.plev > 0)
1137 {
1138 rbx = rbx->quant.prefqual->descr;
1139 for (rd = rbx->hiprot; rd != NULL; rd = rd->next)
1140 if (rd->categ != CHIPRO && rd->match != NULL)
1141 {
1142 if (rd->match->categ == CVIRT)
1143 setprotectedvirt (rb, rd->match, TRUE - rd->match->protected);
1144 else
1145 rd->match->protected = TRUE - rd->match->protected;
1146 }
1147 }
1148 }
1149
1150 /******************************************************************************
1151 SETPREFCHAIN */
1152
1153 /* Setter opp prefikskjeden rekursift
1154 * Oppdager ulovlig prefiks og feil prefiksniv�
1155 * Oppdager ved merking sirkul�r prefikskjede */
1156
1157 static setprefchain (rd)
1158 struct DECL *rd;
1159 {
1160 struct DECL *rdx;
1161 if (rd->plev <= 0 && rd->identqual==NULL)
1162 {
1163 if (rd->plev == 0)
1164 rd->prefqual = commonprefiks;
1165 }
1166 else
1167 {
1168 rdx = findGlobal (rd->identqual, FALSE);
1169 rd->identqual=NULL;
1170 rd->plev = 0;
1171 if (rdx->categ == CNEW)
1172 {
1173 rdx->categ = CERROR;
1174 d2error (50, rd, rdx);
1175 rd->prefqual = commonprefiks;
1176 }
1177 else if (rdx->kind != KCLASS)
1178 {
1179 if (rdx->categ != CERROR)
1180 d2error (50, rd, rdx);
1181 rdx->categ = CERROR;
1182 rd->prefqual = commonprefiks;
1183 }
1184 else if (seenthrough != NULL)
1185 {
1186 if (rdx->categ != CERROR)
1187 d2error (49, rd, rdx);
1188 rdx->categ = CERROR;
1189 rd->prefqual = commonprefiks;
1190 }
1191 else if ((cblock->quant.kind == KFOR && rdx->encl != rd->encl)
1192 /* For for-block s} blir ikke blokkniv}et |ket. Prefiksen vil aldri
1193 * v{re deklarert i for-blokken (da ville det v{rt lagt p} en ekstra
1194 * blokk), den vil ligge i prefiksen til for-blokken, og det er
1195 * ulovlig, da en for-blokk alltid skal opptre som om det er en blokk
1196 */
1197 || (rdx->encl->blev != rd->encl->blev))
1198 {
1199 if (rdx->categ != CERROR)
1200 d2error (51, rd, rdx);
1201 rdx->categ = CERROR;
1202 rd->prefqual = commonprefiks;
1203 }
1204 else
1205 {
1206 if (rdx->prefqual == NULL)
1207 setprefchain (rdx);
1208 if (rd->prefqual == commonprefiks)
1209 d2error (52, rd, rdx);
1210 else
1211 {
1212 rd->prefqual = rdx;
1213 rd->plev = rdx->plev + 1;
1214 }
1215 }
1216 }
1217 }
1218
1219 /******************************************************************************
1220 SETQUALPREFCHAIN */
1221
1222 /* Setter opp prefikskjeden og kvalifikasjonen til pekere
1223 * gj�r kall p� setprefchain og sjekker kvalifikasjonen */
1224
1225 static struct DECL *
setqualprefchain(rd,param)1226 setqualprefchain (rd, param)
1227 struct DECL *rd;
1228 int param;
1229 {
1230 struct DECL *rdx;
1231 for (; rd != NULL; rd = rd->next)
1232 {
1233 if (param && (rd->categ == CLOCAL || rd->categ == CCONSTU
1234 || rd->categ == CCPROC || rd->categ == CEXTR
1235 || rd->categ == CEXTRMAIN))
1236 return (rd);
1237 if (rd->type == TREF)
1238 {
1239 rdx = findGlobal (rd->identqual, FALSE);
1240 rd->plev = 0;
1241 if (rdx->categ == CNEW)
1242 {
1243 d2error (53, rd);
1244 rdx->categ = CERROR;
1245 }
1246 else if (rdx->kind != KCLASS)
1247 {
1248 if (rdx->categ != CERROR)
1249 d2error (54, rd);
1250 rdx->categ = CERROR;
1251 rd->type = TERROR;
1252 }
1253 rd->prefqual = rdx;
1254 }
1255 if (rd->kind == KCLASS && rd->prefqual == NULL)
1256 setprefchain (rd);
1257 }
1258 return (rd);
1259 }
1260
1261 /******************************************************************************
1262 SJEKKDEKL */
1263
1264 /* Kalles i pass 2 for hver blokk som ikke er en prosedyre eller klasse
1265 * Sjekkdekl tar seg av � sjekke og akumulere opp virtuelle
1266 * Prefikskjeden og kvalifikasjoner settes ved kall p� setqualprefchain
1267 * den sjekker ogs� konsistensen for type kind og categ */
1268
1269 void
sjekkdekl(rb)1270 static sjekkdekl (rb)
1271 struct BLOCK *rb;
1272 {
1273 struct DECL *rd = NULL,
1274 *rdx = NULL,
1275 *rdy,
1276 *va = NULL,
1277 *vb = NULL,
1278 *vc = NULL;
1279 struct BLOCK *rbx = NULL;
1280 int vno,
1281 vnolab,
1282 kind;
1283 switch (kind = rb->quant.kind)
1284 {
1285 case KCLASS:
1286 /* Merker at denne klassen er blitt kalt */
1287 rb->quant.match = sjekkdeklcalled;
1288 /* Prefiksen maa f�rst alokeres */
1289 if (rb->quant.plev > 0)
1290 {
1291 rbx = rb->quant.prefqual->descr;
1292 if (rbx->quant.match != sjekkdeklcalled)
1293 {
1294 cblock = rbx;
1295 sjekkdekl (rbx);
1296 cblock = rb;
1297 }
1298 rb->localclasses |= rbx->localclasses;
1299 rb->napar += rbx->napar;
1300 }
1301 break;
1302 case KPRBLK:
1303 /* M� lete p� niv�et utenfor prefiksblokken */
1304 cblev--;
1305 cblock= cblock->quant.encl;
1306 setprefchain (&rb->quant);
1307 cblev++;
1308 cblock= rb;
1309 if (cblev <= 2 /*|| display[cblev - 1]->stat*/)
1310 rb->stat = TRUE;
1311 break;
1312 case KINSP:
1313 /* if (rb->quant.prefqual->descr->stat)
1314 rb->stat = TRUE;*/
1315 return; /* Sjekker blokken som inspiseres ved dens
1316 * deklarasjon */
1317 case KFOR:
1318 case KCON:
1319 /* if (rb->quant.prefqual->descr->stat)
1320 rb->stat = TRUE;*/
1321 break;
1322 case KBLOKK:
1323 if (cblev <= 2 /*|| display[cblev - 1]->stat*/)
1324 rb->stat = TRUE;
1325 break;
1326 default:
1327 /* INGEN AKSJON */
1328 break;
1329 }
1330 /* Sjekker alle deklarasjonene til denne blokken */
1331 for (rd = rb->parloc; rd != NULL; rd = rd->next)
1332 {
1333 if (rd->ident != NULL)
1334 {
1335 /* Sjekker dobbeltdeklarasjoner */
1336 for (rdx = rb->parloc; rdx->ident != rd->ident
1337 || rdx->protected == TRUE; rdx = rdx->next);
1338 if (rdx != rd)
1339 {
1340 if (kind == KPROC && (rdx->categ == CDEFLT ||
1341 rdx->categ == CVALUE ||
1342 rdx->categ == CNAME ||
1343 rdx->categ == CVAR) &&
1344 rd->categ != CDEFLT && rd->categ != CVALUE &&
1345 rd->categ != CNAME && rd->categ != CVAR)
1346 {
1347 char *s;
1348 obstack_grow (&osDecl, "__", 2);
1349 obstack_grow0 (&osDecl, rdx->ident, strlen(rdx->ident));
1350 s= obstack_finish(&osDecl);
1351 rdx->ident = tag (s);
1352 obstack_free (&osDecl, s);
1353 }
1354 else
1355 d2error (55, rd);
1356 }
1357 }
1358 if (rd->kind == KNOKD && rd->type != TVARARGS)
1359 d2error (63, rd);
1360 if (rd->kind == KARRAY && rd->type == TNOTY)
1361 rd->type = TREAL;
1362 switch (rd->categ)
1363 {
1364 case CLOCAL:
1365 case CCONST:
1366 case CCONSTU:
1367 /* Ikke mer sjekking lokale deklarasjoner */
1368 break;
1369 case CDEFLT:
1370 /* Procedyrer, label eller switch er ikke
1371 * lovlig som parameter til klasser */
1372 /* if (kind == KCLASS)
1373 {
1374 if (rd->kind == KPROC | rd->type == TLABEL)
1375 d2error (56, rd);
1376 }*/
1377 if (rd->type == TVARARGS)
1378 {
1379 if (rd->next != NULL)
1380 d2error (80, rd);
1381 if (kind != KPROC || rb->quant.categ != CCPROC)
1382 d2error (81, rd);
1383 }
1384 if (rd->type == TLABEL && rb->quant.categ == CCPROC)
1385 d2error (82, rd);
1386 break;
1387 case CVALUE:
1388 /* Sjekker om lovlig valueoverf�ring */
1389 if ((rd->type == TINTG | rd->type == TREAL | rd->type == TBOOL |
1390 rd->type == TCHAR) && (rd->kind == KSIMPLE | rd->kind == KARRAY))
1391 {
1392 if (rd->kind == KSIMPLE)
1393 rd->categ = CDEFLT;
1394 }
1395 else if (rd->type == TTEXT & rd->kind == KSIMPLE) /* OK */ ;
1396 else if (rd->type == TVARARGS)
1397 {
1398 if (rd->next != NULL)
1399 d2error (80, rd);
1400 if (kind != KPROC || rb->quant.categ != CCPROC)
1401 d2error (81, rd);
1402 }
1403 else
1404 d2error (57, rd);
1405 if (rd->type == TLABEL && rb->quant.categ == CCPROC)
1406 d2error (82, rd);
1407 break;
1408 case CVAR:
1409 if (rd->type == TREF && (rd->kind == KSIMPLE | rd->kind == KARRAY))
1410 {
1411 rd->categ = CDEFLT;
1412 }
1413 case CNAME:
1414 /* Nameparameter til klasser er ikke lovlig */
1415 /* if (kind == KCLASS)
1416 d2error (58, rd);*/
1417 if (kind == KPROC && rb->quant.categ == CCPROC &&
1418 (rd->type == TTEXT || rd->type == TREF))
1419 d2error (77, rd);
1420 if (rd->type == TVARARGS)
1421 {
1422 if (rd->next != NULL)
1423 d2error (80, rd);
1424 if (kind != KPROC || rb->quant.categ != CCPROC)
1425 d2error (81, rd);
1426 }
1427 if (rd->type == TLABEL && rb->quant.categ == CCPROC)
1428 d2error (82, rd);
1429 break;
1430 case CEXTR:
1431 case CEXTRMAIN:
1432 break;
1433 case CCPROC:
1434 if (rd->type == TREF)
1435 d2error (78, rd);
1436 break;
1437 default:
1438 /* ULOVLIG CATEG */
1439 d2error (59, rd);
1440 }
1441 }
1442 if (rb->quant.kind == KCLASS || rb->quant.kind == KPRBLK)
1443 {
1444 setprotected (rb, FALSE);
1445
1446 /* Kopierer opp de akumulerte virtuelle
1447 * Kjeder disse sammen i en liste hvor
1448 * va peker paa f�rste og vb p� siste */
1449 if (rb->quant.plev > 0)
1450 for (vc = rb->quant.prefqual->descr->virt;
1451 vc != NULL; vc = vc->next)
1452 {
1453 if (va == NULL)
1454 va = vb = newDecl ();
1455 else
1456 vb = vb->next = newDecl ();
1457 makeequal (vb, vc);
1458 vb->encl = rb;
1459 vb->dim = 0;
1460 }
1461 rdx = rb->virt;
1462 if (va != NULL || rb->virt != NULL)
1463 {
1464 /* Hekter de akumulerte inn i listen av virtuelle
1465 * slik at de blir liggende f�rst i lista */
1466 vc = rb->virt;
1467 if (va != NULL)
1468 {
1469 vb->next = rb->virt;
1470 rb->virt = va;
1471 vno = rb->quant.prefqual->descr->navirt;
1472 vnolab = rb->quant.prefqual->descr->navirtlab;
1473 }
1474 else
1475 vno = vnolab = 0;
1476
1477 vb = vc;
1478 for (; vc != NULL; vc = vc->next)
1479 {
1480 /* Sjekker dobbel spesifisering av de nye virtuelle */
1481 for (va = rb->virt; va->ident != vc->ident ||
1482 va->protected == TRUE; va = va->next);
1483 if (va != vc)
1484 {
1485 d2error (60, vc);
1486 while (va->next != vc)
1487 va = va->next;
1488 va->next = vc->next;
1489 vc = va;
1490 }
1491 else
1492 {
1493 /* Sjekker om det er lovlig virtuell */
1494 if (vc->kind != KPROC && vc->type != TLABEL)
1495 {
1496 d2error (61, vc);
1497 vc->type = TERROR;
1498 vc->kind = KERROR;
1499 }
1500 if (vc->kind == KPROC)
1501 vc->virtno = ++vno;
1502 else
1503 vc->virtno = ++vnolab;
1504 vc->dim = 1;
1505 }
1506 }
1507 rb->navirt = vno;
1508 rb->navirtlab = vnolab;
1509 }
1510 }
1511 else
1512 rdx = NULL;
1513
1514 /* Setter opp kvalifikasjoner og prefiks pekere */
1515 rd = rb->parloc;
1516 cblev--;
1517 cblock= cblock->quant.encl;
1518 if (rd != NULL)
1519 rd = setqualprefchain (rd, 1); /* FOR PARAMETERE */
1520 cblev++;
1521 cblock= rb;
1522 if (rdx != NULL)
1523 setqualprefchain (rdx, 0); /* FOR VIRTUELLE */
1524 if (rd != NULL)
1525 setqualprefchain (rd, 0); /* FOR LOKALE */
1526
1527 cblev++;
1528 for (rd = rb->parloc; rd != NULL; rd = rd->next)
1529 /* Sjekker lokal klasse og prosedyre */
1530 if ((rd->kind == KCLASS && rd->match != sjekkdeklcalled)
1531 || (rd->kind == KPROC && (rd->categ == CLOCAL || rd->categ == CCPROC)))
1532 {
1533 cblock = rd->descr;
1534 sjekkdekl (rd->descr);
1535 }
1536 else
1537 /* SJEKKER PROSEDYRE SOM ER OVERF\RT SOM PARAMETER */
1538 if (rd->kind == KPROC & rd->descr != NULL)
1539 {
1540 cblock = rd->descr;
1541 sjekkdekl (rd->descr);
1542 }
1543 for (rd = vb; rd != NULL; rd = rd->next)
1544 /* Sjekker spesifikasjon av virtuell prosedyre */
1545 if (rd->kind == KPROC & rd->descr != NULL)
1546 {
1547 cblock = rd->descr;
1548 sjekkdekl (rd->descr);
1549 }
1550 cblev--;
1551 cblock = rb;
1552 for (vc = rb->virt; vc != NULL; vc = vc->next)
1553 {
1554 if (vc->protected)
1555 continue;
1556 for (va = rb->parloc; va != NULL && va->ident != vc->ident;
1557 va = va->next);
1558 if (va != NULL)
1559 {
1560 if ((vc->type == TERROR && (va->kind == KPROC || va->type == TLABEL))
1561 || (vc->type == TLABEL && va->type == TLABEL
1562 && vc->kind == va->kind)
1563 || (vc->kind == KPROC && va->kind == KPROC && subordinate (va, vc)
1564 && sameParam (vc->descr, va->descr)))
1565 {
1566 vc->match = va;
1567 vc->type = va->type;
1568 vc->prefqual = va->prefqual;
1569 }
1570 else
1571 d2error (62, va);
1572 }
1573 else if (vc->match == vc)
1574 vc->match = NULL;
1575 }
1576 if (rb->quant.kind == KCLASS || rb->quant.kind == KPRBLK)
1577 {
1578 /* Listen av hidden og protected sjekkes og match settes opp */
1579 for (rd = rb->hiprot; rd != NULL; rd = rd->next)
1580 {
1581 rdx = findLocal (rd->ident, &rb->quant, TRUE);
1582 if (rdx->categ == CNEW)
1583 {
1584 d2error (74, rd);
1585 rdx->categ = CERROR;
1586 }
1587 else if (rd->categ != CHIDEN && rdx->encl != rb)
1588 d2error (75, rd);
1589 else if (rd->categ != CHIDEN && rdx->categ == CVIRT)
1590 {
1591 if (rb->quant.plev == 0)
1592 vno = 0;
1593 else if (rdx->kind == KPROC)
1594 vno = rb->quant.prefqual->descr->navirt;
1595 else
1596 vno = rb->quant.prefqual->descr->navirtlab;
1597 if (rdx->virtno <= vno)
1598 d2error (75, rd);
1599 else
1600 rd->match = rdx;
1601 }
1602 else if (rd->categ == CHIDEN && rdx->categ == CVIRT
1603 && rb->quant.plev > 0)
1604 {
1605 for (rdy = rb->quant.prefqual->descr->virt;
1606 rdy->virtno != rdx->virtno || rdy->kind != rdx->kind;
1607 rdy = rdy->next);
1608 rd->match = rdy;
1609 }
1610 else
1611 rd->match = rdx;
1612 }
1613 setprotected (rb, TRUE);
1614 /* Sjekk at de som er hidden ogs� er protected */
1615 for (rd = rb->hiprot; rd != NULL; rd = rd->next)
1616 if (rd->categ == CHIDEN && rd->match != NULL &&
1617 rd->match->protected == FALSE)
1618 d2error (76, rd);
1619 }
1620 }
1621
1622
1623 /*****************************************************************************/
1624 /* HJELP TIL SJEKKEREN */
1625 /*****************************************************************************/
1626
1627 /******************************************************************************
1628 FIRSTCLASS */
1629
1630 struct BLOCK *
firstclass()1631 firstclass ()
1632 { /* Retunerer med blev for den n{rmeste
1633 * klassen eller prefiksblokk sett
1634 * fra cblock */
1635
1636 int i;
1637 struct BLOCK *rb;
1638 i = cblev;
1639 for (rb = cblock; rb->quant.kind != KCLASS && rb->quant.kind != KPRBLK; rb = rb->quant.encl)
1640 if ((rb->quant.kind == KFOR || rb->quant.kind == KINSP
1641 || rb->quant.kind == KCON) &&
1642 rb->quant.match->kind == KCLASS)
1643 return (rb->quant.match->descr);
1644 return (rb);
1645 }
1646
1647
1648 /******************************************************************************
1649 INBLOCK */
1650
1651 /* InBlock kalles fra sjekkeren hver gang en blokk entres */
nextblock()1652 nextblock ()
1653 {
1654 static struct BLOCK *lblock;
1655
1656 if (lblock == NULL)
1657 lblock = ssblock;
1658 else
1659 lblock = lblock->next_block;
1660
1661 while (lblock->quant.categ == CDEFLT /* formell proc.spec */ ||
1662 lblock->quant.categ == CNAME /* formell proc.spec */ ||
1663 lblock->quant.categ == CVAR /* formell proc.spec */ ||
1664 lblock->quant.categ == CVIRT /* virtuell proc.spec */ ||
1665 lblock->quant.categ == CCPROC ||
1666 lblock->timestamp != 0)
1667 lblock = lblock->next_block;
1668 cblock= lblock;
1669 }
1670
inBlock()1671 inBlock ()
1672 {
1673 nextblock ();
1674 cblev = cblock->blev;
1675 if (cblock->quant.kind != KPROC && cblock->quant.kind != KCLASS)
1676 sjekkdekl (cblock);
1677 if (cblock->quant.kind == KCLASS || cblock->quant.kind == KPRBLK)
1678 setprotected (cblock, FALSE);
1679 }
1680
1681 /******************************************************************************
1682 OUTBLOCK */
1683
1684 /* OutBlock kalles fra sjekkeren hver gang en blokk forlates */
1685
outBlock()1686 outBlock ()
1687 {
1688 if (cblock->quant.kind == KCLASS || cblock->quant.kind == KPRBLK)
1689 setprotected (cblock, TRUE);
1690 if (cblock->quant.kind == KCON)
1691 {
1692 cblock->quant.prefqual->descr->when = NULL;
1693 }
1694 if (cblock->quant.kind == KFOR || cblock->quant.kind == KINSP
1695 || cblock->quant.kind == KCON)
1696 cblock = cblock->quant.prefqual->descr;
1697 else
1698 {
1699 cblev--;
1700 cblock = cblock->quant.encl;
1701 }
1702 }
1703
1704 /******************************************************************************
1705 REGWHEN */
1706
1707
1708 regwhen (rb, rd) struct BLOCK *rb; struct DECL *rd;
1709 {
1710 rb->quant.prefqual->descr->when= rd;
1711 }
1712
1713 /******************************************************************************
1714 REGINSP */
1715
1716
1717 reginsp (rb, rd) struct BLOCK *rb; struct DECL *rd;
1718 {
1719 if (rd == NULL)
1720 {
1721 d2error (73, &rb->quant);
1722 rd = findGlobal (tag ("Noqual"), FALSE);
1723 rd->categ = CERROR;
1724 }
1725 rb->virt = rd;
1726 }
1727
1728 /******************************************************************************
1729 REGTHIS */
1730
1731 /* Kalles fra sjekkeren hver gang this oppdages,
1732 * sjekker da lovligheten */
1733
1734 struct DECL *
regThis(ident)1735 regThis (ident)
1736 char *ident;
1737 {
1738 struct DECL *rd,
1739 *rdt,
1740 *rdx;
1741 struct BLOCK *rb;
1742 #ifdef DEBUG
1743 if (option_input)
1744 printf ("regThis---line:%ld cblev:%d\t"
1745 ,lineno, cblev);
1746 #endif
1747 for (rb = cblock; rb->blev > 0; rb= rb->quant.encl) /* Skal det v}re i>=0 .(Omgivelsene) */
1748 {
1749 rd = &rb->quant;
1750 do
1751 {
1752 rdx = rd;
1753 if (rd->kind == KINSP)
1754 {
1755 seenthrough = rd->descr;
1756 rd = rd->descr->when;
1757 }
1758 else
1759 seenthrough = NULL;
1760 if (rd->kind == KCLASS)
1761 {
1762 do
1763 if (rd->ident == ident)
1764 {
1765 if (rd->descr->thisused == MAYBEE)
1766 d2error (72, rd);
1767 rd->descr->thisused |= TRUE;
1768 #ifdef DEBUG
1769 if (option_input)
1770 printf ("---end\n");
1771 #endif
1772 if (rd->descr->blev == cblock->blev)
1773 localused = TRUE;
1774 return (rd);
1775 }
1776 while (rd = (rdt = rd)->prefqual, rdt->plev > 0);
1777 }
1778 rd = rdx->prefqual;
1779 }
1780 while (rdx->kind == KCON || rdx->kind == KINSP || rdx->kind == KFOR);
1781
1782 }
1783 #ifdef DEBUG
1784 if (option_input)
1785 printf ("---end\n");
1786 #endif
1787 d2error (79, rd = findGlobal (ident, FALSE));
1788 return (rd);
1789 }
1790
1791 /******************************************************************************
1792 FINDLOCAL */
1793
1794 /* FindLocal finner den deklarasjonen som svarer til et navn
1795 * Den leter lokalt i den lista den har f�t og dens prefikskjede
1796 * Har den ikke f�t noen liste leter den slik findGlobal gj�r
1797 * Den registrerer ogs� localused
1798 * Hvis virt==TRUE skal det f�rst letes i evt. virtuell liste */
1799
1800 struct DECL *
findLocal(ident,rd,virt)1801 findLocal (ident, rd, virt)
1802 char *ident;
1803 struct DECL *rd;
1804 char virt;
1805 {
1806 seenthrough = NULL;
1807 if (rd != NULL && rd->descr != NULL)
1808 rd = findDecl (ident, rd->descr, virt);
1809 else
1810 return (findGlobal (ident, virt));
1811 if (rd != NULL)
1812 return (rd);
1813 for (rd = unknowns->parloc; rd != NULL; rd = rd->next)
1814 if (rd->ident == ident)
1815 return (rd);
1816 return (newnotseen (ident));
1817 }
1818
1819 /******************************************************************************
1820 NEXTPARAM & FIRSTPARAM */
1821
1822 /* To prosedyrer for � finne parameterene
1823 * til en prosedyre eller klasse
1824 * F�r som input forrige parameter */
1825
1826 struct DECL *
nextParam(rd)1827 nextParam (rd)
1828 struct DECL *rd;
1829 {
1830 struct DECL *rdx;
1831 int plev;
1832 if (rd == NULL)
1833 return (NULL);
1834 if (rd->type == TVARARGS)
1835 return (rd);
1836 if (rd->next != NULL)
1837 {
1838 rd = rd->next;
1839 if (rd == arrayparam && rd->dim != USPECDIM)
1840 rd->dim--;
1841 if (rd->categ == CDEFLT || rd->categ == CVALUE ||
1842 rd->categ == CNAME || rd->categ == CVAR || rd->type == TVARARGS)
1843 return (rd);
1844 }
1845 if (rd->encl->quant.kind == KCLASS)
1846 {
1847 for (rd= ppop (); rd!= NULL; rd= ppop ())
1848 if ((rdx = rd->descr->parloc) != NULL &&
1849 (rdx->categ == CDEFLT || rdx->categ == CVALUE
1850 || rdx->categ == CNAME || rdx->categ == CVAR))
1851 return (rdx);
1852 }
1853 return (sluttparam);
1854 }
1855
1856 static struct DECL *
firstclassparam(rd)1857 firstclassparam (rd)
1858 struct DECL *rd;
1859 {
1860 struct DECL *rdx,
1861 *rdy;
1862 if (rd->plev > 0)
1863 {
1864 ppush (rd);
1865 rdy = firstclassparam (rd->prefqual);
1866 }
1867 else
1868 rdy = sluttparam;
1869 if (rdy == sluttparam)
1870 {
1871 if ((rdx = rd->descr->parloc) != NULL &&
1872 (rdx->categ == CDEFLT || rdx->categ == CVALUE
1873 || rdx->categ == CNAME || rdx->categ == CVAR))
1874 return (rdx);
1875 ppop ();
1876 }
1877 return (rdy);
1878 }
1879
1880
1881
1882 struct DECL *
firstParam(rd)1883 firstParam (rd)
1884 struct DECL *rd;
1885 {
1886 struct DECL *rdx;
1887 if (rd->kind == KCLASS)
1888 {
1889 pclean ();
1890 return (firstclassparam (rd));
1891 }
1892 if (rd->kind == KARRAY)
1893 {
1894 if (rd->type == TLABEL)
1895 return (switchparam);
1896 if (rd->dim)
1897 arrayparam->dim = rd->dim;
1898 else
1899 arrayparam->dim = USPECDIM;
1900 return (arrayparam);
1901 }
1902 /* else Kommentertut p.g.a full spesifisering
1903 * av parametere til formelle prosedyrer.
1904 * if(rd->kind==KPROC && rd->categ==CDEFLT) {
1905 * return(procparam); } */
1906
1907 if (rd->descr == NULL)
1908 return (sluttparam);
1909 if ((rdx = rd->descr->parloc) != NULL &&
1910 (rdx->categ == CDEFLT || rdx->categ == CVALUE
1911 || rdx->categ == CNAME || rdx->categ == CVAR
1912 || rdx->type == TVARARGS))
1913 return (rdx);
1914 return (sluttparam);
1915 }
1916
1917 /******************************************************************************
1918 MOREPARAM */
1919
1920 /* Forlanges det flere parametere */
1921
1922 moreParam (rd)
1923 struct DECL *rd;
1924 {
1925 if (rd == sluttparam)
1926 return (FALSE);
1927 if (rd == switchparam->next)
1928 return (FALSE);
1929 if (rd == NULL)
1930 return (FALSE);
1931 if (rd->type == TVARARGS)
1932 return (MAYBEE);
1933 if (rd == arrayparam)
1934 {
1935 if (rd->dim == USPECDIM)
1936 return (MAYBEE);
1937 if (rd->dim > 0)
1938 return (TRUE);
1939 return (FALSE);
1940 }
1941 /* er kommenter ut siden formelle procedyrer er fullt ut spesifisert
1942 * if(rd==procparam)return(MAYBEE); */
1943 return (TRUE);
1944 }
1945
1946
1947 /******************************************************************************
1948 NOTBODY */
1949
1950 /* Er vi inne i en prosedyre kropp */
1951
1952 body (rd)
1953 struct DECL *rd;
1954 {
1955 struct BLOCK *rb, *rbx;
1956 rbx = cblock;
1957 rb = rd->descr;
1958 for (rbx= cblock; rbx->blev > 0; rbx= rbx->quant.encl)
1959 {
1960 /* Hvis vi er inne i en inspect blokk eller for blokk */
1961 /* m} match f|lges for } f} riktig blokk. KAN BARE */
1962 /* BRUKES FOR ] UNDERS\KE OM MAN ER INNE I EN PROSEDYRE */
1963 if (rbx->quant.kind == KCON || rbx->quant.kind == KFOR)
1964 rbx= rbx->quant.match->descr;
1965 if (rbx == rb)
1966 return (TRUE);
1967 }
1968 return (FALSE);
1969 }
1970
1971 /******************************************************************************
1972 DANGERPROC */
1973
1974 /* Er prosedyren farlig og m] isoleres i uttrykk */
1975
1976 char
dangerProc(rd)1977 dangerProc (rd)
1978 struct DECL *rd;
1979 {
1980 switch (rd->descr->codeclass)
1981 {
1982 case CCCPROC:
1983 return (rd->type == TTEXT);
1984 case CCFILEDANGER:
1985 case CCTEXTDANGER:
1986 case CCRANDOMRUTDANGER:
1987 case CCBLANKSCOPY:
1988 case CCFILEBLANKSCOPY:
1989 case CCSIMPLEDANGER:
1990 case CCNO:
1991 return (TRUE);
1992 }
1993 return (FALSE);
1994 }
1995
1996 /*****************************************************************************
1997 REMOVEBLOCK */
1998
1999 removeBlock (rb) struct BLOCK *rb;
2000 {
2001 struct DECL *rd;
2002 if (rb->quant.encl->parloc->descr == rb)
2003 rb->quant.encl->parloc= rb->quant.encl->parloc->next;
2004 else
2005 {
2006 for (rd= rb->quant.encl->parloc; rd->next->descr != rb; rd= rd->next);
2007 rd->next= rd->next->next;
2008 }
2009 }
2010