sources/int/typchk.c

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