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