src/int/typchk.c

   1      /* Loglan82 Compiler&Interpreter
   2      Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
   3      Copyright (C)  1993, 1994 LITA, Pau
   4
   5      This program is free software; you can redistribute it and/or modify
   6      it under the terms of the GNU General Public License as published by
   7      the Free Software Foundation; either version 2 of the License, or
   8      (at your option) any later version.
   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  contacts:  Andrzej.Salwicki@univ-pau.fr
  20
  21 or             Andrzej Salwicki
  22                 LITA   Departement d'Informatique
  23                 Universite de Pau
  24                 Avenue de l'Universite
  25                 64000 Pau   FRANCE
  26                  tel.  ++33 59923154    fax. ++33 59841696
  27
  28 =======================================================================
  29 */
  30
  31 #include "depend.h"
  32 #include "genint.h"
  33 #include "int.h"
  34 #include "process.h"
  35 #include "intproto.h"
  36
  37 /* Type checking routines */
  38
  39
  40 /* Determine if prot occurs in the prefix sequence of object am
  41  */
  42
  43 #ifndef NO_PROTOTYPES
  44 static bool pref(word, word);
  45 static bool typep0(word, word, bool, word *, word *);
  46 static bool prefh(word, word);
  47 static bool typef(word, word, word, word);
  48 #else
  49 static bool pref();
  50 static bool typep0();
  51 static bool prefh();
  52 static bool typef();
  53 #endif
  54
  55
  56 static bool pref(word am, word prot)
  57 {
  58         word t1, t2;
  59         protdescr *ptr;
  60
  61         t1 = M[am + PROTNUM];
  62         if (t1 != AINT && t1 != AVIRT && t1 != AREAL && t1 != FILEOBJECT) {
  63                 /* neither array nor file */
  64                 ptr = prototype[t1];
  65                 t1 = ptr->preflist;
  66                 t2 = t1 + ptr->lthpreflist;
  67                 while (t1 < t2) {
  68                         if (prot == M[t1])
  69                                 return TRUE;
  70                         t1++;
  71                 }
  72         }
  73         return FALSE;
  74 }
  75
  76 /* Validate qualification of object */
  77 void qua(virtaddr *virt, word tp)
  78 {
  79         if (virt->mark != M[virt->addr + 1])
  80                 errsignal(RTEREFTN);
  81         if (M[tp] != CLASSTYPE)
  82                 errsignal(RTEINCQA);
  83         if (!pref(M[virt->addr], M[tp + 1]))
  84                 errsignal(RTEINCQA);
  85 }
  86
  87 /* Determine if A in B */
  88 bool inl(virtaddr *virt, word tp)
  89 {
  90         /* none is in everything */
  91         if (virt->mark != M[virt->addr + 1])
  92                 return TRUE;
  93         else if (M[tp] != CLASSTYPE)
  94                 return FALSE;
  95         else
  96                 return pref(M[virt->addr], M[tp + 1]);
  97 }
  98
  99 /* Determine if A is B */
 100 bool is(virtaddr *virt, word tp)
 101 {
 102         if (virt->mark != M[virt->addr + 1] || M[tp] != CLASSTYPE)
 103                 return FALSE;
 104         else
 105                 return (M[M[virt->addr] + PROTNUM] == M[tp + 1]);
 106 }
 107
 108
 109 /**
 110  * Check correctness of an especially clumsy assignment statement
 111  */
 112 void typref(virtaddr *virt, word tp)
 113 {
 114         word t1, t2, t3;
 115         int knd;
 116
 117         /* none always allowed */
 118         if (virt->mark == M[virt->addr + 1]) {
 119                 /* am of right hand side */
 120                 t3 = M[virt->addr];
 121                 t1 = M[t3 + PROTNUM];
 122                 if (t1 == AINT || t1 == AREAL || t1 == AVIRT)
 123                         errsignal(RTEINCAS);
 124                 /* right hand side type */
 125                 t2 = M[tp];
 126                 if (t2 == FILETYPE) {
 127                         if (t1 != FILEOBJECT)
 128                                 errsignal(RTEINCAS);
 129                 }
 130                 else if (t2 == PURECOROUTINE || t2 == PUREPROCESS) {
 131                         if (t2 == PURECOROUTINE)
 132                                 knd = COROUTINE;
 133                         else
 134                                 knd = PROCESS;
 135
 136                         if (prototype[t1]->kind != knd)
 137                                 errsignal(RTEINCAS);
 138                 } else {
 139                         if (t2 != CLASSTYPE)
 140                                 errsignal(RTEINCAS);
 141                         if (!pref(t3, M[tp + 1]))
 142                                 errsignal(RTEINCAS);
 143                 }
 144         }
 145 }
 146
 147
 148 /**
 149  * Check correctness of a dynamic assignment
 150  */
 151 void typed(word ldim, word lt, word rdim, word rt, virtaddr *virt)
 152 {
 153         if (ldim != rdim)
 154                 errsignal(RTEINCAS);
 155
 156         if (ldim == 0)
 157                 typref(virt, lt);
 158         else if (lt != rt)
 159                 errsignal(RTEINCAS);
 160 }
 161
 162 /**
 163  * Search the SL chain of object am to find the nearest Y such that Y in A.
 164  * prot = prototype number of A
 165  */
 166 word loadt(word am, word prot)
 167 {
 168         word t1, t2, t3, t4;
 169
 170         while(!pref(am, prot)) {
 171                 t1 = am + M[am] + SL;
 172                 /* try next object in chain */
 173                 t2 = M[t1];
 174                 t3 = M[t1 + 1];
 175                 t4 = M[t2 + 1];
 176                 if(t3 != t4)
 177                         errsignal(RTEFTPMS);
 178                 am = M[t2];
 179         }
 180         return am;
 181 }
 182
 183
 184 /**
 185  * Compute type of a formal parameter - see also typep (below).
 186  */
 187 static bool typep0(word am, word pdaddr, bool protp, word *dim, word *tp)
 188 {
 189         word t1;
 190         protdescr *ptr;
 191
 192         /* prototype number on input */
 193         if (protp) {
 194                 ptr = prototype[pdaddr];
 195                 *dim = ptr->nrarray;
 196                 *tp = ptr->finaltype;
 197         } else {
 198                 /* type address on input */
 199                 *dim = M[pdaddr + 1];
 200                 *tp = M[pdaddr + 2];
 201         }
 202         if (M[*tp] != FORMTYPE)
 203                 return TRUE;
 204         else {
 205                 /* SL prototype number */
 206                 t1 = M[*tp + 1];
 207                 if (t1 == DUMMY)
 208                         return FALSE;
 209                 /* undefined */
 210                 else {
 211                         *tp = loadt(am, t1) + M[*tp + 2];
 212                         /* accumulate dim */
 213                         *dim += M[*tp];
 214                         *tp = M[*tp + 1];
 215                         /* AIL 1989.02.02 */
 216                         return TRUE;
 217                 }
 218         }
 219 }
 220
 221 /**
 222  * Compute type of formal parameter
 223  */
 224 void typep(word am, word nr, word *dim, word *tp)
 225 {
 226         if (!typep0(am, M[prototype[M[am + PROTNUM]]->pfdescr + nr], FALSE, dim,
 227                                                                         tp)) {
 228                 errsignal(RTESYSER);
 229         }
 230 }
 231
 232
 233 /* Auxiliary function for heads, almost the same as pref.
 234  */
 235
 236 static bool prefh(word tp, word prot)
 237 {
 238         word t1, t2;
 239         protdescr *ptr;
 240
 241         ptr = prototype[M[tp + 1]];
 242         t2 = ptr->preflist;
 243         t1 = t2 + ptr->lthpreflist - 1;
 244         do {
 245                 if (M[ t1 ] == prot)
 246                         return TRUE;
 247                 else
 248                         t1--;
 249         } while (t1 >= t2);
 250         return FALSE;
 251 }
 252
 253
 254 /**
 255  * Check compatibility of generalized types, used by heads only.
 256  */
 257 static bool typef(word dima, word ta, word dimb, word tb)
 258 {
 259         word t1, t2;
 260         int knd;
 261
 262         /* incompatible headers */
 263         if (dima != dimb)
 264                 errsignal(RTEINCHS);
 265
 266         /* types different somehow */
 267         if (ta != tb) {
 268                 /* dim must be 0 now */
 269                 if (dima != 0)
 270                         errsignal(RTEINCHS);
 271
 272                 t1 = M[ta];
 273                 t2 = M[tb];
 274
 275                 if (t1 == PRIMITIVETYPE || t1 == FILETYPE)
 276                         errsignal(RTEINCHS);
 277
 278                 if (t2 == PRIMITIVETYPE || t2 == FILETYPE)
 279                         errsignal(RTEINCHS);
 280
 281                 if (t1 != PURECOROUTINE && t1 != PUREPROCESS) {
 282                         if (t2 == PURECOROUTINE || t2 == PUREPROCESS)
 283                                 return TRUE;
 284                         else {
 285                                 if (!prefh(ta, M[tb + 1])) {
 286                                         if (!prefh(tb, M[ta + 1]))
 287                                                 errsignal(RTEINCHS);
 288                                         else
 289                                                 return TRUE;
 290                                 }
 291                         }
 292                 }
 293                 /* something pure */
 294                 else {
 295                         if (t1 != t2) {
 296                                 /* AIL: t1 below replaced with t2, 1989.02.02 */
 297                                 /* if (t1 == PURECOROUTINE || t1 == PUREPROCESS) */
 298                                 if (t2 == PURECOROUTINE || t2 == PUREPROCESS) {
 299                                         /* used as junk */
 300                                         knd = RECORD;
 301                                 }
 302                                 else
 303                                         knd = prototype[M[tb + 1]]->kind;
 304
 305                                 if ((t1 == PURECOROUTINE && knd != COROUTINE) ||
 306                                         (t1 == PUREPROCESS && knd != PROCESS)) {
 307
 308                                         if ((t1 != PURECOROUTINE) ||
 309                                                 (knd != PROCESS &&
 310                                                 t2 != PUREPROCESS)) {
 311
 312                                                 return TRUE;
 313                                         }
 314                                 }
 315                         }
 316                 }
 317         }
 318         return FALSE;
 319 }
 320
 321
 322 /**
 323  * Verify the compatibility of formal/actual procedure (function) heads.
 324  */
 325 void heads(virtaddr *virt, word nr)
 326 {
 327         word i, j, fp, gp, oba, g, slen, dim, t1, t2, tp, ftv;
 328         protdescr *ptr;
 329         bool junk;
 330         word x[MAXHDLEN + 1], y[MAXHDLEN + 1];
 331         /* The two arrays declared above may be dynamically generated as objects */
 332         /* upon entry to heads. In fact heads was implemented this way in the    */
 333         /* original LOGLAN running system on MERA-400                            */
 334
 335         oba = M[virt->addr];
 336         ptr = prototype[M[oba + PROTNUM]];
 337         /* parameter description pointer */
 338         fp = M[ptr->pfdescr + nr];
 339         /* length of its desclist */
 340         slen = M[fp + 2];
 341         if (slen > MAXHDLEN)
 342                 errsignal(RTEFHTLG);
 343         /* type value pointer */
 344         ftv = oba + M[ptr->parlist + nr];
 345         g = M[ftv];
 346         /* not none */
 347         if (M[ftv + 1] == M[g + 1 ]) {
 348                 /* am of SL */
 349                 g = M[g];
 350         }
 351         else {
 352                 /* SL chain cut off */
 353                 errsignal(RTESLCOF);
 354         }
 355         /* prototype number of g */
 356         gp = M[ftv + 2];
 357         ptr = prototype[gp];
 358         /* t2 = F-kind */
 359         t2 = M[fp];
 360         if (ptr->kind == FUNCTION) {
 361                 if (t2 != FORMFUNC)
 362                         errsignal(RTEINCHS);
 363
 364                 junk = typep0(g, gp, TRUE, &dim, &tp);
 365                 junk = typep0(oba, fp + 2, FALSE, &t1, &t2);
 366
 367                 if (typef(dim, tp, t1, t2))
 368                         errsignal(RTEINCHS);
 369         }
 370         else if (t2 != FORMPROC)
 371                 errsignal(RTEINCHS);
 372
 373         /* incompatible lengths */
 374         if (slen != ptr->lthparlist)
 375                 errsignal(RTEINCHS);
 376
 377         /* oba descriptlist */
 378         t1 = M[fp + 1] - 1;
 379         /* g   descriptlist */
 380         t2 = ptr->pfdescr - 1;
 381         /* verify second order lists */
 382         for (i = 1; i <= slen; i++ ) {
 383                 /* mark entry as empty */
 384                 x[i] = DUMMY;
 385                 y[i] = DUMMY;
 386
 387                 /* first type pointer */
 388                 fp = M[t1 + i];
 389                 /* second type pointer */
 390                 gp = M[t2 + i];
 391                 /* first type ordinal */
 392                 tp = M[fp];
 393                 if (tp != M[gp])
 394                         errsignal(RTEINCHS);
 395
 396                 if (tp == FORMTYPE) {
 397                         /* save pointers to formal types */
 398                         x[i] = fp;
 399                         y[i] = gp;
 400                 } else {
 401                         if (tp == PARIN || tp == PAROUT || tp == PARINOUT) {
 402                                 /* AIL 1989.02.02 */
 403                                 /* if (typep0(oba, fp, FALSE, &dim, &tp)) */
 404                                 if (! typep0(oba, fp, FALSE, &dim, &tp)) {
 405                                         /* undefined yet */
 406                                         /* search preceding formals */
 407                                         for (j = 1; j <= i;  j++)
 408                                                 if (x[j] == M[fp + 2])
 409                                                 break;
 410                                         if (j > i)
 411                                                 errsignal(RTEINCHS);
 412                                         if (y[j] != M[gp + 2])
 413                                                 errsignal(RTEINCHS);
 414                                 }
 415                                 /* already defined */
 416                                 else {
 417                                         for (j = 1; j <= i;  j++ )
 418                                                 if (y [j] == M[gp + 2])
 419                                                         errsignal(RTEINCHS);
 420
 421                                         junk = typep0(g, gp, FALSE, &j, &ftv);
 422                                         junk = typef(dim, tp, j, ftv);
 423                                 }
 424                         }
 425                 }
 426         }
 427 }
 428