/* $Id: cdekl.c,v 1.10 1997/01/08 09:49:13 cim Exp $ */
/* Copyright (C) 1994, 1998 Sverre Hvammen Johansen,
* Department of Informatics, University of Oslo.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; version 2.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
/* Deklarasjonslager for Simula */
#include "const.h"
#include "dekl.h"
#include "const.h"
#include "lex.h"
#include "name.h"
#include <stdio.h>
#include <obstack.h>
char *xmalloc();
void free();
#define obstack_chunk_alloc xmalloc
#define obstack_chunk_free free
static struct obstack osDecl;
static struct obstack osPref;
/*****************************************************************************/
/* INITIELT */
/*****************************************************************************/
/* KONTAKT MED YACC, LEX OG FEILSYSTEMET */
/* Bruker bufferet til lex da det garantert er stort nokk
* Dette blir brukt i det tilfellet at det m} lages en ny tag
* for identen til en parameter som har navnkonflikt med en lokal variabel */
char yaccerror;
char *prefquantident;
int localused;
int arrdim;
struct BLOCK *ssblock; /* First system block
(The outermost system block with blev=0)
the system environment is conected to this block */
struct BLOCK *cblock; /* Current block */
struct BLOCK *sblock; /* First non system block
(The outermost block with blev=1)
sblock is connected with ssblock through
two INSP blocks (sysin and sysout) */
struct BLOCK *seenthrough; /* Settes av findGlobal og findLocal og peker
* p} en utenforliggende inspect blokk(hvis
* den finnes). Det er fordi jeg onsker
* } vite n}r en variable er sett gjennom
* inspect. Trenger denne informasjon i
* kode genereringen for } aksessere
* variable fra den inspiserte klassen
* gjennom inspect variabelen */
struct DECL *classtext;
int cblev;
struct DECL *cprevdecl;
/* Har en peker som peker p} en array deklarasjon som ikke har f}tt
* satt sin dim verdi. */
struct DECL *lastArray;
/* Under sjekkingen og innlesingen av deklarasjonene
* trenger jeg å merke de ulike objektene
* Lar atributter peke paa ulike objekter for merkeingen */
static struct DECL *sjekkdeklcalled;
static struct DECL *lastunknowns;
static struct BLOCK *unknowns;
struct DECL *commonprefiks; /* Felles prefiks til alle ikke prefiksede
* klasser Inneholder prosedyren DETACH */
static struct DECL *switchparam;
static struct DECL *procparam;
static struct DECL *sluttparam;
static struct DECL *arrayparam;
/******************************************************************************
PCLEAN, PPUSH and PPOP */
static ppush(rd)struct DECL *rd;
{
#if 0
obstack_ptr_grow (&osPref, rd);
#else
obstack_grow(&osPref, &rd, sizeof (void *));
#endif
}
static pclean()
{
void *p;
p= obstack_finish (&osPref);
obstack_free (&osPref, p);
}
static struct DECL *ppop()
{
struct DECL *rd;
if (obstack_next_free (&osPref) == obstack_base (&osPref))
return (NULL);
rd= * ((struct DECL * *) obstack_next_free (&osPref) - 1);
obstack_blank (&osPref, - sizeof (void *));
return (rd);
}
/******************************************************************************
NEW-DECL/BLOCK */
struct DECL *newDecl()
{
struct DECL *rd;
rd= (struct DECL *) obstack_alloc (&osDecl, sizeof (struct DECL));
memset (rd, 0, sizeof (struct DECL));
return rd;
}
static struct BLOCK *newBlock()
{
struct BLOCK *rb;
rb= (struct BLOCK *)obstack_alloc (&osDecl, sizeof (struct BLOCK));
memset (rb, 0, sizeof (struct BLOCK));
rb->quant.descr = rb;
return rb;
}
/******************************************************************************
INITDECL */
/* InitDecl kalles før selve innlesingen */
initDecl ()
{
struct BLOCK *rb;
struct DECL *rd;
obstack_init(&osDecl);
obstack_init(&osPref);
cblev= -1;
sjekkdeklcalled = newDecl ();
unknowns = newBlock ();
unknowns->quant.kind = KERROR;
beginBlock (KBLOKK);
ssblock=cblock;
/* ssblock->quant.encl= ssblock; Dersom denne er med går kompilatoren inn
i en evig løkke dersom det er noe som er udeklarert. Er ikke sikker
på om å bare kommentere det ut er riktig løsning */
lesinn_external_spec (tag ("TEXTOBJ*"), "simenvir");
commonprefiks = findGlobal (tag ("COMMON*"), TRUE);
commonprefiks->plev = -1;
classtext = findGlobal (tag ("TEXTOBJ*"), TRUE);
beginBlock (KINSP);
beginBlock (KINSP);
rd = findGlobal (tag ("MAXLONGREAL"), TRUE);
rd->value.rval = MAX_DOUBLE;
rd = findGlobal (tag ("MINLONGREAL"), TRUE);
rd->value.rval = -MAX_DOUBLE;
rd = findGlobal (tag ("MAXREAL"), TRUE);
rd->value.rval = MAX_DOUBLE;
rd = findGlobal (tag ("MINREAL"), TRUE);
rd->value.rval = -MAX_DOUBLE;
rd = findGlobal (tag ("MAXRANK"), TRUE);
rd->value.ival = MAXRANK;
rd = findGlobal (tag ("MAXINT"), TRUE);
rd->value.ival = MAX_INT;
rd = findGlobal (tag ("MININT"), TRUE);
rd->value.ival = -MAX_INT - 1;
}
/******************************************************************************
REINIT */
/* Reinit kalles før sjekkingen starter */
reinit ()
{
struct DECL *rd;
endBlock (NULL,CCNO);
endBlock (NULL,CCNO);
endBlock (NULL,CCNO);
/* M} gj|re et hack for } f} satt kvalifikasjon p} inspect sysin */
/* og inspect sysout, da neste blokk ikke er en connection blokk */
inBlock ();
inBlock (findGlobal (tag ("INFILE"), TRUE));
cblock->when = findGlobal (tag ("INFILE"), TRUE);
inBlock (findGlobal (tag ("PRINTFILE"), TRUE));
cblock->when = findGlobal (tag ("PRINTFILE"), TRUE);
sblock = cblock = cblock->next_block;
switchparam = newDecl ();
switchparam->type = TINTG;
switchparam->kind = KSIMPLE;
switchparam->categ = CDEFLT;
switchparam->encl = unknowns;
switchparam->next = newDecl ();
switchparam->next->type = TINTG;
switchparam->next->kind = KSIMPLE;
switchparam->next->categ = CDEFLT;
switchparam->next->encl = unknowns;
switchparam->next->next = switchparam->next;
procparam = newDecl ();
procparam->type = TERROR;
procparam->kind = TERROR;
procparam->categ = CNAME;
procparam->encl = unknowns;
procparam->next = procparam;
sluttparam = newDecl ();
sluttparam->encl = unknowns;
sluttparam->next = sluttparam;
arrayparam = newDecl ();
arrayparam->type = TINTG;
arrayparam->kind = KSIMPLE;
arrayparam->categ = CDEFLT;
arrayparam->encl = unknowns;
arrayparam->next = arrayparam;
}
/*****************************************************************************/
/* HJELPE-PROSEDYRER */
/*****************************************************************************/
/******************************************************************************
SETARRAYDIM */
/* LastArray peker på første array i siste arraydeklarasjon og setArrayDim
* settes disse arrayenes dimensjon (dim). Så lengde next også er en array
* skal også denne ha dimmensjonen arrdim.( integer array a,b(...); */
setArrayDim (arrdim) int arrdim;
{
while (lastArray != NULL)
{
lastArray->dim = arrdim;
lastArray = (lastArray->next == NULL ? NULL :
(lastArray->next->kind == KARRAY ? lastArray->next : NULL));
}
arrdim = 0;
}
/******************************************************************************
NEWNOTSEEN */
/* Newnotseen kalles hver gang det er noe udeklarert
* Den legger alle disse inn i en liste med de ukjente */
static struct DECL *
newnotseen (ident)
char *ident;
{
if (lastunknowns == NULL)
unknowns->parloc = lastunknowns = newDecl ();
else
lastunknowns = lastunknowns->next = newDecl ();
lastunknowns->ident = ident;
lastunknowns->type = TERROR;
lastunknowns->kind = KERROR;
lastunknowns->categ = CNEW;
lastunknowns->dim = 1;
lastunknowns->encl = unknowns;
lastunknowns->descr = unknowns;
return (lastunknowns);
}
/******************************************************************************
FINDDECL */
/* FindDecl leter etter deklarasjonen ident lokalt i blokken og langs
* den prefikskjede.Den kalles rekursivt for hvert BLOCK objekt langs
* prefikskjeden.Ved en inspect blokk kalles den for den ispiserte
* klassen og dens prefikser.Finnes den returneres en peker til
* deklarasjonspakka, hvis ikke returneres NULL
* HVIS virt==TRUE skal det først letes i evt. virtuell liste */
struct DECL *
findDecl (ident, rb, virt)
char *ident;
struct BLOCK *rb;
char virt;
{
struct DECL *rd;
if ((rb->quant.kind == KINSP) && (rb->when != NULL))
{
seenthrough = rb;
if ((rd = findDecl (ident, rb->when->descr, virt)) != NULL
&& rd->type != TLABEL)
return (rd);
seenthrough = NULL;
}
else
{
if (virt && rb->quant.kind == KCLASS)
for (rd = rb->virt; rd != NULL; rd = rd->next)
if (rd->ident == ident && rd->protected == FALSE)
return (rd);
for (rd = rb->parloc; rd != NULL; rd = rd->next)
if (rd->ident == ident && rd->protected == FALSE)
return (rd);
}
/* Går også gjennom prefikskjeden */
if (rb->quant.kind == KCLASS || rb->quant.kind == KINSP || rb->quant.kind == KPRBLK
|| rb->quant.kind == KFOR || rb->quant.kind == KCON)
if (rb->quant.plev > -1 && rb->quant.prefqual != NULL)
if ((rd = findDecl (ident, rb->quant.prefqual->descr,
rb->quant.kind == KCLASS | rb->quant.kind == KPRBLK ? FALSE : virt)) != NULL)
return (rd);
return (NULL);
}
/******************************************************************************
FINDGLOBAL */
/* FindGlobal finner den deklarasjonen som svarer til et navn
* Den leter for hvert blokknivaa, i prefikskjeden og lokalt
* Stopper ved f\rste forekomst, fins den ikke kalles newnotseen
* Hvis virt==true skal det først letes i evt. virtuell liste */
struct DECL *
findGlobal (ident, virt)
char *ident;
char virt;
{
struct DECL *rd;
struct BLOCK *rb;
seenthrough = NULL;
for (rb= cblock; rb; rb= rb->quant.encl)
if ((rd= findDecl (ident, rb, virt)) != NULL)
{
if (rd->encl->blev == cblock->blev &&
(rd->categ == CLOCAL || rd->categ == CVIRT))
localused = TRUE;
return (rd);
}
for (rd = unknowns->parloc; rd != NULL; rd = rd->next)
if (rd->ident == ident)
return (rd);
return (newnotseen (ident));
}
/******************************************************************************
SAMEPARAM */
/* Sjekker om parameterene er de samme */
sameParam (rb1, rb2)
struct BLOCK *rb1,
*rb2;
{
struct DECL *rd1,
*rd2;
int i;
if (rb1 == NULL || rb2 == NULL)
return (FALSE);
if (rb1->quant.kind != KPROC || rb2->quant.kind != KPROC)
return (FALSE);
if (rb1->napar != rb2->napar)
return (FALSE);
rd1 = rb1->parloc;
rd2 = rb2->parloc;
for (i = 1; i <= rb1->napar; i++)
{
if (rd1->type != rd2->type && rd1->type != TNOTY)
return (FALSE);
if (rd1->kind != rd2->kind)
return (FALSE);
if (rd1->categ != rd2->categ)
return (FALSE);
if (rd1->prefqual != rd2->prefqual && rd1->type !=TNOTY)
{
if (subclass (rd2->prefqual, rd1->prefqual))
{
if (rd1->categ == CNAME) return (FALSE);
if (rd1->kind == KPROC) return (FALSE);
} else
if (subclass (rd1->prefqual, rd2->prefqual)) ;
else return (FALSE);
}
if (rd1->kind == KPROC &&
sameParam (rd2->descr, rd1->descr) == FALSE)
return (FALSE);
rd1 = rd1->next;
rd2 = rd2->next;
}
return (TRUE);
}
/******************************************************************************
MAKEEQUAL */
/* Gjør rd1 lik rd2 ved å kopiere atributter */
static makeequal (rd1, rd2)
struct DECL *rd1,
*rd2;
{
rd1->ident = rd2->ident;
rd1->line = rd2->line;
rd1->plev = rd2->plev;
rd1->identqual = rd2->identqual;
rd1->dim = rd2->dim;
rd1->virtno = rd2->virtno;
rd1->type = rd2->type;
rd1->kind = rd2->kind;
rd1->categ = rd2->categ;
rd1->encl = rd2->encl;
rd1->descr = rd2->descr;
rd1->match = rd2->match;
rd1->next = NULL;
rd1->prefqual = rd2->prefqual;
rd1->protected = rd2->protected;
}
/******************************************************************************
COMMONQUAL */
/* Finner felles kvalifikasjon for to klasser
* NULL hviss ingen slik finnes */
struct DECL *
commonqual (rdx, rdy)
struct DECL *rdx,
*rdy;
{ /* Hvis rdx eller rdy peker på
* commonprefiks (som har plev=-1) s} vil
* den leveres som felles kvalifikasjon, som
* er ønskelig i den situasjonen. Men hvis
* ikke en av dem peker dit så vil IKKE
* commonprefiks være felles kvalifikasjon.
* Dette betyr at det ikke er nødvendig
* med spesialbehandling for parametere til
* call, resume. Hvis rdx eller rdy er lik
* NULL, returneres den andre. */
if (rdx == NULL) return (rdy);
if (rdy == NULL) return (rdx);
if (rdx == rdy) return (rdx);
while (rdx != NULL && rdx->plev > rdy->plev)
rdx = rdx->prefqual;
if(rdx == NULL) return(rdy);
while (rdy != NULL && rdy->plev > rdx->plev)
rdy = rdy->prefqual;
while (rdx != rdy && rdx!=NULL && rdy != NULL && rdx->plev > 0)
{
rdx = rdx->prefqual;
rdy = rdy->prefqual;
}
return (rdx == rdy ? rdx : NULL);
}
/******************************************************************************
SUBCLASS */
/* Er rdx en subklasse til rdy, returnerer TRUE eller FALSE */
char
subclass (rdx, rdy)
struct DECL *rdx,
*rdy;
{
if (rdx == rdy)
return (TRUE);
if (rdx == NULL || rdy == NULL) return(FALSE);
if (rdx->plev < rdy->plev)
return (0);
while (rdx != NULL && rdx->plev > rdy->plev)
rdx = rdx->prefqual;
return (rdx == rdy);
}
/******************************************************************************
SUBORDINATE */
char
subordinate (rda, rdb)
struct DECL *rda,
*rdb;
{
return ((rda->type != TREF && rda->type == rdb->type)
|| rdb->type == TNOTY || (rda->type == TREF && rdb->type == TREF
&& subclass (rda->prefqual, rdb->prefqual)));
}
/*****************************************************************************/
/* INNLESING */
/*****************************************************************************/
/******************************************************************************
BEGINBLOCK */
/* Kalles fra syntakssjekkeren hver gang en ny blokk entres */
beginBlock (kind)
char kind;
{
static int cblno = STARTBLNO;
static struct BLOCK *lblock;
struct DECL *rd2;
if (yaccerror)
return;
#ifdef DEBUG
if (option_input)
printf (
"beginBlock---line:%ld type:%c kind:%c categ:%c\t"
,lineno, type, kind, categ);
#endif
{
struct BLOCK *lastcblock= cblock;
if (kind == KPROC || kind == KCLASS)
{
cblock = (struct BLOCK *) cprevdecl;
cprevdecl->match = cprevdecl;
}
else
{
cblock = newBlock ();
cblock->quant.line = lineno;
cblock->quant.kind = kind;
#if 1
if (lastcblock != NULL)
{
if (lastcblock->lastparloc == NULL)
cprevdecl= lastcblock->parloc=lastcblock->lastparloc=
&cblock->quant;
else
cprevdecl= lastcblock->lastparloc=
lastcblock->lastparloc->next= &cblock->quant;
cblock->quant.type= TNOTY;
cblock->quant.categ= CLOCAL;
}
#endif
}
cblock->quant.encl= lastcblock;
}
if (lblock != NULL)
lblock = lblock->next_block = cblock;
else
lblock = cblock;
cblock->blno = cblno++;
switch (kind)
{
case KPROC:
case KCLASS:
cblev++;
if (staticblock && cblock->quant.categ == CLOCAL)
cblock->stat = TRUE;
break;
case KFOR:
case KINSP:
case KCON:
cblock->quant.ident = NULL;
/* cblock->quant.encl = NULL;*/
cblock->quant.descr = cblock;
rd2 = &cblock->quant.encl->quant;
cblock->quant.prefqual = rd2;
cblock->quant.plev = rd2->plev + 1;
if (rd2->kind != KCON && rd2->kind != KINSP &&
rd2->kind != KFOR)
cblock->quant.match = rd2;
else
cblock->quant.match = rd2->match;
switch (cblock->quant.prefqual->kind)
{
case KFOR:
case KCON:
case KINSP:
cblock->fornest= cblock->quant.prefqual->descr->fornest;
cblock->connest= cblock->quant.prefqual->descr->connest;
break;
}
switch (kind)
{
case KFOR:
cblock->fornest+= 1;
if (cblock->quant.match->descr->fornest < cblock->fornest)
cblock->quant.match->descr->fornest++;
break;
case KINSP:
cblock->connest+= 1;
if (cblock->quant.match->descr->connest < cblock->connest)
cblock->quant.match->descr->connest++;
break;
}
if (staticblock)
cblock->stat = TRUE;
break;
case KPRBLK:
cblev++;
/* cblock->quant.ident= tag ("blokk");*/
cblock->quant.descr= cblock;
cblock->quant.identqual= prefquantident;
if (staticblock)
cblock->stat= TRUE;
break;
default:
cblev++;
if (staticblock)
cblock->stat = TRUE;
break;
}
cblock->blev = cblev;
#ifdef DEBUG
if (option_input)
printf ("---end\n");
#endif
}
/******************************************************************************
ENDBLOCK */
/* Kalles fra syntakssjekkeren hver gang en blokk terminerer */
/*VARARGS0 */
endBlock (rtname, codeclass)
char *rtname;
char codeclass;
{
#ifdef DEBUG
if (option_input)
printf ("endBlock---line:%ld type:%c kind:%c categ:%c\t"
,lineno, type, kind, categ);
#endif
if (yaccerror)
return;
switch (cblock->quant.kind)
{
case KFOR:
case KINSP:
case KCON:
break;
default:
if (codeclass)
{
cblock->rtname = rtname;
cblock->codeclass = codeclass;
}
cblev--;
}
cblock = cblock->quant.encl;
#ifdef DEBUG
if (option_input)
printf ("---end\n");
#endif
}
/******************************************************************************
REGDECL */
/* RegDecl kalles fra syntakssjekkeren
* hver gang vi leser en deklarasjon */
regDecl (ident, type, kind, categ)
char *ident, type, kind, categ;
{
struct DECL *pd,
*pdx = NULL;
#ifdef DEBUG
if (option_input)
printf ("regDecl---line:%ld navn:%s type:%c kind:%c categ:%c\n"
,lineno, ident, type, kind, categ);
#endif
if (yaccerror)
return;
switch (categ)
{
case CVALUE:
case CNAME:
case CVAR: /* Denne er kun satt for eksterne moduler */
if (kind == KNOKD)
{
for (pd = cblock->parloc;
pd != NULL && pd->ident != ident; pd = pd->next);
if (pd != NULL || type != TVARARGS)
{
cprevdecl = pd;
if (pd == NULL)
d1error (34, ident);
else
{
if (pd->categ != CDEFLT)
d1error (35, ident);
pd->categ = categ;
if (categ == CNAME && nameasvar == ON)
pd->categ = CVAR;
}
break;
}
}
case CDEFLT:
cblock->napar++;
case CLOCAL:
case CCONSTU:
case CCONST:
case CEXTR:
case CEXTRMAIN:
case CCPROC:
proceed:
if (kind == KCLASS || kind == KPROC)
{
pd = (struct DECL *) newBlock ();
}
else
{
pd = newDecl ();
}
if (cblock->lastparloc == NULL)
cprevdecl = cblock->parloc = cblock->lastparloc = pd;
else
cprevdecl = cblock->lastparloc = cblock->lastparloc->next = pd;
cblock->lastparloc->ident = ident;
cblock->lastparloc->line = lineno;
cblock->lastparloc->type = type;
cblock->lastparloc->kind = kind;
cblock->lastparloc->categ = categ;
if (categ == CNAME && nameasvar == ON)
cblock->lastparloc->categ = CVAR;
cblock->lastparloc->encl = cblock;
if ((type == TREF || kind == KCLASS)
&& (categ == CLOCAL || categ == CEXTR /* ||
* categ==CEXTRMAIN */
|| categ == CCPROC || categ == CDEFLT
|| (categ == CVALUE || categ == CNAME
|| categ == CVAR) && kind != KNOKD))
{
if (kind == KCLASS && cblock->quant.kind == KCLASS)
cblock->localclasses = TRUE;
cblock->lastparloc->identqual = prefquantident;
}
break;
case CSPEC:
for (pd = cblock->parloc; pd != NULL && pd->ident != ident; pd = pd->next)
pdx = pd;
cprevdecl = pd;
if (pd == NULL)
d1error (34, ident);
else
{
if (pd->kind != KNOKD)
d1error (36, ident);
pd->type = type;
pd->kind = kind;
if (type == TREF)
{
pd->identqual = prefquantident;
}
if (kind == KPROC)
{
/* Bytter ut dette objektet med et st|rre */
cprevdecl = &newBlock ()->quant;
if (cblock->lastparloc == pd)
cblock->lastparloc = cprevdecl;
makeequal (cprevdecl, pd);
cprevdecl->descr = (struct BLOCK *) cprevdecl;
cprevdecl->next = pd->next;
if (pdx == NULL)
cblock->parloc = cprevdecl;
else
pdx->next = cprevdecl;
}
}
break;
case CHIDEN:
case CPROT:
case CHIPRO:
pd = cblock->hiprot;
if (pd != NULL)
while (pd->next != NULL && pd->ident != ident)
pd = pd->next;
if (pd != NULL && pd->ident == ident)
{
if (pd->categ != categ && pd->categ != CHIPRO
&& categ != CHIPRO)
pd->categ = CHIPRO;
else
{
d1error (41, ident);
if (categ == CHIPRO)
pd->categ = CHIPRO;
}
cprevdecl = pd;
}
else
{
if (pd == NULL)
cblock->hiprot = pd = newDecl ();
else
pd = pd->next = newDecl ();
pd->ident = ident;
pd->line = lineno;
pd->type = TNOTY;
pd->kind = KNOKD;
pd->categ = categ;
pd->encl = cblock;
}
break;
case CVIRT:
if (kind == KCLASS || kind == KPROC)
{
pd = (struct DECL *) newBlock ();
}
else
{
pd = newDecl ();
}
if (cblock->lastvirt == NULL)
cblock->virt = pd = cblock->lastvirt= pd;
else
pd = cblock->lastvirt = cblock->lastvirt->next = pd;
cprevdecl = pd;
pd->ident = ident;
pd->line = lineno;
pd->type = type;
pd->kind = kind;
pd->categ = categ;
pd->encl = cblock;
if (type == TREF)
{
pd->identqual = prefquantident;
}
break;
default:
d1error (37);
break;
}
#ifdef DEBUG
if (option_input)
printf ("---end\n");
#endif
}
/******************************************************************************
REGINNER */
/* Kalles fra syntakssjekkeren hver gang
* inner oppdages, sjekker da lovligheten */
regInner ()
{
#ifdef DEBUG
if (option_input)
printf ("regInner---line:%ld cblev:%d\t"
,lineno, cblev);
#endif
if (cblock->quant.kind != KCLASS)
d1error (38);
else
{
if (cblock->inner)
d1error (39);
else
cblock->inner = TRUE;
}
#ifdef DEBUG
if (option_input)
printf ("---end\n");
#endif
}
/*****************************************************************************/
/* SJEKKING AV DEKLARASJONER */
/*****************************************************************************/
/******************************************************************************
DUMPDEKL */
/* Dumpdekl skriver ut tilstanden til en deklarasjon
* brukes ved uttesting av kompilatoren */
#ifdef DEBUG
static dumpdekl (rd)
struct DECL *rd;
{
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);
if (rd->protected == TRUE)
printf (" PROTECTED");
printf ("\n");
if (rd->descr != NULL)
printf (" Blokk:(%d,%d)\n", rd->descr->blno, rd->descr->blev);
if (rd->match != NULL && rd->categ == CVIRT)
{
if (rd->match != rd)
{
if (rd->kind == KPROC)
printf (" match:Blokk(%d,%d) navn:%s\n",
rd->match->descr->blno, rd->match->descr->blev,
rd->match->ident);
else
printf (" match:%s i Blokk(%d,%d)\n",
rd->match->ident, rd->match->encl->blno, rd->match->encl->blev);
}
else
printf (" match:INGEN MATCH\n");
}
else if (rd->match == NULL && rd->categ == CVIRT)
printf (" match:INGEN MATCH\n");
if (rd->prefqual != NULL && rd->type == TREF)
printf (" kvalifikasjon:%s\n", rd->prefqual->ident);
if (rd->descr != NULL && (rd->categ == CDEFLT || rd->categ == CVIRT))
{
if (rd->categ == CVIRT)
{
printf (" Virtuell spec:\n");
printf (">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n");
dumpblock (rd->descr);
printf ("<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n");
}
else
{
printf (" Formell procedure spec:\n");
printf (">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>\n");
dumpblock (rd->descr);
printf ("<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<\n");
}
}
}
/******************************************************************************
DUMPBLOCK */
/* Dumpblock skriver ut tilstanden til en blokk
* Den gjør i sin tur en rekke kall paa dumpdekl */
static dumpblock (rb)
struct BLOCK *rb;
{
struct DECL *rd;
printf
("->BLOCK:(%d,%d) k:%c, np:%d, nv:%d, nvl:%d, f:%d, c:%d, l:%ld, ",
rb->blno, rb->blev, rb->quant.kind,
rb->napar, rb->navirt, rb->navirtlab, rb->fornest,
rb->connest, rb->quant.line);
if (rb->localclasses)
printf ("l:YES ");
else
printf ("l:NO ");
if (rb->thisused)
printf ("t:YES ");
else
printf ("t:NO ");
printf ("\n");
if (rb->quant.categ == CEXTR || rb->quant.categ == CEXTRMAIN)
{
if (rb->quant.kind == KCLASS)
printf (" Extern klasse %s timestampandfilename:%s %s\n",
rb->quant.ident, rb->timestamp, rb->filename);
else
printf (" Extern prosedyre %s timestampandfilename:%s %s\n",
rb->quant.ident, rb->timestamp, rb->filename);
}
else if (rb->quant.categ == CCPROC)
printf (" C-Prosedyre %s\n", rb->rtname);
if (rb->timestamp != 0)
printf (" I extern modul : timestampandfilename:%s %s\n",
rb->timestamp, rb->filename);
printf (" quant:%s plev:%d\n",
rb->quant.ident, rb->quant.plev);
if (rb->quant.prefqual != NULL)
{
printf (" Prefikskjeden:\n");
for (rd = rb->quant.prefqual; rd != NULL; rd = rd->prefqual)
{
printf (" Blokk:(%d,%d) ", rd->descr->blno,
rd->descr->blev);
if (rd->ident != 0)
printf (" navn : %s\n", rd->ident);
else
printf ("\n");
}
}
if (rb->parloc != NULL && rb->parloc->encl != rb)
{
}
else if (rb->parloc != NULL)
{
printf (" Parametere:\n");
for (rd = rb->parloc; rd != NULL &&
(rd->categ == CDEFLT || rd->categ == CVALUE ||
rd->categ == CNAME || rd->categ == CVAR);
rd = rd->next)
dumpdekl (rd);
printf (" Deklarasjoner:\n");
for (; rd != NULL; rd = rd->next)
dumpdekl (rd);
}
if (rb->virt != NULL && rb->virt->encl != rb)
{
}
else if (rb->virt != NULL)
{
printf (" Virtuelle:\n");
for (rd = rb->virt; rd != NULL; rd = rd->next)
dumpdekl (rd);
}
if (rb->hiprot != NULL && rb->hiprot->encl != rb)
{
}
else if (rb->hiprot != NULL)
{
printf (" Hidden/Protected:\n");
for (rd = rb->hiprot; rd != NULL; rd = rd->next)
dumpdekl (rd);
}
printf ("\n");
}
/******************************************************************************
DUMP */
/* Dump skriver ut tilstanden til hele strukturen
* Den gjør et kall på dumpblock for hver blokk */
static dump ()
{
struct BLOCK *rb;
printf ("BLOKK:Blno,Blev,kind,napar,navirt,navirtlab,");
printf ("fornest,connest,line1,line2,localclasses,thisused\n\n");
printf ("DECL:navn,kind,type,categ,plev,dim,virtno,line\n\n");
for (rb = sblock; rb != NULL; rb = rb->next_block)
if (!(rb->quant.kind == KPROC && (rb->quant.categ == CDEFLT ||
rb->quant.categ == CVIRT)))
dumpblock (rb);
printf ("---UNKNOWNS---\n");
dumpblock (unknowns);
fflush (stdout);
}
#endif
/******************************************************************************
SETPROTECTED */
/* Setter/fjerner protected merket når klasser entres/forlates */
static setprotectedvirt (rb, rd, protected)
struct BLOCK *rb;
struct DECL *rd;
char protected;
{
struct BLOCK *rbx;
struct DECL *rdx;
rbx = rb;
/* Den virtuelle listen for innerste prefiksniv} er ikke akkumulert opp */
if (rb->navirt == 0 & rb->navirtlab == 0)
goto neste;
while (TRUE)
{
if (rd->kind == KPROC && rbx->navirt < rd->virtno)
break;
if (rd->kind != KPROC && rbx->navirtlab < rd->virtno)
break;
for (rdx = rbx->virt; rdx->virtno != rd->virtno |
rdx->kind != rd->kind; rdx = rdx->next);
rdx->protected = protected;
if (rdx->match != NULL)
rdx->match->protected = protected;
neste:if (rbx->quant.plev > 0)
rbx = rbx->quant.prefqual->descr;
else
break;
}
}
static setprotected (rb, protected)
struct BLOCK *rb;
char protected;
{
struct BLOCK *rbx;
struct DECL *rd;
for (rd = rb->hiprot; rd != NULL; rd = rd->next)
if (rd->match != NULL && rd->match->encl == rb)
{
if (rd->match->categ == CVIRT)
setprotectedvirt (rb, rd->match, protected);
else
rd->match->protected = protected;
}
rbx = rb;
while (rbx->quant.plev > 0)
{
rbx = rbx->quant.prefqual->descr;
for (rd = rbx->hiprot; rd != NULL; rd = rd->next)
if (rd->categ != CHIPRO && rd->match != NULL)
{
if (rd->match->categ == CVIRT)
setprotectedvirt (rb, rd->match, TRUE - rd->match->protected);
else
rd->match->protected = TRUE - rd->match->protected;
}
}
}
/******************************************************************************
SETPREFCHAIN */
/* Setter opp prefikskjeden rekursift
* Oppdager ulovlig prefiks og feil prefiksnivå
* Oppdager ved merking sirkulær prefikskjede */
static setprefchain (rd)
struct DECL *rd;
{
struct DECL *rdx;
if (rd->plev <= 0 && rd->identqual==NULL)
{
if (rd->plev == 0)
rd->prefqual = commonprefiks;
}
else
{
rdx = findGlobal (rd->identqual, FALSE);
rd->identqual=NULL;
rd->plev = 0;
if (rdx->categ == CNEW)
{
rdx->categ = CERROR;
d2error (50, rd, rdx);
rd->prefqual = commonprefiks;
}
else if (rdx->kind != KCLASS)
{
if (rdx->categ != CERROR)
d2error (50, rd, rdx);
rdx->categ = CERROR;
rd->prefqual = commonprefiks;
}
else if (seenthrough != NULL)
{
if (rdx->categ != CERROR)
d2error (49, rd, rdx);
rdx->categ = CERROR;
rd->prefqual = commonprefiks;
}
else if ((cblock->quant.kind == KFOR && rdx->encl != rd->encl)
/* For for-block s} blir ikke blokkniv}et |ket. Prefiksen vil aldri
* v{re deklarert i for-blokken (da ville det v{rt lagt p} en ekstra
* blokk), den vil ligge i prefiksen til for-blokken, og det er
* ulovlig, da en for-blokk alltid skal opptre som om det er en blokk
*/
|| (rdx->encl->blev != rd->encl->blev))
{
if (rdx->categ != CERROR)
d2error (51, rd, rdx);
rdx->categ = CERROR;
rd->prefqual = commonprefiks;
}
else
{
if (rdx->prefqual == NULL)
setprefchain (rdx);
if (rd->prefqual == commonprefiks)
d2error (52, rd, rdx);
else
{
rd->prefqual = rdx;
rd->plev = rdx->plev + 1;
}
}
}
}
/******************************************************************************
SETQUALPREFCHAIN */
/* Setter opp prefikskjeden og kvalifikasjonen til pekere
* gjør kall på setprefchain og sjekker kvalifikasjonen */
static struct DECL *
setqualprefchain (rd, param)
struct DECL *rd;
int param;
{
struct DECL *rdx;
for (; rd != NULL; rd = rd->next)
{
if (param && (rd->categ == CLOCAL || rd->categ == CCONSTU
|| rd->categ == CCPROC || rd->categ == CEXTR
|| rd->categ == CEXTRMAIN))
return (rd);
if (rd->type == TREF)
{
rdx = findGlobal (rd->identqual, FALSE);
rd->plev = 0;
if (rdx->categ == CNEW)
{
d2error (53, rd);
rdx->categ = CERROR;
}
else if (rdx->kind != KCLASS)
{
if (rdx->categ != CERROR)
d2error (54, rd);
rdx->categ = CERROR;
rd->type = TERROR;
}
rd->prefqual = rdx;
}
if (rd->kind == KCLASS && rd->prefqual == NULL)
setprefchain (rd);
}
return (rd);
}
/******************************************************************************
SJEKKDEKL */
/* Kalles i pass 2 for hver blokk som ikke er en prosedyre eller klasse
* Sjekkdekl tar seg av å sjekke og akumulere opp virtuelle
* Prefikskjeden og kvalifikasjoner settes ved kall på setqualprefchain
* den sjekker også konsistensen for type kind og categ */
static sjekkdekl (rb)
struct BLOCK *rb;
{
struct DECL *rd = NULL,
*rdx = NULL,
*rdy,
*va = NULL,
*vb = NULL,
*vc = NULL;
struct BLOCK *rbx = NULL;
int vno,
vnolab,
kind;
switch (kind = rb->quant.kind)
{
case KCLASS:
/* Merker at denne klassen er blitt kalt */
rb->quant.match = sjekkdeklcalled;
/* Prefiksen maa først alokeres */
if (rb->quant.plev > 0)
{
rbx = rb->quant.prefqual->descr;
if (rbx->quant.match != sjekkdeklcalled)
{
cblock = rbx;
sjekkdekl (rbx);
cblock = rb;
}
rb->localclasses |= rbx->localclasses;
rb->napar += rbx->napar;
}
break;
case KPRBLK:
/* Må lete på nivået utenfor prefiksblokken */
cblev--;
cblock= cblock->quant.encl;
setprefchain (&rb->quant);
cblev++;
cblock= rb;
if (cblev <= 2 /*|| display[cblev - 1]->stat*/)
rb->stat = TRUE;
break;
case KINSP:
/* if (rb->quant.prefqual->descr->stat)
rb->stat = TRUE;*/
return; /* Sjekker blokken som inspiseres ved dens
* deklarasjon */
case KFOR:
case KCON:
/* if (rb->quant.prefqual->descr->stat)
rb->stat = TRUE;*/
break;
case KBLOKK:
if (cblev <= 2 /*|| display[cblev - 1]->stat*/)
rb->stat = TRUE;
break;
default:
/* INGEN AKSJON */
break;
}
/* Sjekker alle deklarasjonene til denne blokken */
for (rd = rb->parloc; rd != NULL; rd = rd->next)
{
if (rd->ident != NULL)
{
/* Sjekker dobbeltdeklarasjoner */
for (rdx = rb->parloc; rdx->ident != rd->ident
|| rdx->protected == TRUE; rdx = rdx->next);
if (rdx != rd)
{
if (kind == KPROC && (rdx->categ == CDEFLT ||
rdx->categ == CVALUE ||
rdx->categ == CNAME ||
rdx->categ == CVAR) &&
rd->categ != CDEFLT && rd->categ != CVALUE &&
rd->categ != CNAME && rd->categ != CVAR)
{
char *s;
obstack_grow (&osDecl, "__", 2);
obstack_grow0 (&osDecl, rdx->ident, strlen(rdx->ident));
s= obstack_finish(&osDecl);
rdx->ident = tag (s);
obstack_free (&osDecl, s);
}
else
d2error (55, rd);
}
}
if (rd->kind == KNOKD && rd->type != TVARARGS)
d2error (63, rd);
if (rd->kind == KARRAY && rd->type == TNOTY)
rd->type = TREAL;
switch (rd->categ)
{
case CLOCAL:
case CCONST:
case CCONSTU:
/* Ikke mer sjekking lokale deklarasjoner */
break;
case CDEFLT:
/* Procedyrer, label eller switch er ikke
* lovlig som parameter til klasser */
/* if (kind == KCLASS)
{
if (rd->kind == KPROC | rd->type == TLABEL)
d2error (56, rd);
}*/
if (rd->type == TVARARGS)
{
if (rd->next != NULL)
d2error (80, rd);
if (kind != KPROC || rb->quant.categ != CCPROC)
d2error (81, rd);
}
if (rd->type == TLABEL && rb->quant.categ == CCPROC)
d2error (82, rd);
break;
case CVALUE:
/* Sjekker om lovlig valueoverføring */
if ((rd->type == TINTG | rd->type == TREAL | rd->type == TBOOL |
rd->type == TCHAR) && (rd->kind == KSIMPLE | rd->kind == KARRAY))
{
if (rd->kind == KSIMPLE)
rd->categ = CDEFLT;
}
else if (rd->type == TTEXT & rd->kind == KSIMPLE) /* OK */ ;
else if (rd->type == TVARARGS)
{
if (rd->next != NULL)
d2error (80, rd);
if (kind != KPROC || rb->quant.categ != CCPROC)
d2error (81, rd);
}
else
d2error (57, rd);
if (rd->type == TLABEL && rb->quant.categ == CCPROC)
d2error (82, rd);
break;
case CVAR:
if (rd->type == TREF && (rd->kind == KSIMPLE | rd->kind == KARRAY))
{
rd->categ = CDEFLT;
}
case CNAME:
/* Nameparameter til klasser er ikke lovlig */
/* if (kind == KCLASS)
d2error (58, rd);*/
if (kind == KPROC && rb->quant.categ == CCPROC &&
(rd->type == TTEXT || rd->type == TREF))
d2error (77, rd);
if (rd->type == TVARARGS)
{
if (rd->next != NULL)
d2error (80, rd);
if (kind != KPROC || rb->quant.categ != CCPROC)
d2error (81, rd);
}
if (rd->type == TLABEL && rb->quant.categ == CCPROC)
d2error (82, rd);
break;
case CEXTR:
case CEXTRMAIN:
break;
case CCPROC:
if (rd->type == TREF)
d2error (78, rd);
break;
default:
/* ULOVLIG CATEG */
d2error (59, rd);
}
}
if (rb->quant.kind == KCLASS || rb->quant.kind == KPRBLK)
{
setprotected (rb, FALSE);
/* Kopierer opp de akumulerte virtuelle
* Kjeder disse sammen i en liste hvor
* va peker paa første og vb på siste */
if (rb->quant.plev > 0)
for (vc = rb->quant.prefqual->descr->virt;
vc != NULL; vc = vc->next)
{
if (va == NULL)
va = vb = newDecl ();
else
vb = vb->next = newDecl ();
makeequal (vb, vc);
vb->encl = rb;
vb->dim = 0;
}
rdx = rb->virt;
if (va != NULL || rb->virt != NULL)
{
/* Hekter de akumulerte inn i listen av virtuelle
* slik at de blir liggende først i lista */
vc = rb->virt;
if (va != NULL)
{
vb->next = rb->virt;
rb->virt = va;
vno = rb->quant.prefqual->descr->navirt;
vnolab = rb->quant.prefqual->descr->navirtlab;
}
else
vno = vnolab = 0;
vb = vc;
for (; vc != NULL; vc = vc->next)
{
/* Sjekker dobbel spesifisering av de nye virtuelle */
for (va = rb->virt; va->ident != vc->ident ||
va->protected == TRUE; va = va->next);
if (va != vc)
{
d2error (60, vc);
while (va->next != vc)
va = va->next;
va->next = vc->next;
vc = va;
}
else
{
/* Sjekker om det er lovlig virtuell */
if (vc->kind != KPROC && vc->type != TLABEL)
{
d2error (61, vc);
vc->type = TERROR;
vc->kind = KERROR;
}
if (vc->kind == KPROC)
vc->virtno = ++vno;
else
vc->virtno = ++vnolab;
vc->dim = 1;
}
}
rb->navirt = vno;
rb->navirtlab = vnolab;
}
}
else
rdx = NULL;
/* Setter opp kvalifikasjoner og prefiks pekere */
rd = rb->parloc;
cblev--;
cblock= cblock->quant.encl;
if (rd != NULL)
rd = setqualprefchain (rd, 1); /* FOR PARAMETERE */
cblev++;
cblock= rb;
if (rdx != NULL)
setqualprefchain (rdx, 0); /* FOR VIRTUELLE */
if (rd != NULL)
setqualprefchain (rd, 0); /* FOR LOKALE */
cblev++;
for (rd = rb->parloc; rd != NULL; rd = rd->next)
/* Sjekker lokal klasse og prosedyre */
if ((rd->kind == KCLASS && rd->match != sjekkdeklcalled)
|| (rd->kind == KPROC && (rd->categ == CLOCAL || rd->categ == CCPROC)))
{
cblock = rd->descr;
sjekkdekl (rd->descr);
}
else
/* SJEKKER PROSEDYRE SOM ER OVERF\RT SOM PARAMETER */
if (rd->kind == KPROC & rd->descr != NULL)
{
cblock = rd->descr;
sjekkdekl (rd->descr);
}
for (rd = vb; rd != NULL; rd = rd->next)
/* Sjekker spesifikasjon av virtuell prosedyre */
if (rd->kind == KPROC & rd->descr != NULL)
{
cblock = rd->descr;
sjekkdekl (rd->descr);
}
cblev--;
cblock = rb;
for (vc = rb->virt; vc != NULL; vc = vc->next)
{
if (vc->protected)
continue;
for (va = rb->parloc; va != NULL && va->ident != vc->ident;
va = va->next);
if (va != NULL)
{
if ((vc->type == TERROR && (va->kind == KPROC || va->type == TLABEL))
|| (vc->type == TLABEL && va->type == TLABEL
&& vc->kind == va->kind)
|| (vc->kind == KPROC && va->kind == KPROC && subordinate (va, vc)
&& sameParam (vc->descr, va->descr)))
{
vc->match = va;
vc->type = va->type;
vc->prefqual = va->prefqual;
}
else
d2error (62, va);
}
else if (vc->match == vc)
vc->match = NULL;
}
if (rb->quant.kind == KCLASS || rb->quant.kind == KPRBLK)
{
/* Listen av hidden og protected sjekkes og match settes opp */
for (rd = rb->hiprot; rd != NULL; rd = rd->next)
{
rdx = findLocal (rd->ident, &rb->quant, TRUE);
if (rdx->categ == CNEW)
{
d2error (74, rd);
rdx->categ = CERROR;
}
else if (rd->categ != CHIDEN && rdx->encl != rb)
d2error (75, rd);
else if (rd->categ != CHIDEN && rdx->categ == CVIRT)
{
if (rb->quant.plev == 0)
vno = 0;
else if (rdx->kind == KPROC)
vno = rb->quant.prefqual->descr->navirt;
else
vno = rb->quant.prefqual->descr->navirtlab;
if (rdx->virtno <= vno)
d2error (75, rd);
else
rd->match = rdx;
}
else if (rd->categ == CHIDEN && rdx->categ == CVIRT
&& rb->quant.plev > 0)
{
for (rdy = rb->quant.prefqual->descr->virt;
rdy->virtno != rdx->virtno || rdy->kind != rdx->kind;
rdy = rdy->next);
rd->match = rdy;
}
else
rd->match = rdx;
}
setprotected (rb, TRUE);
/* Sjekk at de som er hidden også er protected */
for (rd = rb->hiprot; rd != NULL; rd = rd->next)
if (rd->categ == CHIDEN && rd->match != NULL &&
rd->match->protected == FALSE)
d2error (76, rd);
}
}
/*****************************************************************************/
/* HJELP TIL SJEKKEREN */
/*****************************************************************************/
/******************************************************************************
FIRSTCLASS */
struct BLOCK *
firstclass ()
{ /* Retunerer med blev for den n{rmeste
* klassen eller prefiksblokk sett
* fra cblock */
int i;
struct BLOCK *rb;
i = cblev;
for (rb = cblock; rb->quant.kind != KCLASS && rb->quant.kind != KPRBLK; rb = rb->quant.encl)
if ((rb->quant.kind == KFOR || rb->quant.kind == KINSP
|| rb->quant.kind == KCON) &&
rb->quant.match->kind == KCLASS)
return (rb->quant.match->descr);
return (rb);
}
/******************************************************************************
INBLOCK */
/* InBlock kalles fra sjekkeren hver gang en blokk entres */
nextblock ()
{
static struct BLOCK *lblock;
if (lblock == NULL)
lblock = ssblock;
else
lblock = lblock->next_block;
while (lblock->quant.categ == CDEFLT /* formell proc.spec */ ||
lblock->quant.categ == CNAME /* formell proc.spec */ ||
lblock->quant.categ == CVAR /* formell proc.spec */ ||
lblock->quant.categ == CVIRT /* virtuell proc.spec */ ||
lblock->quant.categ == CCPROC ||
lblock->timestamp != 0)
lblock = lblock->next_block;
cblock= lblock;
}
inBlock ()
{
nextblock ();
cblev = cblock->blev;
if (cblock->quant.kind != KPROC && cblock->quant.kind != KCLASS)
sjekkdekl (cblock);
if (cblock->quant.kind == KCLASS || cblock->quant.kind == KPRBLK)
setprotected (cblock, FALSE);
}
/******************************************************************************
OUTBLOCK */
/* OutBlock kalles fra sjekkeren hver gang en blokk forlates */
outBlock ()
{
if (cblock->quant.kind == KCLASS || cblock->quant.kind == KPRBLK)
setprotected (cblock, TRUE);
if (cblock->quant.kind == KCON)
{
cblock->quant.prefqual->descr->when = NULL;
}
if (cblock->quant.kind == KFOR || cblock->quant.kind == KINSP
|| cblock->quant.kind == KCON)
cblock = cblock->quant.prefqual->descr;
else
{
cblev--;
cblock = cblock->quant.encl;
}
}
/******************************************************************************
REGWHEN */
regwhen (rb, rd) struct BLOCK *rb; struct DECL *rd;
{
rb->quant.prefqual->descr->when= rd;
}
/******************************************************************************
REGINSP */
reginsp (rb, rd) struct BLOCK *rb; struct DECL *rd;
{
if (rd == NULL)
{
d2error (73, &rb->quant);
rd = findGlobal (tag ("Noqual"), FALSE);
rd->categ = CERROR;
}
rb->virt = rd;
}
/******************************************************************************
REGTHIS */
/* Kalles fra sjekkeren hver gang this oppdages,
* sjekker da lovligheten */
struct DECL *
regThis (ident)
char *ident;
{
struct DECL *rd,
*rdt,
*rdx;
struct BLOCK *rb;
#ifdef DEBUG
if (option_input)
printf ("regThis---line:%ld cblev:%d\t"
,lineno, cblev);
#endif
for (rb = cblock; rb->blev > 0; rb= rb->quant.encl) /* Skal det v}re i>=0 .(Omgivelsene) */
{
rd = &rb->quant;
do
{
rdx = rd;
if (rd->kind == KINSP)
{
seenthrough = rd->descr;
rd = rd->descr->when;
}
else
seenthrough = NULL;
if (rd->kind == KCLASS)
{
do
if (rd->ident == ident)
{
if (rd->descr->thisused == MAYBEE)
d2error (72, rd);
rd->descr->thisused |= TRUE;
#ifdef DEBUG
if (option_input)
printf ("---end\n");
#endif
if (rd->descr->blev == cblock->blev)
localused = TRUE;
return (rd);
}
while (rd = (rdt = rd)->prefqual, rdt->plev > 0);
}
rd = rdx->prefqual;
}
while (rdx->kind == KCON || rdx->kind == KINSP || rdx->kind == KFOR);
}
#ifdef DEBUG
if (option_input)
printf ("---end\n");
#endif
d2error (79, rd = findGlobal (ident, FALSE));
return (rd);
}
/******************************************************************************
FINDLOCAL */
/* FindLocal finner den deklarasjonen som svarer til et navn
* Den leter lokalt i den lista den har fåt og dens prefikskjede
* Har den ikke fåt noen liste leter den slik findGlobal gjør
* Den registrerer også localused
* Hvis virt==TRUE skal det først letes i evt. virtuell liste */
struct DECL *
findLocal (ident, rd, virt)
char *ident;
struct DECL *rd;
char virt;
{
seenthrough = NULL;
if (rd != NULL && rd->descr != NULL)
rd = findDecl (ident, rd->descr, virt);
else
return (findGlobal (ident, virt));
if (rd != NULL)
return (rd);
for (rd = unknowns->parloc; rd != NULL; rd = rd->next)
if (rd->ident == ident)
return (rd);
return (newnotseen (ident));
}
/******************************************************************************
NEXTPARAM & FIRSTPARAM */
/* To prosedyrer for å finne parameterene
* til en prosedyre eller klasse
* Får som input forrige parameter */
struct DECL *
nextParam (rd)
struct DECL *rd;
{
struct DECL *rdx;
int plev;
if (rd == NULL)
return (NULL);
if (rd->type == TVARARGS)
return (rd);
if (rd->next != NULL)
{
rd = rd->next;
if (rd == arrayparam && rd->dim != USPECDIM)
rd->dim--;
if (rd->categ == CDEFLT || rd->categ == CVALUE ||
rd->categ == CNAME || rd->categ == CVAR || rd->type == TVARARGS)
return (rd);
}
if (rd->encl->quant.kind == KCLASS)
{
for (rd= ppop (); rd!= NULL; rd= ppop ())
if ((rdx = rd->descr->parloc) != NULL &&
(rdx->categ == CDEFLT || rdx->categ == CVALUE
|| rdx->categ == CNAME || rdx->categ == CVAR))
return (rdx);
}
return (sluttparam);
}
static struct DECL *
firstclassparam (rd)
struct DECL *rd;
{
struct DECL *rdx,
*rdy;
if (rd->plev > 0)
{
ppush (rd);
rdy = firstclassparam (rd->prefqual);
}
else
rdy = sluttparam;
if (rdy == sluttparam)
{
if ((rdx = rd->descr->parloc) != NULL &&
(rdx->categ == CDEFLT || rdx->categ == CVALUE
|| rdx->categ == CNAME || rdx->categ == CVAR))
return (rdx);
ppop ();
}
return (rdy);
}
struct DECL *
firstParam (rd)
struct DECL *rd;
{
struct DECL *rdx;
if (rd->kind == KCLASS)
{
pclean ();
return (firstclassparam (rd));
}
if (rd->kind == KARRAY)
{
if (rd->type == TLABEL)
return (switchparam);
if (rd->dim)
arrayparam->dim = rd->dim;
else
arrayparam->dim = USPECDIM;
return (arrayparam);
}
/* else Kommentertut p.g.a full spesifisering
* av parametere til formelle prosedyrer.
* if(rd->kind==KPROC && rd->categ==CDEFLT) {
* return(procparam); } */
if (rd->descr == NULL)
return (sluttparam);
if ((rdx = rd->descr->parloc) != NULL &&
(rdx->categ == CDEFLT || rdx->categ == CVALUE
|| rdx->categ == CNAME || rdx->categ == CVAR
|| rdx->type == TVARARGS))
return (rdx);
return (sluttparam);
}
/******************************************************************************
MOREPARAM */
/* Forlanges det flere parametere */
moreParam (rd)
struct DECL *rd;
{
if (rd == sluttparam)
return (FALSE);
if (rd == switchparam->next)
return (FALSE);
if (rd == NULL)
return (FALSE);
if (rd->type == TVARARGS)
return (MAYBEE);
if (rd == arrayparam)
{
if (rd->dim == USPECDIM)
return (MAYBEE);
if (rd->dim > 0)
return (TRUE);
return (FALSE);
}
/* er kommenter ut siden formelle procedyrer er fullt ut spesifisert
* if(rd==procparam)return(MAYBEE); */
return (TRUE);
}
/******************************************************************************
NOTBODY */
/* Er vi inne i en prosedyre kropp */
body (rd)
struct DECL *rd;
{
struct BLOCK *rb, *rbx;
rbx = cblock;
rb = rd->descr;
for (rbx= cblock; rbx->blev > 0; rbx= rbx->quant.encl)
{
/* Hvis vi er inne i en inspect blokk eller for blokk */
/* m} match f|lges for } f} riktig blokk. KAN BARE */
/* BRUKES FOR ] UNDERS\KE OM MAN ER INNE I EN PROSEDYRE */
if (rbx->quant.kind == KCON || rbx->quant.kind == KFOR)
rbx= rbx->quant.match->descr;
if (rbx == rb)
return (TRUE);
}
return (FALSE);
}
/******************************************************************************
DANGERPROC */
/* Er prosedyren farlig og m] isoleres i uttrykk */
char
dangerProc (rd)
struct DECL *rd;
{
switch (rd->descr->codeclass)
{
case CCCPROC:
return (rd->type == TTEXT);
case CCFILEDANGER:
case CCTEXTDANGER:
case CCRANDOMRUTDANGER:
case CCBLANKSCOPY:
case CCFILEBLANKSCOPY:
case CCSIMPLEDANGER:
case CCNO:
return (TRUE);
}
return (FALSE);
}
/*****************************************************************************
REMOVEBLOCK */
removeBlock (rb) struct BLOCK *rb;
{
struct DECL *rd;
if (rb->quant.encl->parloc->descr == rb)
rb->quant.encl->parloc= rb->quant.encl->parloc->next;
else
{
for (rd= rb->quant.encl->parloc; rd->next->descr != rb; rd= rd->next);
rd->next= rd->next->next;
}
}
syntax highlighted by Code2HTML, v. 0.9.1