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