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
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
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
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
19 contacts: Andrzej.Salwicki@univ-pau.fr
\r
22 LITA Departement d'Informatique
\r
24 Avenue de l'Universite
\r
26 tel. ++33 59923154 fax. ++33 59841696
\r
28 =======================================================================
\r
34 #include "process.h"
\r
35 #include "intproto.h"
\r
37 /* Type checking routines */
\r
40 /* Determine if prot occurs in the prefix sequence of object am
\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
50 static bool typep0();
\r
51 static bool prefh();
\r
52 static bool typef();
\r
56 static bool pref(am, prot)
\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
67 t2 = t1+ptr->lthpreflist;
\r
70 if (prot == M[ t1 ]) return (TRUE);
\r
78 void qua(virt, tp) /* Validate qualification of object */
\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
88 bool inl(virt, tp) /* Determine if A in B */
\r
92 if (virt->mark != M[ virt->addr+1 ])
\r
93 return (TRUE); /* none is in everything */
\r
95 if (M[ tp ] != CLASSTYPE) return (FALSE);
\r
96 else return (pref(M[ virt->addr ], M[ tp+1 ]));
\r
100 bool is(virt, tp) /* Determine if A is B */
\r
104 if (virt->mark != M[ virt->addr+1 ] || M[ tp ] != CLASSTYPE)
\r
106 else return (M[ M[ virt->addr ]+PROTNUM ] == M[ tp+1 ]);
\r
110 /* Check correctness of an especially clumsy assignment statement
\r
113 void typref(virt, tp)
\r
120 if (virt->mark == M[ virt->addr+1 ]) /* none always allowed */
\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
128 if (t1 != FILEOBJECT) errsignal(RTEINCAS);
\r
131 if (t2 == PURECOROUTINE || t2 == PUREPROCESS)
\r
133 if (t2 == PURECOROUTINE) knd = COROUTINE;
\r
134 else knd = PROCESS;
\r
135 if (prototype[ t1 ]->kind != knd) errsignal(RTEINCAS);
\r
139 if (t2 != CLASSTYPE) errsignal(RTEINCAS);
\r
140 if (!pref(t3, M[ tp+1 ])) errsignal(RTEINCAS);
\r
146 /* Check correctness of a dynamic assignment
\r
149 void typed(ldim, lt, rdim, rt, virt)
\r
150 word ldim, lt, rdim, rt;
\r
153 if (ldim != rdim) errsignal(RTEINCAS);
\r
154 if (ldim == 0) typref(virt, lt);
\r
156 if (lt != rt) errsignal(RTEINCAS);
\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
164 word loadt(am, prot)
\r
167 word t1, t2, t3, t4;
\r
169 while( !pref(am, prot) )
\r
171 t1 = am+M[ am ]+SL;
\r
172 t2 = M[ t1 ]; /* try next object in chain */
\r
175 if( t3 != t4 ) errsignal( RTEFTPMS );
\r
182 /* Compute type of a formal parameter - see also typep (below). */
\r
184 static bool typep0(am, pdaddr, protp, dim, tp)
\r
192 if (protp) /* prototype number on input */
\r
194 ptr = prototype[ pdaddr ];
\r
195 *dim = ptr->nrarray;
\r
196 *tp = ptr->finaltype;
\r
198 else /* type address on input */
\r
200 *dim = M[ pdaddr+1 ];
\r
201 *tp = M[ pdaddr+2 ];
\r
203 if (M[ *tp ] != FORMTYPE) return (TRUE);
\r
206 t1 = M[ *tp+1 ]; /* SL prototype number */
\r
207 if (t1 == DUMMY) return (FALSE);
\r
208 else /* undefined */
\r
210 *tp = loadt(am, t1)+M[ *tp+2 ];
\r
211 *dim += M[ *tp ]; /* accumulate dim */
\r
213 return (TRUE); /* AIL 1989.02.02 */
\r
219 void typep(am, nr, dim, tp) /* Compute type of formal parameter */
\r
223 if (!typep0(am, M[ prototype[ M[ am+PROTNUM ] ]->pfdescr+nr ],
\r
224 FALSE, dim, tp)) errsignal(RTESYSER);
\r
228 /* Auxiliary function for heads, almost the same as pref.
\r
231 static bool prefh(tp, prot)
\r
237 ptr = prototype[ M[ tp+1 ] ];
\r
238 t2 = ptr->preflist;
\r
239 t1 = t2+ptr->lthpreflist-1;
\r
242 if (M[ t1 ] == prot) return (TRUE);
\r
244 } while (t1 >= t2);
\r
249 /* Check compatibility of generalized types, used by heads only.
\r
252 static bool typef(dima, ta, dimb, tb)
\r
253 word dima, ta, dimb, tb;
\r
258 if (dima != dimb) errsignal(RTEINCHS); /* incompatible headers */
\r
259 if (ta != tb) /* types different somehow */
\r
261 if (dima != 0) errsignal(RTEINCHS); /* dim must be 0 now */
\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
268 if (t2 == PURECOROUTINE || t2 == PUREPROCESS) return (TRUE);
\r
271 if (!prefh(ta, M[ tb+1 ]))
\r
273 if (!prefh(tb, M[ ta+1 ])) errsignal(RTEINCHS);
\r
274 else return (TRUE);
\r
278 else /* something pure */
\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
288 if ((t1 == PURECOROUTINE && knd != COROUTINE) ||
\r
289 (t1 == PUREPROCESS && knd != PROCESS))
\r
291 if ((t1 != PURECOROUTINE) ||
\r
292 (knd != PROCESS && t2 != PUREPROCESS))
\r
302 /* Verify the compatibility of formal/actual procedure (function) heads.
\r
305 void heads(virt, nr)
\r
309 word i, j, fp, gp, oba, g, slen, dim, t1, t2, tp, ftv;
\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
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
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
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
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
345 x[ i ] = DUMMY; /* mark entry as empty */
\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
353 x[ i ] = fp; /* save pointers to formal types */
\r
358 if (tp == PARIN || tp == PAROUT || tp == PARINOUT)
\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
368 if (j > i) errsignal(RTEINCHS);
\r
369 if (y[ j ] != M[ gp+2 ]) errsignal(RTEINCHS);
\r
371 else /* already defined */
\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