From: Rafał Długołęcki Date: Wed, 24 Jul 2013 08:17:40 +0000 (+0200) Subject: vlp-10 using coding style in typchk.c X-Git-Tag: 3.1~16 X-Git-Url: https://git.dlugolecki.net.pl/?a=commitdiff_plain;h=4922daba787aeefe88365fe1f60ab38d4baf44fa;p=vlp.git vlp-10 using coding style in typchk.c --- diff --git a/src/int/typchk.c b/src/int/typchk.c index fac9ff8..2a70407 100644 --- a/src/int/typchk.c +++ b/src/int/typchk.c @@ -28,11 +28,11 @@ or Andrzej Salwicki ======================================================================= */ -#include "depend.h" -#include "genint.h" -#include "int.h" -#include "process.h" -#include "intproto.h" +#include "depend.h" +#include "genint.h" +#include "int.h" +#include "process.h" +#include "intproto.h" /* Type checking routines */ @@ -41,10 +41,10 @@ or Andrzej Salwicki */ #ifndef NO_PROTOTYPES -static bool pref(word,word); -static bool typep0(word,word,bool,word *,word *); -static bool prefh(word,word); -static bool typef(word,word,word,word); +static bool pref(word, word); +static bool typep0(word, word, bool, word *, word *); +static bool prefh(word, word); +static bool typef(word, word, word, word); #else static bool pref(); static bool typep0(); @@ -53,331 +53,376 @@ static bool typef(); #endif -static bool pref(am, prot) -word am, prot; +static bool pref(word am, word prot) { - word t1, t2; - protdescr *ptr; - - t1 = M[ am+PROTNUM ]; - if (t1 != AINT && t1 != AVIRT && t1 != AREAL && t1 != FILEOBJECT) - { /* neither array nor file */ - ptr = prototype[ t1 ]; - t1 = ptr->preflist; - t2 = t1+ptr->lthpreflist; - while (t1 < t2) - { - if (prot == M[ t1 ]) return (TRUE); - t1++; - } - } - return (FALSE); -} /* end pref */ - - -void qua(virt, tp) /* Validate qualification of object */ -virtaddr *virt; -word tp; -{ - if (virt->mark != M[ virt->addr+1 ]) errsignal(RTEREFTN); - if (M[ tp ] != CLASSTYPE) errsignal(RTEINCQA); - if (!pref(M[ virt->addr ], M[ tp+1 ])) errsignal(RTEINCQA); -} /* end qua */ - + word t1, t2; + protdescr *ptr; + + t1 = M[am + PROTNUM]; + if (t1 != AINT && t1 != AVIRT && t1 != AREAL && t1 != FILEOBJECT) { + /* neither array nor file */ + ptr = prototype[t1]; + t1 = ptr->preflist; + t2 = t1 + ptr->lthpreflist; + while (t1 < t2) { + if (prot == M[t1]) + return TRUE; + t1++; + } + } + return FALSE; +} -bool inl(virt, tp) /* Determine if A in B */ -virtaddr *virt; -word tp; +/* Validate qualification of object */ +void qua(virtaddr *virt, word tp) { - if (virt->mark != M[ virt->addr+1 ]) - return (TRUE); /* none is in everything */ - else - if (M[ tp ] != CLASSTYPE) return (FALSE); - else return (pref(M[ virt->addr ], M[ tp+1 ])); -} /* end inl */ + if (virt->mark != M[virt->addr + 1]) + errsignal(RTEREFTN); + if (M[tp] != CLASSTYPE) + errsignal(RTEINCQA); + if (!pref(M[virt->addr], M[tp + 1])) + errsignal(RTEINCQA); +} +/* Determine if A in B */ +bool inl(virtaddr *virt, word tp) +{ + /* none is in everything */ + if (virt->mark != M[virt->addr + 1]) + return TRUE; + else if (M[tp] != CLASSTYPE) + return FALSE; + else + return pref(M[virt->addr], M[tp + 1]); +} -bool is(virt, tp) /* Determine if A is B */ -virtaddr *virt; -word tp; +/* Determine if A is B */ +bool is(virtaddr *virt, word tp) { - if (virt->mark != M[ virt->addr+1 ] || M[ tp ] != CLASSTYPE) - return (FALSE); - else return (M[ M[ virt->addr ]+PROTNUM ] == M[ tp+1 ]); -} /* end is */ + if (virt->mark != M[virt->addr + 1] || M[tp] != CLASSTYPE) + return FALSE; + else + return (M[M[virt->addr] + PROTNUM] == M[tp + 1]); +} -/* Check correctness of an especially clumsy assignment statement +/** + * Check correctness of an especially clumsy assignment statement */ - -void typref(virt, tp) -virtaddr *virt; -word tp; +void typref(virtaddr *virt, word tp) { - word t1, t2, t3; - int knd; - - if (virt->mark == M[ virt->addr+1 ]) /* none always allowed */ - { - t3 = M[ virt->addr ]; /* am of right hand side */ - t1 = M[ t3+PROTNUM ]; - if (t1 == AINT || t1 == AREAL || t1 == AVIRT) errsignal(RTEINCAS); - t2 = M[ tp ]; /* right hand side type */ - if (t2 == FILETYPE) - { - if (t1 != FILEOBJECT) errsignal(RTEINCAS); - } - else - if (t2 == PURECOROUTINE || t2 == PUREPROCESS) - { - if (t2 == PURECOROUTINE) knd = COROUTINE; - else knd = PROCESS; - if (prototype[ t1 ]->kind != knd) errsignal(RTEINCAS); - } - else - { - if (t2 != CLASSTYPE) errsignal(RTEINCAS); - if (!pref(t3, M[ tp+1 ])) errsignal(RTEINCAS); - } - } -} /* end typref */ - - -/* Check correctness of a dynamic assignment - */ + word t1, t2, t3; + int knd; + + /* none always allowed */ + if (virt->mark == M[virt->addr + 1]) { + /* am of right hand side */ + t3 = M[virt->addr]; + t1 = M[t3 + PROTNUM]; + if (t1 == AINT || t1 == AREAL || t1 == AVIRT) + errsignal(RTEINCAS); + /* right hand side type */ + t2 = M[tp]; + if (t2 == FILETYPE) { + if (t1 != FILEOBJECT) + errsignal(RTEINCAS); + } + else if (t2 == PURECOROUTINE || t2 == PUREPROCESS) { + if (t2 == PURECOROUTINE) + knd = COROUTINE; + else + knd = PROCESS; + + if (prototype[t1]->kind != knd) + errsignal(RTEINCAS); + } else { + if (t2 != CLASSTYPE) + errsignal(RTEINCAS); + if (!pref(t3, M[tp + 1])) + errsignal(RTEINCAS); + } + } +} + -void typed(ldim, lt, rdim, rt, virt) -word ldim, lt, rdim, rt; -virtaddr *virt; +/** + * Check correctness of a dynamic assignment + */ +void typed(word ldim, word lt, word rdim, word rt, virtaddr *virt) { - if (ldim != rdim) errsignal(RTEINCAS); - if (ldim == 0) typref(virt, lt); - else - if (lt != rt) errsignal(RTEINCAS); -} /* end typed */ + if (ldim != rdim) + errsignal(RTEINCAS); + if (ldim == 0) + typref(virt, lt); + else if (lt != rt) + errsignal(RTEINCAS); +} -/* Search the SL chain of object am to find the nearest Y such that Y in A. +/** + * Search the SL chain of object am to find the nearest Y such that Y in A. * prot = prototype number of A */ - -word loadt(am, prot) -word am, prot; +word loadt(word am, word prot) { - word t1, t2, t3, t4; - - while( !pref(am, prot) ) - { - t1 = am+M[ am ]+SL; - t2 = M[ t1 ]; /* try next object in chain */ - t3 = M[ t1+1 ]; - t4 = M[ t2+1 ]; - if( t3 != t4 ) errsignal( RTEFTPMS ); - am = M[ t2 ]; - } - return (am); + word t1, t2, t3, t4; + + while(!pref(am, prot)) { + t1 = am + M[am] + SL; + /* try next object in chain */ + t2 = M[t1]; + t3 = M[t1 + 1]; + t4 = M[t2 + 1]; + if(t3 != t4) + errsignal(RTEFTPMS); + am = M[t2]; + } + return am; } -/* Compute type of a formal parameter - see also typep (below). */ - -static bool typep0(am, pdaddr, protp, dim, tp) -word am, pdaddr; -bool protp; -word *dim, *tp; +/** + * Compute type of a formal parameter - see also typep (below). + */ +static bool typep0(word am, word pdaddr, bool protp, word *dim, word *tp) { - word t1; - protdescr *ptr; - - if (protp) /* prototype number on input */ - { - ptr = prototype[ pdaddr ]; - *dim = ptr->nrarray; - *tp = ptr->finaltype; - } - else /* type address on input */ - { - *dim = M[ pdaddr+1 ]; - *tp = M[ pdaddr+2 ]; - } - if (M[ *tp ] != FORMTYPE) return (TRUE); - else - { - t1 = M[ *tp+1 ]; /* SL prototype number */ - if (t1 == DUMMY) return (FALSE); - else /* undefined */ - { - *tp = loadt(am, t1)+M[ *tp+2 ]; - *dim += M[ *tp ]; /* accumulate dim */ - *tp = M[ *tp+1 ]; - return (TRUE); /* AIL 1989.02.02 */ - } - } -} /* end typep0 */ - - -void typep(am, nr, dim, tp) /* Compute type of formal parameter */ -word am, nr; -word *dim, *tp; + word t1; + protdescr *ptr; + + /* prototype number on input */ + if (protp) { + ptr = prototype[pdaddr]; + *dim = ptr->nrarray; + *tp = ptr->finaltype; + } else { + /* type address on input */ + *dim = M[pdaddr + 1]; + *tp = M[pdaddr + 2]; + } + if (M[*tp] != FORMTYPE) + return TRUE; + else { + /* SL prototype number */ + t1 = M[*tp + 1]; + if (t1 == DUMMY) + return FALSE; + /* undefined */ + else { + *tp = loadt(am, t1) + M[*tp + 2]; + /* accumulate dim */ + *dim += M[*tp]; + *tp = M[*tp + 1]; + /* AIL 1989.02.02 */ + return TRUE; + } + } +} + +/** + * Compute type of formal parameter + */ +void typep(word am, word nr, word *dim, word *tp) { - if (!typep0(am, M[ prototype[ M[ am+PROTNUM ] ]->pfdescr+nr ], - FALSE, dim, tp)) errsignal(RTESYSER); -} /* end typep */ + if (!typep0(am, M[prototype[M[am + PROTNUM]]->pfdescr + nr], FALSE, dim, + tp)) { + errsignal(RTESYSER); + } +} /* Auxiliary function for heads, almost the same as pref. */ -static bool prefh(tp, prot) -word tp, prot; +static bool prefh(word tp, word prot) { - word t1, t2; - protdescr *ptr; - - ptr = prototype[ M[ tp+1 ] ]; - t2 = ptr->preflist; - t1 = t2+ptr->lthpreflist-1; - do - { - if (M[ t1 ] == prot) return (TRUE); - else t1--; - } while (t1 >= t2); - return (FALSE); -} /* end prefh */ - - -/* Check compatibility of generalized types, used by heads only. - */ + word t1, t2; + protdescr *ptr; + + ptr = prototype[M[tp + 1]]; + t2 = ptr->preflist; + t1 = t2 + ptr->lthpreflist - 1; + do { + if (M[ t1 ] == prot) + return TRUE; + else + t1--; + } while (t1 >= t2); + return FALSE; +} -static bool typef(dima, ta, dimb, tb) -word dima, ta, dimb, tb; -{ - word t1, t2; - int knd; - - if (dima != dimb) errsignal(RTEINCHS); /* incompatible headers */ - if (ta != tb) /* types different somehow */ - { - if (dima != 0) errsignal(RTEINCHS); /* dim must be 0 now */ - t1 = M[ ta ]; - t2 = M[ tb ]; - if (t1 == PRIMITIVETYPE || t1 == FILETYPE) errsignal(RTEINCHS); - if (t2 == PRIMITIVETYPE || t2 == FILETYPE) errsignal(RTEINCHS); - if (t1 != PURECOROUTINE && t1 != PUREPROCESS) - { - if (t2 == PURECOROUTINE || t2 == PUREPROCESS) return (TRUE); - else - { - if (!prefh(ta, M[ tb+1 ])) - { - if (!prefh(tb, M[ ta+1 ])) errsignal(RTEINCHS); - else return (TRUE); - } - } - } - else /* something pure */ - { - if (t1 != t2) - { - /* AIL : t1 below replaced with t2, 1989.02.02 */ - /* if (t1 == PURECOROUTINE || t1 == PUREPROCESS) */ - if (t2 == PURECOROUTINE || t2 == PUREPROCESS) - knd = RECORD; /* used as junk */ - else knd = prototype[ M[ tb+1 ] ]->kind; - - if ((t1 == PURECOROUTINE && knd != COROUTINE) || - (t1 == PUREPROCESS && knd != PROCESS)) - { - if ((t1 != PURECOROUTINE) || - (knd != PROCESS && t2 != PUREPROCESS)) - return (TRUE); - } - } - } - } - return (FALSE); -} /* end typef */ - - -/* Verify the compatibility of formal/actual procedure (function) heads. + +/** + * Check compatibility of generalized types, used by heads only. */ +static bool typef(word dima, word ta, word dimb, word tb) +{ + word t1, t2; + int knd; + + /* incompatible headers */ + if (dima != dimb) + errsignal(RTEINCHS); + + /* types different somehow */ + if (ta != tb) { + /* dim must be 0 now */ + if (dima != 0) + errsignal(RTEINCHS); + + t1 = M[ta]; + t2 = M[tb]; + + if (t1 == PRIMITIVETYPE || t1 == FILETYPE) + errsignal(RTEINCHS); + + if (t2 == PRIMITIVETYPE || t2 == FILETYPE) + errsignal(RTEINCHS); + + if (t1 != PURECOROUTINE && t1 != PUREPROCESS) { + if (t2 == PURECOROUTINE || t2 == PUREPROCESS) + return TRUE; + else { + if (!prefh(ta, M[tb + 1])) { + if (!prefh(tb, M[ta + 1])) + errsignal(RTEINCHS); + else + return TRUE; + } + } + } + /* something pure */ + else { + if (t1 != t2) { + /* AIL: t1 below replaced with t2, 1989.02.02 */ + /* if (t1 == PURECOROUTINE || t1 == PUREPROCESS) */ + if (t2 == PURECOROUTINE || t2 == PUREPROCESS) { + /* used as junk */ + knd = RECORD; + } + else + knd = prototype[M[tb + 1]]->kind; + + if ((t1 == PURECOROUTINE && knd != COROUTINE) || + (t1 == PUREPROCESS && knd != PROCESS)) { + + if ((t1 != PURECOROUTINE) || + (knd != PROCESS && + t2 != PUREPROCESS)) { + + return TRUE; + } + } + } + } + } + return FALSE; +} + -void heads(virt, nr) -virtaddr *virt; -word nr; +/** + * Verify the compatibility of formal/actual procedure (function) heads. + */ +void heads(virtaddr *virt, word nr) { - word i, j, fp, gp, oba, g, slen, dim, t1, t2, tp, ftv; - protdescr *ptr; - bool junk; - word x[ MAXHDLEN+1 ], y[ MAXHDLEN+1 ]; - /* The two arrays declared above may be dynamically generated as objects */ - /* upon entry to heads. In fact heads was implemented this way in the */ - /* original LOGLAN running system on MERA-400 */ - - oba = M[ virt->addr ]; - ptr = prototype[ M[ oba+PROTNUM ] ]; - fp = M[ ptr->pfdescr+nr ]; /* parameter description pointer */ - slen = M[ fp+2 ]; /* length of its desclist */ - if (slen > MAXHDLEN) errsignal(RTEFHTLG); - ftv = oba+M[ ptr->parlist+nr ]; /* type value pointer */ - g = M[ ftv ]; - if (M[ ftv+1 ] == M[ g+1 ]) /* not none */ - g = M[ g ]; /* am of SL */ - else errsignal(RTESLCOF); /* SL chain cut off */ - gp = M[ ftv+2 ]; /* prototype number of g */ - ptr = prototype[ gp ]; - t2 = M[ fp ]; /* t2 = F-kind */ - if (ptr->kind == FUNCTION) - { - if (t2 != FORMFUNC) errsignal(RTEINCHS); - junk = typep0(g, gp, TRUE, &dim, &tp); - junk = typep0(oba, fp+2, FALSE, &t1, &t2); - if (typef(dim, tp, t1, t2)) errsignal(RTEINCHS); - } - else - if (t2 != FORMPROC) errsignal(RTEINCHS); - if (slen != ptr->lthparlist) /* incompatible lengths */ - errsignal(RTEINCHS); - t1 = M[ fp+1 ]-1; /* oba descriptlist */ - t2 = ptr->pfdescr-1; /* g descriptlist */ - for (i = 1; i <= slen; i++ ) /* verify second order lists */ - { - x[ i ] = DUMMY; /* mark entry as empty */ - y[ i ] = DUMMY; - fp = M[ t1+i ]; /* first type pointer */ - gp = M[ t2+i ]; /* second type pointer */ - tp = M[ fp ]; /* first type ordinal */ - if (tp != M[ gp ]) errsignal(RTEINCHS); - if (tp == FORMTYPE) - { - x[ i ] = fp; /* save pointers to formal types */ - y[ i ] = gp; + word i, j, fp, gp, oba, g, slen, dim, t1, t2, tp, ftv; + protdescr *ptr; + bool junk; + word x[MAXHDLEN + 1], y[MAXHDLEN + 1]; + /* The two arrays declared above may be dynamically generated as objects */ + /* upon entry to heads. In fact heads was implemented this way in the */ + /* original LOGLAN running system on MERA-400 */ + + oba = M[virt->addr]; + ptr = prototype[M[oba + PROTNUM]]; + /* parameter description pointer */ + fp = M[ptr->pfdescr + nr]; + /* length of its desclist */ + slen = M[fp + 2]; + if (slen > MAXHDLEN) + errsignal(RTEFHTLG); + /* type value pointer */ + ftv = oba + M[ptr->parlist + nr]; + g = M[ftv]; + /* not none */ + if (M[ftv + 1] == M[g + 1 ]) { + /* am of SL */ + g = M[g]; } - else - { - if (tp == PARIN || tp == PAROUT || tp == PARINOUT) - { - /* AIL 1989.02.02 */ - /* if (typep0(oba, fp, FALSE, &dim, &tp)) */ - if (! typep0(oba, fp, FALSE, &dim, &tp)) - { /* undefined yet */ + else { + /* SL chain cut off */ + errsignal(RTESLCOF); + } + /* prototype number of g */ + gp = M[ftv + 2]; + ptr = prototype[gp]; + /* t2 = F-kind */ + t2 = M[fp]; + if (ptr->kind == FUNCTION) { + if (t2 != FORMFUNC) + errsignal(RTEINCHS); + + junk = typep0(g, gp, TRUE, &dim, &tp); + junk = typep0(oba, fp + 2, FALSE, &t1, &t2); + + if (typef(dim, tp, t1, t2)) + errsignal(RTEINCHS); + } + else if (t2 != FORMPROC) + errsignal(RTEINCHS); + + /* incompatible lengths */ + if (slen != ptr->lthparlist) + errsignal(RTEINCHS); + + /* oba descriptlist */ + t1 = M[fp + 1] - 1; + /* g descriptlist */ + t2 = ptr->pfdescr - 1; + /* verify second order lists */ + for (i = 1; i <= slen; i++ ) { + /* mark entry as empty */ + x[i] = DUMMY; + y[i] = DUMMY; + + /* first type pointer */ + fp = M[t1 + i]; + /* second type pointer */ + gp = M[t2 + i]; + /* first type ordinal */ + tp = M[fp]; + if (tp != M[gp]) + errsignal(RTEINCHS); + + if (tp == FORMTYPE) { + /* save pointers to formal types */ + x[i] = fp; + y[i] = gp; + } else { + if (tp == PARIN || tp == PAROUT || tp == PARINOUT) { + /* AIL 1989.02.02 */ + /* if (typep0(oba, fp, FALSE, &dim, &tp)) */ + if (! typep0(oba, fp, FALSE, &dim, &tp)) { + /* undefined yet */ /* search preceding formals */ - for (j = 1; j <= i; j++ ) - if (x[ j ] == M[ fp+2 ]) - break; - if (j > i) errsignal(RTEINCHS); - if (y[ j ] != M[ gp+2 ]) errsignal(RTEINCHS); - } - else /* already defined */ - { - for (j = 1; j <= i; j++ ) - if (y [ j ] == M[ gp+2 ]) - errsignal(RTEINCHS); - junk = typep0(g, gp, FALSE, &j, &ftv); - junk = typef(dim, tp, j, ftv); + for (j = 1; j <= i; j++) + if (x[j] == M[fp + 2]) + break; + if (j > i) + errsignal(RTEINCHS); + if (y[j] != M[gp + 2]) + errsignal(RTEINCHS); + } + /* already defined */ + else { + for (j = 1; j <= i; j++ ) + if (y [j] == M[gp + 2]) + errsignal(RTEINCHS); + + junk = typep0(g, gp, FALSE, &j, &ftv); + junk = typef(dim, tp, j, ftv); + } + } } - } } - } }