1 /* Loglan82 Compiler&Interpreter
2 Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
3 Copyright (C) 1993, 1994 LITA, Pau
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.
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.
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.
19 contacts: Andrzej.Salwicki@univ-pau.fr
22 LITA Departement d'Informatique
24 Avenue de l'Universite
26 tel. ++33 59923154 fax. ++33 59841696
28 =======================================================================
37 /* Type checking routines */
40 /* Determine if prot occurs in the prefix sequence of object am
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);
56 static bool pref(am, prot)
63 if (t1 != AINT && t1 != AVIRT && t1 != AREAL && t1 != FILEOBJECT)
64 { /* neither array nor file */
65 ptr = prototype[ t1 ];
67 t2 = t1+ptr->lthpreflist;
70 if (prot == M[ t1 ]) return (TRUE);
78 void qua(virt, tp) /* Validate qualification of object */
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);
88 bool inl(virt, tp) /* Determine if A in B */
92 if (virt->mark != M[ virt->addr+1 ])
93 return (TRUE); /* none is in everything */
95 if (M[ tp ] != CLASSTYPE) return (FALSE);
96 else return (pref(M[ virt->addr ], M[ tp+1 ]));
100 bool is(virt, tp) /* Determine if A is B */
104 if (virt->mark != M[ virt->addr+1 ] || M[ tp ] != CLASSTYPE)
106 else return (M[ M[ virt->addr ]+PROTNUM ] == M[ tp+1 ]);
110 /* Check correctness of an especially clumsy assignment statement
113 void typref(virt, tp)
120 if (virt->mark == M[ virt->addr+1 ]) /* none always allowed */
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 */
128 if (t1 != FILEOBJECT) errsignal(RTEINCAS);
131 if (t2 == PURECOROUTINE || t2 == PUREPROCESS)
133 if (t2 == PURECOROUTINE) knd = COROUTINE;
135 if (prototype[ t1 ]->kind != knd) errsignal(RTEINCAS);
139 if (t2 != CLASSTYPE) errsignal(RTEINCAS);
140 if (!pref(t3, M[ tp+1 ])) errsignal(RTEINCAS);
146 /* Check correctness of a dynamic assignment
149 void typed(ldim, lt, rdim, rt, virt)
150 word ldim, lt, rdim, rt;
153 if (ldim != rdim) errsignal(RTEINCAS);
154 if (ldim == 0) typref(virt, lt);
156 if (lt != rt) errsignal(RTEINCAS);
160 /* Search the SL chain of object am to find the nearest Y such that Y in A.
161 * prot = prototype number of A
169 while( !pref(am, prot) )
172 t2 = M[ t1 ]; /* try next object in chain */
175 if( t3 != t4 ) errsignal( RTEFTPMS );
182 /* Compute type of a formal parameter - see also typep (below). */
184 static bool typep0(am, pdaddr, protp, dim, tp)
192 if (protp) /* prototype number on input */
194 ptr = prototype[ pdaddr ];
196 *tp = ptr->finaltype;
198 else /* type address on input */
200 *dim = M[ pdaddr+1 ];
203 if (M[ *tp ] != FORMTYPE) return (TRUE);
206 t1 = M[ *tp+1 ]; /* SL prototype number */
207 if (t1 == DUMMY) return (FALSE);
210 *tp = loadt(am, t1)+M[ *tp+2 ];
211 *dim += M[ *tp ]; /* accumulate dim */
213 return (TRUE); /* AIL 1989.02.02 */
219 void typep(am, nr, dim, tp) /* Compute type of formal parameter */
223 if (!typep0(am, M[ prototype[ M[ am+PROTNUM ] ]->pfdescr+nr ],
224 FALSE, dim, tp)) errsignal(RTESYSER);
228 /* Auxiliary function for heads, almost the same as pref.
231 static bool prefh(tp, prot)
237 ptr = prototype[ M[ tp+1 ] ];
239 t1 = t2+ptr->lthpreflist-1;
242 if (M[ t1 ] == prot) return (TRUE);
249 /* Check compatibility of generalized types, used by heads only.
252 static bool typef(dima, ta, dimb, tb)
253 word dima, ta, dimb, tb;
258 if (dima != dimb) errsignal(RTEINCHS); /* incompatible headers */
259 if (ta != tb) /* types different somehow */
261 if (dima != 0) errsignal(RTEINCHS); /* dim must be 0 now */
264 if (t1 == PRIMITIVETYPE || t1 == FILETYPE) errsignal(RTEINCHS);
265 if (t2 == PRIMITIVETYPE || t2 == FILETYPE) errsignal(RTEINCHS);
266 if (t1 != PURECOROUTINE && t1 != PUREPROCESS)
268 if (t2 == PURECOROUTINE || t2 == PUREPROCESS) return (TRUE);
271 if (!prefh(ta, M[ tb+1 ]))
273 if (!prefh(tb, M[ ta+1 ])) errsignal(RTEINCHS);
278 else /* something pure */
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;
288 if ((t1 == PURECOROUTINE && knd != COROUTINE) ||
289 (t1 == PUREPROCESS && knd != PROCESS))
291 if ((t1 != PURECOROUTINE) ||
292 (knd != PROCESS && t2 != PUREPROCESS))
302 /* Verify the compatibility of formal/actual procedure (function) heads.
309 word i, j, fp, gp, oba, g, slen, dim, t1, t2, tp, ftv;
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 */
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 */
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)
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);
338 if (t2 != FORMPROC) errsignal(RTEINCHS);
339 if (slen != ptr->lthparlist) /* incompatible lengths */
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 */
345 x[ i ] = DUMMY; /* mark entry as empty */
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);
353 x[ i ] = fp; /* save pointers to formal types */
358 if (tp == PARIN || tp == PAROUT || tp == PARINOUT)
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 ])
368 if (j > i) errsignal(RTEINCHS);
369 if (y[ j ] != M[ gp+2 ]) errsignal(RTEINCHS);
371 else /* already defined */
373 for (j = 1; j <= i; j++ )
374 if (y [ j ] == M[ gp+2 ])
376 junk = typep0(g, gp, FALSE, &j, &ftv);
377 junk = typef(dim, tp, j, ftv);