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(word am, word prot)
62 if (t1 != AINT && t1 != AVIRT && t1 != AREAL && t1 != FILEOBJECT) {
63 /* neither array nor file */
66 t2 = t1 + ptr->lthpreflist;
76 /* Validate qualification of object */
77 void qua(virtaddr *virt, word tp)
79 if (virt->mark != M[virt->addr + 1])
81 if (M[tp] != CLASSTYPE)
83 if (!pref(M[virt->addr], M[tp + 1]))
87 /* Determine if A in B */
88 bool inl(virtaddr *virt, word tp)
90 /* none is in everything */
91 if (virt->mark != M[virt->addr + 1])
93 else if (M[tp] != CLASSTYPE)
96 return pref(M[virt->addr], M[tp + 1]);
99 /* Determine if A is B */
100 bool is(virtaddr *virt, word tp)
102 if (virt->mark != M[virt->addr + 1] || M[tp] != CLASSTYPE)
105 return (M[M[virt->addr] + PROTNUM] == M[tp + 1]);
110 * Check correctness of an especially clumsy assignment statement
112 void typref(virtaddr *virt, word tp)
117 /* none always allowed */
118 if (virt->mark == M[virt->addr + 1]) {
119 /* am of right hand side */
121 t1 = M[t3 + PROTNUM];
122 if (t1 == AINT || t1 == AREAL || t1 == AVIRT)
124 /* right hand side type */
126 if (t2 == FILETYPE) {
127 if (t1 != FILEOBJECT)
130 else if (t2 == PURECOROUTINE || t2 == PUREPROCESS) {
131 if (t2 == PURECOROUTINE)
136 if (prototype[t1]->kind != knd)
141 if (!pref(t3, M[tp + 1]))
149 * Check correctness of a dynamic assignment
151 void typed(word ldim, word lt, word rdim, word rt, virtaddr *virt)
163 * Search the SL chain of object am to find the nearest Y such that Y in A.
164 * prot = prototype number of A
166 word loadt(word am, word prot)
170 while(!pref(am, prot)) {
171 t1 = am + M[am] + SL;
172 /* try next object in chain */
185 * Compute type of a formal parameter - see also typep (below).
187 static bool typep0(word am, word pdaddr, bool protp, word *dim, word *tp)
192 /* prototype number on input */
194 ptr = prototype[pdaddr];
196 *tp = ptr->finaltype;
198 /* type address on input */
199 *dim = M[pdaddr + 1];
202 if (M[*tp] != FORMTYPE)
205 /* SL prototype number */
211 *tp = loadt(am, t1) + M[*tp + 2];
222 * Compute type of formal parameter
224 void typep(word am, word nr, word *dim, word *tp)
226 if (!typep0(am, M[prototype[M[am + PROTNUM]]->pfdescr + nr], FALSE, dim,
233 /* Auxiliary function for heads, almost the same as pref.
236 static bool prefh(word tp, word prot)
241 ptr = prototype[M[tp + 1]];
243 t1 = t2 + ptr->lthpreflist - 1;
255 * Check compatibility of generalized types, used by heads only.
257 static bool typef(word dima, word ta, word dimb, word tb)
262 /* incompatible headers */
266 /* types different somehow */
268 /* dim must be 0 now */
275 if (t1 == PRIMITIVETYPE || t1 == FILETYPE)
278 if (t2 == PRIMITIVETYPE || t2 == FILETYPE)
281 if (t1 != PURECOROUTINE && t1 != PUREPROCESS) {
282 if (t2 == PURECOROUTINE || t2 == PUREPROCESS)
285 if (!prefh(ta, M[tb + 1])) {
286 if (!prefh(tb, M[ta + 1]))
296 /* AIL: t1 below replaced with t2, 1989.02.02 */
297 /* if (t1 == PURECOROUTINE || t1 == PUREPROCESS) */
298 if (t2 == PURECOROUTINE || t2 == PUREPROCESS) {
303 knd = prototype[M[tb + 1]]->kind;
305 if ((t1 == PURECOROUTINE && knd != COROUTINE) ||
306 (t1 == PUREPROCESS && knd != PROCESS)) {
308 if ((t1 != PURECOROUTINE) ||
310 t2 != PUREPROCESS)) {
323 * Verify the compatibility of formal/actual procedure (function) heads.
325 void heads(virtaddr *virt, word nr)
327 word i, j, fp, gp, oba, g, slen, dim, t1, t2, tp, ftv;
330 word x[MAXHDLEN + 1], y[MAXHDLEN + 1];
331 /* The two arrays declared above may be dynamically generated as objects */
332 /* upon entry to heads. In fact heads was implemented this way in the */
333 /* original LOGLAN running system on MERA-400 */
336 ptr = prototype[M[oba + PROTNUM]];
337 /* parameter description pointer */
338 fp = M[ptr->pfdescr + nr];
339 /* length of its desclist */
343 /* type value pointer */
344 ftv = oba + M[ptr->parlist + nr];
347 if (M[ftv + 1] == M[g + 1 ]) {
352 /* SL chain cut off */
355 /* prototype number of g */
360 if (ptr->kind == FUNCTION) {
364 junk = typep0(g, gp, TRUE, &dim, &tp);
365 junk = typep0(oba, fp + 2, FALSE, &t1, &t2);
367 if (typef(dim, tp, t1, t2))
370 else if (t2 != FORMPROC)
373 /* incompatible lengths */
374 if (slen != ptr->lthparlist)
377 /* oba descriptlist */
380 t2 = ptr->pfdescr - 1;
381 /* verify second order lists */
382 for (i = 1; i <= slen; i++ ) {
383 /* mark entry as empty */
387 /* first type pointer */
389 /* second type pointer */
391 /* first type ordinal */
396 if (tp == FORMTYPE) {
397 /* save pointers to formal types */
401 if (tp == PARIN || tp == PAROUT || tp == PARINOUT) {
403 /* if (typep0(oba, fp, FALSE, &dim, &tp)) */
404 if (! typep0(oba, fp, FALSE, &dim, &tp)) {
406 /* search preceding formals */
407 for (j = 1; j <= i; j++)
408 if (x[j] == M[fp + 2])
412 if (y[j] != M[gp + 2])
415 /* already defined */
417 for (j = 1; j <= i; j++ )
418 if (y [j] == M[gp + 2])
421 junk = typep0(g, gp, FALSE, &j, &ftv);
422 junk = typef(dim, tp, j, ftv);