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