DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / gpcp-linux.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Remove batch
[gpcp-linux.git] / gpcp / TypeDesc.cp
1 (* ==================================================================== *)
2 (* *)
3 (* TypeDesc Module for the Gardens Point Component Pascal Compiler. *)
4 (* Implements type descriptors that are extensions of Symbols.Type *)
5 (* *)
6 (* Copyright (c) John Gough 1999, 2000. *)
7 (* version 1.1.4 2002:Jan:14 *)
8 (* *)
9 (* ==================================================================== *)
10
11 MODULE TypeDesc;
12
13 IMPORT
14 GPCPcopyright,
15 Console,
16 GPText,
17 VarSets,
18 NameHash,
19 FileNames,
20 CSt := CompState,
21 Id := IdDesc,
22 Sy := Symbols,
23 Lv := LitValue,
24 S := CPascalS,
25 H := DiagHelper,
26 RTS;
27
28 (* ============================================================ *)
29
30 CONST (* type-kinds *)
31 basTp* = Sy.standard;
32 tmpTp* = 1; namTp* = 2; arrTp* = 3;
33 recTp* = 4; ptrTp* = 5; prcTp* = 6;
34 enuTp* = 7; evtTp* = 8; ovlTp* = 9;
35 vecTp* = 10;
36
37 CONST (* base-ordinals *)
38 (* WARNING: these are locked in. If they are changed, there *)
39 (* is a consequential change in CPJrts for the JVM version. *)
40 notBs = 0;
41 boolN* = 1;
42 sChrN* = 2; charN* = 3;
43 byteN* = 4; sIntN* = 5; intN* = 6; lIntN* = 7;
44 sReaN* = 8; realN* = 9;
45 setN* = 10;
46 anyRec* = 11; anyPtr* = 12;
47 strN* = 13; sStrN* = 14; uBytN* = 15;
48 metaN* = 16;
49
50 CONST (* record attributes *)
51 noAtt* = 0; isAbs* = 1; limit* = 2;
52 extns* = 3; iFace* = 4;
53 cmpnd* = 5; (* Marker for Compound Types *)
54 noNew* = 8; (* These two attributes are really for xAttr, *)
55 valRc* = 16; (* but piggy-back on recAtt in the symbolfile *)
56 clsRc* = 32; (* but piggy-back on recAtt in the symbolfile *)
57
58 (* ============================================================ *)
59
60 CONST (* traversal depth markers *)
61 initialMark = 0;
62 finishMark = -1;
63 errorMark = 0FFFFFH;
64
65 (* ============================================================ *)
66
67 (* ------------------------------------------------------- *
68 * Overloadeds do not occur in pure Component Pascal. *
69 * They appear transiently as descriptors of types of *
70 * idents bound to overloaded members from foriegn libs. *
71 * ------------------------------------------------------- *)
72 TYPE
73 Overloaded* = POINTER TO EXTENSIBLE RECORD (Sy.Type)
74 (* ... inherited from Type ... ------------- *
75 * idnt* : Idnt; (* Id of typename *)
76 * kind- : INTEGER; (* tag for unions *)
77 * serial- : INTEGER; (* type serial-nm *)
78 * force* : INTEGER; (* force sym-emit *)
79 * xName* : Lv.CharOpen; (* proc signature *)
80 * dump*,depth* : INTEGER; (* scratch loc'ns *)
81 * tgXtn* : ANYPTR; (* target stuff *)
82 * ----------------------------------------- *)
83 END;
84
85 (* ============================================================ *)
86
87 TYPE
88 Base* = POINTER TO RECORD (Sy.Type)
89 (* ... inherited from Type ... ------------- *
90 * idnt* : Idnt; (* Id of typename *)
91 * kind- : INTEGER; (* tag for unions *)
92 * serial- : INTEGER; (* type serial-nm *)
93 * force* : INTEGER; (* force sym-emit *)
94 * xName* : Lv.CharOpen; (* full ext name *)
95 * dump*,depth* : INTEGER; (* scratch loc'ns *)
96 * tgXtn* : ANYPTR; (* target stuff *)
97 * ----------------------------------------- *)
98 tpOrd* : INTEGER;
99 END; (* ------------------------------ *)
100
101 (* ============================================================ *)
102
103 VAR anyRecTp- : Base; (* Descriptor for the base type ANYREC. *)
104 anyPtrTp- : Base; (* Descriptor for the base type ANYPTR. *)
105 integerT* : Sy.Type;
106 nilStr : Lv.CharOpen;
107
108 (* ============================================================ *)
109
110 TYPE
111 Opaque* = POINTER TO RECORD (Sy.Type)
112 (* ... inherited from Type ... ------------- *
113 * idnt* : Idnt; (* Id of typename *)
114 * kind- : INTEGER; (* tag for unions *)
115 * serial- : INTEGER; (* type serial-nm *)
116 * force* : INTEGER; (* force sym-emit *)
117 * xName* : Lv.CharOpen; (* full ext name *)
118 * dump*,depth* : INTEGER; (* scratch loc'ns *)
119 * tgXtn* : ANYPTR; (* target stuff *)
120 * ----------------------------------------- *)
121 resolved* : Sy.Type; (* ptr to real-Tp *)
122 scopeNm* : Lv.CharOpen;
123 END; (* ------------------------------ *)
124
125 (* ============================================================ *)
126
127 TYPE
128 Array* = POINTER TO EXTENSIBLE RECORD (Sy.Type)
129 (* ... inherited from Type ... ------------- *
130 * idnt* : Idnt; (* Id of typename *)
131 * kind- : INTEGER; (* tag for unions *)
132 * serial- : INTEGER; (* type serial-nm *)
133 * force* : INTEGER; (* force sym-emit *)
134 * xName* : Lv.CharOpen; (* full ext name *)
135 * dump*,depth* : INTEGER; (* scratch loc'ns *)
136 * tgXtn* : ANYPTR; (* target stuff *)
137 * ----------------------------------------- *)
138 elemTp* : Sy.Type; (* element tpDesc *)
139 length* : INTEGER; (* 0 for open-arr *)
140 END; (* ------------------------------ *)
141
142 (* ============================================================ *)
143
144 TYPE
145 Vector* = POINTER TO RECORD (Array)
146 (* ... inherited from Type ... ------------- *
147 * idnt* : Idnt; (* Id of typename *)
148 * kind- : INTEGER; (* tag for unions *)
149 * serial- : INTEGER; (* type serial-nm *)
150 * force* : INTEGER; (* force sym-emit *)
151 * xName* : Lv.CharOpen; (* full ext name *)
152 * dump*,depth* : INTEGER; (* scratch loc'ns *)
153 * tgXtn* : ANYPTR; (* target stuff *)
154 * ... inherited from Array ... ------------ *
155 * elemTp* : Sy.Type; (* element tpDesc *)
156 * length* : INTEGER; (* unused for Vec *)
157 * ----------------------------------------- *)
158 END; (* ------------------------------ *)
159
160 (* ============================================================ *)
161
162 TYPE
163 (* ====================================================== *
164 * When should a record type be implemented as a *
165 * reference class? When any of the following is true:- *
166 * > It is extensible or abstract *
167 * > It extends a type other than System.ValueType *
168 * > It has an embedded non-value structure *
169 * > It is only declared as a pointer target *
170 * > If the target does not support value records *
171 * ====================================================== *)
172 Record* = POINTER TO RECORD (Sy.Type)
173 (* ... inherited from Type ... ------------- *
174 * idnt* : Idnt; (* Id of typename *)
175 * kind- : INTEGER; (* tag for unions *)
176 * serial- : INTEGER; (* type serial-nm *)
177 * force* : INTEGER; (* force sym-emit *)
178 * xName* : Lv.CharOpen; (* full ext name *)
179 * dump*,depth* : INTEGER; (* scratch loc'ns *)
180 * tgXtn* : ANYPTR; (* target stuff *)
181 * ----------------------------------------- *)
182 baseTp* : Sy.Type; (* immediate base *)
183 bindTp* : Sy.Type; (* ptrTo if anon. *)
184 encCls* : Sy.Type; (* if nested cls. *)
185 recAtt* : INTEGER;
186 symTb* : Sy.SymbolTable;
187 extrnNm* : Lv.CharOpen;
188 scopeNm* : Lv.CharOpen;
189 fields* : Sy.IdSeq; (* list of fields *)
190 methods* : Sy.IdSeq; (* list of meth's *)
191 statics* : Sy.IdSeq; (* list of stat's *)
192 interfaces* : Sy.TypeSeq;(* impl-sequence *)
193 events* : Sy.IdSeq; (* event-sequence *)
194 xAttr* : SET; (* external attrs *)
195 END; (* ------------------------------ *)
196
197 (* ============================================================ *)
198
199 TYPE
200 Enum* = POINTER TO RECORD (Sy.Type)
201 (* ... inherited from Type ... ------------- *
202 * idnt* : Idnt; (* Id of typename *)
203 * kind- : INTEGER; (* tag for unions *)
204 * serial- : INTEGER; (* type serial-nm *)
205 * force* : INTEGER; (* force sym-emit *)
206 * xName* : Lv.CharOpen; (* full ext name *)
207 * dump*,depth* : INTEGER; (* scratch loc'ns *)
208 * tgXtn* : ANYPTR; (* target stuff *)
209 * ----------------------------------------- *)
210 symTb* : Sy.SymbolTable;
211 statics* : Sy.IdSeq; (* list of stat's *)
212 END; (* ------------------------------ *)
213
214 (* ============================================================ *)
215
216 TYPE
217 Pointer* = POINTER TO EXTENSIBLE RECORD (Sy.Type)
218 (* ... inherited from Type ... ------------- *
219 * idnt* : Idnt; (* Id of typename *)
220 * kind- : INTEGER; (* tag for unions *)
221 * serial- : INTEGER; (* type serial-nm *)
222 * force* : INTEGER; (* force sym-emit *)
223 * xName* : Lv.CharOpen; (* full ext name *)
224 * dump*,depth* : INTEGER; (* scratch loc'ns *)
225 * tgXtn* : ANYPTR; (* target stuff *)
226 * ----------------------------------------- *)
227 boundTp* : Sy.Type; (* ptr bound type *)
228 END; (* ------------------------------ *)
229
230 (* ============================================================ *)
231
232 TYPE
233 Procedure* = POINTER TO EXTENSIBLE RECORD (Sy.Type)
234 (* ... inherited from Type ... ------------- *
235 * idnt* : Idnt; (* Id of typename *)
236 * kind- : INTEGER; (* tag for unions *)
237 * serial- : INTEGER; (* type serial-nm *)
238 * force* : INTEGER; (* force sym-emit *)
239 * xName* : Lv.CharOpen; (* proc signature *)
240 * dump*,depth* : INTEGER; (* scratch loc'ns *)
241 * tgXtn* : ANYPTR; (* target stuff *)
242 * ----------------------------------------- *)
243 tName* : Lv.CharOpen;(* proc-type name *)
244 retType* : Sy.Type; (* ret-type | NIL *)
245 receiver* : Sy.Type; (* element tpDesc *)
246 formals* : Id.ParSeq; (* formal params *)
247 hostClass*: Record; (* host classType *)
248 retN*,argN* : INTEGER;
249 END; (* ------------------------------ *)
250
251 (* ============================================================ *)
252
253 TYPE
254 Event* = POINTER TO RECORD (Procedure)
255 (* ... inherited from Type ... ------------- *
256 * xName* : Lv.CharOpen; (* proc signature *)
257 * tName* : Lv.CharOpen; (* proc-type name *)
258 * tgXtn* : ANYPTR; (* target stuff *)
259 * ----------------------------------------- *
260 * ... inherited from Procedure ... -------- *
261 * tName* : Lv.CharOpen;(* proc-type name *)
262 * retType* : Sy.Type; (* ret-type | NIL *)
263 * receiver* : Sy.Type; (* element tpDesc *)
264 * formals* : Id.ParSeq; (* formal params *)
265 * retN*,argN* : INTEGER;
266 * ----------------------------------------- *)
267 bndRec- : Record;
268 END;
269
270 (* ============================================================ *)
271 (* Predicates on Type extensions *)
272 (* ============================================================ *)
273
274 PROCEDURE (t : Base)isBooleanType*() : BOOLEAN;
275 BEGIN RETURN t.tpOrd = boolN END isBooleanType;
276
277 (* -------------------------------------------- *)
278
279 PROCEDURE (t : Base)isNumType*() : BOOLEAN;
280 BEGIN
281 RETURN
282 (t.tpOrd <= realN) & (t.tpOrd >= byteN) OR (t.tpOrd = uBytN);
283 END isNumType;
284
285 PROCEDURE (t : Enum)isNumType*() : BOOLEAN;
286 BEGIN RETURN TRUE END isNumType;
287
288
289 (* -------------------------------------------- *)
290
291 PROCEDURE (t : Base)isBaseType*() : BOOLEAN;
292 BEGIN RETURN TRUE END isBaseType;
293
294 (* -------------------------------------------- *)
295
296 PROCEDURE (t : Base)isIntType*() : BOOLEAN;
297 BEGIN
298 RETURN
299 (t.tpOrd <= lIntN) & (t.tpOrd >= byteN) OR (t.tpOrd = uBytN);
300 END isIntType;
301
302 PROCEDURE (t : Enum)isIntType*() : BOOLEAN;
303 BEGIN RETURN TRUE END isIntType;
304
305 (* -------------------------------------------- *)
306
307 PROCEDURE (t : Base)isScalarType*() : BOOLEAN;
308 BEGIN RETURN t.tpOrd # anyRec END isScalarType;
309
310 PROCEDURE (t : Enum)isScalarType*() : BOOLEAN;
311 BEGIN RETURN TRUE END isScalarType;
312
313 PROCEDURE (t : Array)isScalarType*() : BOOLEAN, EXTENSIBLE;
314 BEGIN RETURN FALSE END isScalarType;
315
316 PROCEDURE (t : Vector)isScalarType*() : BOOLEAN;
317 BEGIN RETURN TRUE END isScalarType;
318
319 PROCEDURE (t : Record)isScalarType*() : BOOLEAN;
320 BEGIN RETURN FALSE END isScalarType;
321
322 (* -------------------------------------------- *)
323
324 PROCEDURE (t : Record)isImportedType*() : BOOLEAN;
325 BEGIN
326 IF t.bindTp # NIL THEN
327 RETURN t.bindTp.isImportedType();
328 ELSE
329 RETURN (t.idnt # NIL) & (t.idnt.dfScp # NIL) & t.idnt.dfScp.isImport();
330 END;
331 END isImportedType;
332
333 (* -------------------------------------------- *)
334
335 PROCEDURE (t : Base)isSetType*() : BOOLEAN;
336 BEGIN RETURN t.tpOrd = setN END isSetType;
337
338 (* -------------------------------------------- *)
339
340 PROCEDURE (t : Base)isRealType*() : BOOLEAN;
341 BEGIN RETURN (t.tpOrd = realN) OR (t.tpOrd = sReaN) END isRealType;
342
343 (* -------------------------------------------- *)
344
345 PROCEDURE (t : Base)isCharType*() : BOOLEAN;
346 BEGIN RETURN (t.tpOrd = charN) OR (t.tpOrd = sChrN) END isCharType;
347
348 (* -------------------------------------------- *)
349
350 PROCEDURE (t : Base)isNativeObj*() : BOOLEAN;
351 BEGIN RETURN (t = anyRecTp) OR (t = anyPtrTp) END isNativeObj;
352
353 (* -------------------------------------------- *)
354
355 PROCEDURE (t : Pointer)isNativeObj*() : BOOLEAN;
356 BEGIN RETURN t = CSt.ntvObj END isNativeObj;
357
358 PROCEDURE (t : Pointer)isNativeStr*() : BOOLEAN;
359 BEGIN RETURN t = CSt.ntvStr END isNativeStr;
360
361 PROCEDURE (t : Pointer)isNativeExc*() : BOOLEAN;
362 BEGIN RETURN t = CSt.ntvExc END isNativeExc;
363
364 (* -------------------------------------------- *)
365
366 PROCEDURE (t : Record)isNativeObj*() : BOOLEAN;
367 BEGIN RETURN t = CSt.ntvObj(Pointer).boundTp END isNativeObj;
368
369 PROCEDURE (t : Record)isNativeStr*() : BOOLEAN;
370 BEGIN RETURN t = CSt.ntvStr(Pointer).boundTp END isNativeStr;
371
372 PROCEDURE (t : Record)isNativeExc*() : BOOLEAN;
373 BEGIN RETURN t = CSt.ntvExc(Pointer).boundTp END isNativeExc;
374
375 (* -------------------------------------------- *)
376
377 PROCEDURE (t : Base)isStringType*() : BOOLEAN;
378 BEGIN RETURN (t.tpOrd = strN) OR (t.tpOrd = sStrN) END isStringType;
379
380 PROCEDURE (t : Pointer)isStringType*() : BOOLEAN;
381 BEGIN RETURN t = CSt.ntvStr END isStringType;
382
383 PROCEDURE (t : Record)isStringType*() : BOOLEAN;
384 BEGIN RETURN t = CSt.ntvStr(Pointer).boundTp END isStringType;
385
386 (* -------------------------------------------- *)
387
388 PROCEDURE (t : Pointer)nativeCompat*() : BOOLEAN;
389 BEGIN RETURN (t = CSt.ntvStr) OR (t = CSt.ntvObj) END nativeCompat;
390
391 (* -------------------------------------------- *)
392
393 PROCEDURE (t : Array)isCharArrayType*() : BOOLEAN;
394 BEGIN RETURN (t.elemTp # NIL) & t.elemTp.isCharType() END isCharArrayType;
395
396 (* -------------------------------------------- *)
397
398 PROCEDURE (t : Pointer)isDynamicType*() : BOOLEAN;
399 (** A type is dynamic if it is a pointer to any *
400 * record. Overrides isDynamicType method in Symbols.Type. *)
401 BEGIN RETURN (t.boundTp # NIL) & (t.boundTp IS Record) END isDynamicType;
402
403 (* -------------------------------------------- *)
404
405 PROCEDURE (t : Base)isPointerType*() : BOOLEAN;
406 BEGIN RETURN t.tpOrd = anyPtr END isPointerType;
407
408 (* -------------------------------------------- *)
409
410 PROCEDURE (t : Pointer)isPointerType*() : BOOLEAN;
411 BEGIN RETURN TRUE END isPointerType;
412
413 (* -------------------------------------------- *)
414
415 PROCEDURE (t : Record)isRecordType*() : BOOLEAN;
416 BEGIN RETURN TRUE END isRecordType;
417
418 (* -------------------------------------------- *)
419
420 PROCEDURE (t : Procedure)isProcType*() : BOOLEAN;
421 BEGIN RETURN TRUE END isProcType;
422
423 (* -------------------------------------------- *)
424
425 PROCEDURE (t : Base)isProcType*() : BOOLEAN;
426 BEGIN RETURN t.tpOrd = anyPtr END isProcType;
427
428 (* -------------------------------------------- *)
429
430 PROCEDURE (t : Base)isDynamicType*() : BOOLEAN;
431 BEGIN RETURN t.tpOrd = anyPtr END isDynamicType;
432
433 (* -------------------------------------------- *)
434
435 PROCEDURE (t : Procedure)isProperProcType*() : BOOLEAN;
436 BEGIN RETURN t.retType = NIL END isProperProcType;
437
438 (* -------------------------------------------- *)
439
440 PROCEDURE (t : Procedure)returnType*() : Sy.Type;
441 BEGIN RETURN t.retType END returnType;
442
443 (* -------------------------------------------- *)
444
445 PROCEDURE (t : Record)isAbsRecType*() : BOOLEAN;
446 (** A record is absolute if it is declared to be an absolute *
447 * record, or is a compound type. *
448 * Overrides isAbsRecType method in Symbols.Type. *)
449 BEGIN
450 RETURN (isAbs = t.recAtt) OR
451 (iFace = t.recAtt) OR
452 (cmpnd = t.recAtt);
453 END isAbsRecType;
454
455 (* -------------------------------------------- *)
456
457 PROCEDURE (t : Record)isExtnRecType*() : BOOLEAN;
458 (** A record is extensible if declared absolute or extensible *
459 * record. Overrides isExtnRecType method in Symbols.Type. *)
460 BEGIN
461 RETURN (extns = t.recAtt) OR (isAbs = t.recAtt);
462 END isExtnRecType;
463
464 (* -------------------------------------------- *)
465
466 PROCEDURE (t : Base)isExtnRecType*() : BOOLEAN;
467 (** A base type is extensible if it is ANYREC or ANYPTR *
468 * Overrides isExtnRecType method in Symbols.Type. *)
469 BEGIN
470 RETURN t.tpOrd = anyRec;
471 END isExtnRecType;
472
473 (* -------------------------------------------- *)
474
475 PROCEDURE (t : Record)isLimRecType*() : BOOLEAN;
476 (** A record is limited if it is declared to be limited *
477 * record. Overrides isLimRec method in Symbols.Type. *)
478 BEGIN RETURN limit = t.recAtt END isLimRecType;
479
480 (* -------------------------------------------- *)
481
482 PROCEDURE (t : Array)isOpenArrType*() : BOOLEAN;
483 BEGIN RETURN (t.kind = arrTp) & (t.length = 0) END isOpenArrType;
484
485 PROCEDURE (t : Vector)isVectorType*() : BOOLEAN;
486 BEGIN RETURN TRUE END isVectorType;
487
488 (* -------------------------------------------- *)
489
490 PROCEDURE (t : Base)needsInit*() : BOOLEAN;
491 BEGIN RETURN FALSE END needsInit;
492
493 (* -------------------------------------------- *)
494
495 PROCEDURE (t : Base)isLongType*() : BOOLEAN;
496 BEGIN RETURN (t.tpOrd = realN) OR (t.tpOrd = lIntN) END isLongType;
497
498 (* -------------------------------------------- *)
499
500 PROCEDURE (r : Record)compoundCompat*(e : Sy.Type) : BOOLEAN, NEW;
501 (** Returns TRUE iff e is a type that could possibly be assignment
502 * compatible with the compound type r (i.e. r := e).
503 * If e is an extensible record type, it is sufficient that
504 * its base type is a subtype of the base type of r.
505 * Because the type is extensible, compatibility may not
506 * be determinable statically. Assertions may need to be
507 * inserted to determine compatibility at runtime.
508 * If e is not extensible then it must be a subtype of the
509 * base type of r and implement all of the interfaces of
510 * r. *)
511 BEGIN
512 ASSERT(r.isCompoundType());
513 (* Not compatible if r is not a base of e *)
514 IF (~r.isBaseOf(e)) THEN RETURN FALSE END;
515 (* Dynamically compatible if e is an extensible record type *)
516 IF (e.isExtnRecType()) THEN RETURN TRUE END;
517 (* d is not extensible. It must support all of r's interfaces
518 * statically *)
519 RETURN e.implementsAll(r);
520 END compoundCompat;
521
522 (* -------------------------------------------- *)
523
524 PROCEDURE (b : Base)includes*(x : Sy.Type) : BOOLEAN;
525 VAR xBas : Base;
526 xOrd : INTEGER;
527 bOrd : INTEGER;
528 BEGIN
529 IF x IS Enum THEN x := integerT;
530 ELSIF ~(x IS Base) THEN RETURN FALSE;
531 END;
532
533 xBas := x(Base);
534 xOrd := xBas.tpOrd;
535 bOrd := b.tpOrd;
536 CASE bOrd OF
537 | uBytN, byteN, sChrN : (* only equality here *)
538 RETURN xOrd = bOrd;
539 (*
540 * | byteN : (* only equality here *)
541 * RETURN xOrd = bOrd;
542 * | uBytN, sChrN : (* only equality here *)
543 * RETURN (xOrd = uBytN) OR (xOrd = sChrN);
544 *)
545 | charN :
546 RETURN (xOrd = charN) OR (xOrd = sChrN) OR (xOrd = uBytN);
547 | sIntN .. realN :
548 RETURN (xOrd <= bOrd) & (xOrd >= byteN) OR (xOrd = uBytN);
549 ELSE
550 RETURN FALSE;
551 END;
552 END includes;
553
554 PROCEDURE (b : Enum)includes*(x : Sy.Type) : BOOLEAN;
555 VAR xBas : Base;
556 BEGIN
557 RETURN integerT.includes(x);
558 END includes;
559
560 (* -------------------------------------------- *)
561
562 PROCEDURE (b : Base)isBaseOf*(e : Sy.Type) : BOOLEAN;
563 (** Find if e is an extension of base type b. *
564 * Overrides the isBaseOf method in Symbols.Type *)
565 BEGIN
566 IF e.kind = recTp THEN RETURN b.tpOrd = anyRec;
567 ELSIF e.kind = ptrTp THEN RETURN b.tpOrd = anyPtr;
568 ELSE (* all others *) RETURN b = e;
569 END;
570 END isBaseOf;
571
572 (* -------------------------------------------- *)
573
574 PROCEDURE (b : Record)isBaseOf*(e : Sy.Type) : BOOLEAN;
575 (** Find if e is an extension of record type b. *
576 * Overrides the isBaseOf method in Symbols.Type *)
577 VAR ext : Record;
578 i : INTEGER;
579 BEGIN
580 IF e # NIL THEN e := e.boundRecTp() END;
581
582 IF (e = NIL) OR (e.kind # recTp) THEN RETURN FALSE;
583 ELSIF e = b THEN RETURN TRUE; (* Trivially! *)
584 END; (* Not a record *)
585 ext := e(Record); (* Cast to Rec. *)
586
587 (* Compound type test: returns true if b is
588 * a compound type and its base is a base of
589 * e *)
590 IF b.isCompoundType() THEN
591 RETURN b.baseTp.isBaseOf(e);
592 END;
593
594 RETURN b.isBaseOf(ext.baseTp); (* Recurse up! *)
595 END isBaseOf;
596
597 (* -------------------------------------------- *)
598
599 PROCEDURE (b : Pointer)isBaseOf*(e : Sy.Type) : BOOLEAN;
600 (** Find if e is an extension of pointer type b. *
601 * Overrides the isBaseOf method in Symbols.Type *)
602 VAR ext : Pointer;
603 BEGIN
604 IF (e = NIL) OR (e.kind # ptrTp) THEN RETURN FALSE;
605 ELSIF (e = b) OR (b = CSt.ntvObj) THEN RETURN TRUE; (* Trivially! *)
606 END;
607 ext := e(Pointer); (* Cast to Ptr. *)
608 RETURN (b.boundTp # NIL) (* Go to bnd-tp *)
609 & b.boundTp.isBaseOf(ext.boundTp); (* for decision *)
610 END isBaseOf;
611
612 (* -------------------------------------------- *)
613
614 PROCEDURE (s : Array)isRefSurrogate*() : BOOLEAN;
615 BEGIN RETURN TRUE END isRefSurrogate;
616
617 (* -------------------------------------------- *)
618
619 PROCEDURE (s : Record)isRefSurrogate*() : BOOLEAN;
620 BEGIN
621 RETURN (Sy.clsTp IN s.xAttr) OR CSt.targetIsJVM();
622 END isRefSurrogate;
623
624 (* -------------------------------------------- *)
625
626 PROCEDURE (lhT : Array)arrayCompat*(rhT : Sy.Type) : BOOLEAN;
627 BEGIN
628 IF lhT.length = 0 THEN (* An open array type *)
629 IF rhT.kind = arrTp THEN
630 RETURN lhT.elemTp.arrayCompat(rhT(Array).elemTp);
631 ELSE
632 RETURN lhT.isCharArrayType() & rhT.isStringType();
633 END;
634 ELSE
635 RETURN FALSE;
636 END;
637 END arrayCompat;
638
639 (* -------------------------------------------- *)
640
641 PROCEDURE (lhT : Enum)equalType*(rhT : Sy.Type) : BOOLEAN;
642 BEGIN
643 IF lhT = rhT THEN RETURN TRUE END;
644 WITH rhT : Base DO
645 RETURN rhT = integerT;
646 ELSE
647 RETURN FALSE;
648 END;
649 END equalType;
650
651 (* -------------------------------------------- *)
652
653 PROCEDURE (t : Record)isForeign*() : BOOLEAN;
654 BEGIN
655 RETURN Sy.isFn IN t.xAttr;
656 END isForeign;
657
658 PROCEDURE (t : Pointer)isForeign*() : BOOLEAN;
659 BEGIN
660 RETURN t.boundTp.isForeign();
661 END isForeign;
662
663 (* -------------------------------------------- *)
664
665 PROCEDURE (t : Record)isCompoundType*() : BOOLEAN;
666 (* Returns true iff the record is a compound type *)
667 BEGIN
668 RETURN t.recAtt = cmpnd;
669 END isCompoundType;
670
671 (* -------------------------------------------- *)
672
673 PROCEDURE (t : Pointer)isCompoundType*() : BOOLEAN;
674 (* Returns true iff the pointer points to a compound type *)
675 BEGIN
676 RETURN (t.boundTp # NIL) & t.boundTp.isCompoundType();
677 END isCompoundType;
678
679 (* -------------------------------------------- *)
680
681 PROCEDURE (t : Record)ImplementationType*() : Sy.Type;
682 (* For compound types, this returns the base type of the compound
683 * unless it is ANNYREC in which case it returns the first
684 * interface in the list *)
685 BEGIN
686 IF t.isCompoundType() THEN
687 IF t.baseTp # anyRecTp THEN
688 RETURN t.baseTp(Record).bindTp;
689 ELSE
690 RETURN t.interfaces.a[0];
691 END;
692 ELSE
693 RETURN t;
694 END;
695 END ImplementationType;
696
697 (* -------------------------------------------- *)
698
699 PROCEDURE (t : Record)valCopyOK*() : BOOLEAN;
700 BEGIN
701 RETURN ~(Sy.noCpy IN t.xAttr);
702 END valCopyOK;
703
704 PROCEDURE (t : Array)valCopyOK*() : BOOLEAN;
705 BEGIN
706 RETURN t.elemTp.valCopyOK();
707 END valCopyOK;
708
709 (* ============================================ *)
710
711 PROCEDURE (t : Record)isInterfaceType*() : BOOLEAN;
712 BEGIN
713 RETURN (t.recAtt = iFace) OR
714 ( (t.recAtt = cmpnd) &
715 ( (t.baseTp = NIL) OR (t.baseTp = anyRecTp) ) );
716 END isInterfaceType;
717
718 (* -------------------------------------------- *)
719
720 PROCEDURE (t : Pointer)isInterfaceType*() : BOOLEAN;
721 BEGIN
722 RETURN (t.boundTp # NIL) & t.boundTp.isInterfaceType();
723 END isInterfaceType;
724
725 (* ============================================ *)
726
727 PROCEDURE (t : Event)isEventType*() : BOOLEAN;
728 BEGIN RETURN TRUE END isEventType;
729
730 (* ============================================ *)
731
732 PROCEDURE (t : Record)implements*(x : Sy.Type) : BOOLEAN;
733 (* Assert: x.isInterfaceType is true *)
734 VAR i : INTEGER; d : Sy.Type;
735 BEGIN
736 FOR i := 0 TO t.interfaces.tide - 1 DO
737 d := t.interfaces.a[i];
738 IF (d # NIL) &
739 ((d = x) OR d.implements(x)) THEN RETURN TRUE END;
740 END;
741 (* else ... *)
742 RETURN (t.baseTp # NIL) & t.baseTp.implements(x);
743 END implements;
744
745 (* -------------------------------------------- *)
746
747 PROCEDURE (t : Pointer)implements*(x : Sy.Type) : BOOLEAN;
748 BEGIN
749 RETURN (t.boundTp # NIL) & t.boundTp.implements(x);
750 END implements;
751
752 (* ============================================ *)
753
754 PROCEDURE (r : Record)implementsAll*(x : Sy.Type) : BOOLEAN;
755 (* Returns true iff r implements all of the interfaces of x.*)
756 VAR
757 i: INTEGER;
758 BEGIN
759 WITH x : Pointer DO
760 RETURN r.implementsAll(x.boundTp);
761 | x : Record DO
762 FOR i := 0 TO x.interfaces.tide - 1 DO
763 IF ~r.implements(x.interfaces.a[i]) THEN RETURN FALSE END;
764 END;
765 RETURN TRUE;
766 ELSE
767 RETURN FALSE;
768 END;
769 RETURN FALSE;
770 END implementsAll;
771
772 (* -------------------------------------------- *)
773
774 PROCEDURE (i : Pointer)implementsAll*(x : Sy.Type) : BOOLEAN;
775 (* Returns true iff p implements all of the interfaces of x.*)
776 BEGIN
777 RETURN i.boundTp.implementsAll(x);
778 END implementsAll;
779
780 (* ============================================ *)
781
782 PROCEDURE (lhsT : Procedure)formsMatch(rhsT : Procedure) : BOOLEAN,NEW;
783 VAR index : INTEGER;
784 lP,rP : Id.ParId;
785 BEGIN
786 IF lhsT.formals.tide # rhsT.formals.tide THEN RETURN FALSE;
787 ELSE
788 FOR index := 0 TO lhsT.formals.tide-1 DO
789 lP := lhsT.formals.a[index];
790 rP := rhsT.formals.a[index];
791 IF (lP.type # NIL) & ~lP.type.equalType(rP.type) THEN RETURN FALSE END;
792 IF lP.parMod # rP.parMod THEN RETURN FALSE END;
793 END;
794 END;
795 RETURN TRUE;
796 END formsMatch;
797
798 (* -------------------------------------------- *)
799
800 PROCEDURE (lT : Array)equalOpenOrVector*(r : Sy.Type) : BOOLEAN, EXTENSIBLE;
801 VAR rT : Array;
802 BEGIN
803 IF ~(r IS Array) THEN RETURN FALSE;
804 ELSE
805 rT := r(Array);
806 RETURN (lT.length = 0) & (rT.length = 0) &
807 lT.elemTp.equalType(rT.elemTp);
808 END;
809 END equalOpenOrVector;
810
811 (* -------------------------------------------- *)
812
813 PROCEDURE (lT : Vector)equalOpenOrVector*(rT : Sy.Type) : BOOLEAN;
814 BEGIN
815 WITH rT : Vector DO
816 RETURN lT.elemTp.equalType(rT.elemTp);
817 ELSE
818 RETURN FALSE;
819 END;
820 END equalOpenOrVector;
821
822 (* -------------------------------------------- *)
823
824 PROCEDURE (lT : Pointer)equalPointers*(r : Sy.Type) : BOOLEAN;
825 VAR rT : Pointer;
826 rO : Opaque;
827 BEGIN
828 IF r IS Opaque THEN
829 rO := r(Opaque);
830 IF rO.resolved # NIL THEN r := rO.resolved END;
831 END;
832 IF ~(r IS Pointer) THEN RETURN FALSE;
833 ELSE
834 rT := r(Pointer);
835 RETURN lT.boundTp.equalType(rT.boundTp);
836 END;
837 END equalPointers;
838
839 (* -------------------------------------------- *)
840
841 PROCEDURE (i : Record)InstantiateCheck*(tok : S.Token),NEW;
842 BEGIN
843 IF i.recAtt = isAbs THEN
844 S.SemError.Report(90, tok.lin, tok.col);
845 ELSIF i.recAtt = iFace THEN
846 S.SemError.Report(131, tok.lin, tok.col);
847 ELSIF (i.recAtt = limit) & i.isImportedType() THEN
848 S.SemError.Report(71, tok.lin, tok.col);
849 ELSIF (Sy.clsTp IN i.xAttr) & (Sy.noNew IN i.xAttr) THEN
850 S.SemError.Report(155, tok.lin, tok.col);
851 END;
852 END InstantiateCheck;
853
854 (* -------------------------------------------- *)
855
856 PROCEDURE (lhsT : Procedure)procMatch*(rT : Sy.Type) : BOOLEAN;
857 VAR rhsT : Procedure;
858 BEGIN
859 IF ~(rT IS Procedure) THEN RETURN FALSE;
860 ELSE
861 rhsT := rT(Procedure);
862 IF (lhsT.retType = NIL) # (rhsT.retType = NIL) THEN RETURN FALSE END;
863 IF (lhsT.retType # NIL) &
864 ~lhsT.retType.equalType(rhsT.retType) THEN RETURN FALSE END;
865 RETURN lhsT.formsMatch(rhsT);
866 END;
867 END procMatch;
868
869 (* -------------------------------------------- *)
870
871 PROCEDURE (lhsT : Procedure)namesMatch*(rT : Sy.Type) : BOOLEAN;
872 VAR rhsT : Procedure;
873 index : INTEGER;
874 BEGIN
875 IF ~(rT IS Procedure) THEN RETURN FALSE;
876 ELSE
877 rhsT := rT(Procedure);
878 IF lhsT.formals.tide # rhsT.formals.tide THEN RETURN FALSE END;
879 FOR index := 0 TO lhsT.formals.tide-1 DO
880 IF lhsT.formals.a[index].hash #
881 rhsT.formals.a[index].hash THEN RETURN FALSE END;
882 END;
883 RETURN TRUE;
884 END;
885 END namesMatch;
886
887 (* -------------------------------------------- *)
888
889 PROCEDURE (lhsT : Procedure)sigsMatch*(rT : Sy.Type) : BOOLEAN;
890 VAR rhsT : Procedure;
891 BEGIN
892 IF ~(rT IS Procedure) THEN
893 RETURN FALSE;
894 ELSE
895 rhsT := rT(Procedure);
896 RETURN lhsT.formsMatch(rhsT);
897 END;
898 END sigsMatch;
899
900 (* -------------------------------------------- *)
901
902 PROCEDURE (oldT : Procedure)CheckCovariance*(newI : Sy.Idnt);
903 (* When a method is overidden, the formals must match, except *
904 * that the return type may vary covariantly with the recvr. *)
905 VAR newT : Procedure;
906 BEGIN
907 IF newI IS Id.Procs THEN
908 newT := newI.type(Procedure);
909 IF (oldT.retType = NIL) # (newT.retType = NIL) THEN newI.IdError(116);
910 ELSIF ~newT.formsMatch(oldT) THEN
911 newI.IdError(160);
912 ELSIF (oldT.retType # NIL) & (oldT.retType # newT.retType) THEN
913 IF ~oldT.retType.isBaseOf(newT.retType) THEN
914 Sy.RepTypesErrTok(116, oldT, newT, newI.token);
915 ELSIF newI IS Id.MthId THEN
916 INCL(newI(Id.MthId).mthAtt, Id.covar);
917 END;
918 END;
919 END;
920 END CheckCovariance;
921
922 (* -------------------------------------------- *)
923
924 PROCEDURE (desc : Procedure)CheckEmptyOK*();
925 VAR idx : INTEGER;
926 frm : Id.ParId;
927 BEGIN
928 FOR idx := 0 TO desc.formals.tide - 1 DO
929 frm := desc.formals.a[idx];
930 IF frm.parMod = Sy.out THEN frm.IdError(114) END;
931 END;
932 IF desc.retType # NIL THEN desc.TypeError(115) END;
933 END CheckEmptyOK;
934
935 (* -------------------------------------------- *)
936
937 PROCEDURE (rec : Record)defBlk() : Id.BlkId, NEW;
938 VAR scp : Sy.Scope;
939 BEGIN
940 scp := NIL;
941 IF rec.idnt # NIL THEN
942 scp := rec.idnt.dfScp;
943 ELSIF rec.bindTp # NIL THEN
944 IF rec.bindTp.idnt # NIL THEN scp := rec.bindTp.idnt.dfScp END;
945 END;
946 IF scp # NIL THEN
947 WITH scp : Id.BlkId DO RETURN scp ELSE RETURN NIL END;
948 ELSE
949 RETURN NIL;
950 END;
951 END defBlk;
952
953 (* -------------------------------------------- *)
954
955 PROCEDURE^ (recT : Record)bindField*(hash : INTEGER) : Sy.Idnt,NEW;
956
957 PROCEDURE (recT : Record)interfaceBind(hash : INTEGER) : Sy.Idnt,NEW;
958 VAR idnt : Sy.Idnt;
959 intT : Sy.Type;
960 indx : INTEGER;
961 BEGIN
962 FOR indx := 0 TO recT.interfaces.tide-1 DO
963 intT := recT.interfaces.a[indx].boundRecTp();
964 idnt := intT(Record).bindField(hash);
965 IF idnt # NIL THEN RETURN idnt END;
966 END;
967 RETURN NIL;
968 END interfaceBind;
969
970 PROCEDURE AddIndirectImport(id : Sy.Idnt);
971 VAR dBlk : Id.BlkId;
972 rTyp : Record;
973 BEGIN
974 IF id = NIL THEN RETURN END;
975 (*
976 * This additional code checks for indirectly imported modules.
977 * For the .NET framework references to inherited fields of
978 * objects name the defining class. If that class comes from
979 * an assembly that is not explicitly imported into the CP,
980 * then the IL must nevertheless make an explicit reference
981 * to that assembly.
982 *)
983 WITH id : Id.FldId DO
984 rTyp := id.recTyp(Record);
985 dBlk := rTyp.defBlk();
986 IF Sy.weak IN rTyp.xAttr THEN
987 IF CSt.verbose THEN
988 Console.WriteString(rTyp.name());
989 Console.Write(".");
990 Console.WriteString(Sy.getName.ChPtr(id));
991 Console.WriteString(
992 ": defining module of field imported only indirectly");
993 Console.WriteLn;
994 END;
995 INCL(dBlk.xAttr, Sy.need);
996 EXCL(rTyp.xAttr, Sy.weak);
997 Sy.AppendScope(CSt.impSeq, dBlk);
998 END;
999 | id : Id.MthId DO
1000 rTyp := id.bndType(Record);
1001 dBlk := rTyp.defBlk();
1002 IF Sy.weak IN rTyp.xAttr THEN
1003 IF CSt.verbose THEN
1004 Console.WriteString(rTyp.name());
1005 Console.Write(".");
1006 Console.WriteString(Sy.getName.ChPtr(id));
1007 Console.WriteString(
1008 ": defining module of method imported only indirectly");
1009 Console.WriteLn;
1010 END;
1011 INCL(dBlk.xAttr, Sy.need);
1012 EXCL(rTyp.xAttr, Sy.weak);
1013 Sy.AppendScope(CSt.impSeq, dBlk);
1014 END;
1015 | id : Id.OvlId DO
1016 IF (id.dfScp # NIL) &
1017 (id.dfScp IS Id.BlkId) THEN
1018 dBlk := id.dfScp(Id.BlkId);
1019 IF Sy.weak IN dBlk.xAttr THEN
1020 IF CSt.verbose THEN
1021 Console.WriteString(Sy.getName.ChPtr(dBlk));
1022 Console.Write(".");
1023 Console.WriteString(Sy.getName.ChPtr(id));
1024 Console.WriteString(
1025 ": defining module of field imported only indirectly");
1026 Console.WriteLn;
1027 END;
1028 INCL(dBlk.xAttr, Sy.need);
1029 Sy.AppendScope(CSt.impSeq, dBlk);
1030 END;
1031 END;
1032 ELSE (* skip *)
1033 END;
1034 END AddIndirectImport;
1035
1036 PROCEDURE (recT : Record)bindField*(hash : INTEGER) : Sy.Idnt,NEW;
1037 VAR idnt : Sy.Idnt;
1038 base : Sy.Type;
1039 BEGIN
1040 idnt := recT.symTb.lookup(hash);
1041 IF (idnt = NIL) &
1042 (recT.recAtt = iFace) &
1043 (recT.interfaces.tide > 0) THEN idnt := recT.interfaceBind(hash);
1044 END;
1045 WHILE (idnt = NIL) & (* while not found yet *)
1046 (recT.baseTp # NIL) & (* while base is known *)
1047 (recT.baseTp # anyRecTp) DO (* while base # ANYREC *)
1048 base := recT.baseTp;
1049 WITH base : Record DO
1050 recT := base;
1051 idnt := base.symTb.lookup(hash);
1052 ELSE
1053 recT.baseTp := base.boundRecTp();
1054 END;
1055 END;
1056 AddIndirectImport(idnt);
1057 RETURN idnt;
1058 END bindField;
1059
1060 (* -------------------------------------------- *)
1061
1062 PROCEDURE (desc : Procedure)OutCheck*(v : VarSets.VarSet);
1063 VAR idx : INTEGER;
1064 frm : Id.ParId;
1065 msg : POINTER TO FileNames.NameString;
1066 BEGIN
1067 msg := NIL;
1068 FOR idx := 0 TO desc.formals.tide - 1 DO
1069 frm := desc.formals.a[idx];
1070 IF (frm.parMod = Sy.out) & ~v.includes(frm.varOrd) THEN
1071 IF msg = NIL THEN
1072 NEW(msg);
1073 Sy.getName.Of(frm, msg);
1074 ELSE
1075 GPText.Assign(msg^ + "," + Sy.getName.ChPtr(frm)^, msg);
1076 END;
1077 END;
1078 END;
1079 IF msg # NIL THEN desc.TypeErrStr(139, msg) END;
1080 END OutCheck;
1081
1082 (* ============================================================ *)
1083 (* Record error reporting methods *)
1084 (* ============================================================ *)
1085
1086 PROCEDURE (ty : Record)TypeError*(n : INTEGER);
1087 BEGIN
1088 IF ty.bindTp # NIL THEN
1089 ty.bindTp.TypeError(n);
1090 ELSE
1091 ty.TypeError^(n);
1092 END;
1093 END TypeError;
1094
1095 (* -------------------------------------------- *)
1096
1097 PROCEDURE (ty : Record)TypeErrStr*(n : INTEGER;
1098 IN s : ARRAY OF CHAR);
1099 BEGIN
1100 IF ty.bindTp # NIL THEN
1101 ty.bindTp.TypeErrStr(n,s);
1102 ELSE
1103 ty.TypeErrStr^(n,s);
1104 END;
1105 END TypeErrStr;
1106
1107 (* ============================================================ *)
1108 (* Constructor methods *)
1109 (* ============================================================ *)
1110
1111 PROCEDURE newBasTp*() : Base;
1112 VAR rslt : Base;
1113 BEGIN
1114 NEW(rslt);
1115 rslt.SetKind(basTp);
1116 RETURN rslt;
1117 END newBasTp;
1118
1119 (* ---------------------------- *)
1120
1121 PROCEDURE newNamTp*() : Opaque;
1122 VAR rslt : Opaque;
1123 BEGIN
1124 NEW(rslt);
1125 rslt.SetKind(namTp);
1126 RETURN rslt;
1127 END newNamTp;
1128
1129 (* ---------------------------- *)
1130
1131 PROCEDURE newTmpTp*() : Opaque;
1132 VAR rslt : Opaque;
1133 BEGIN
1134 NEW(rslt);
1135 rslt.SetKind(tmpTp);
1136 RETURN rslt;
1137 END newTmpTp;
1138
1139 (* ---------------------------- *)
1140
1141 PROCEDURE newArrTp*() : Array;
1142 VAR rslt : Array;
1143 BEGIN
1144 NEW(rslt);
1145 rslt.SetKind(arrTp);
1146 RETURN rslt;
1147 END newArrTp;
1148
1149 PROCEDURE mkArrayOf*(e : Sy.Type) : Array;
1150 VAR rslt : Array;
1151 BEGIN
1152 NEW(rslt);
1153 rslt.SetKind(arrTp);
1154 rslt.elemTp := e;
1155 RETURN rslt;
1156 END mkArrayOf;
1157
1158 (* ---------------------------- *)
1159
1160 PROCEDURE newVecTp*() : Vector;
1161 VAR rslt : Vector;
1162 BEGIN
1163 NEW(rslt);
1164 rslt.SetKind(vecTp);
1165 RETURN rslt;
1166 END newVecTp;
1167
1168 PROCEDURE mkVectorOf*(e : Sy.Type) : Vector;
1169 VAR rslt : Vector;
1170 BEGIN
1171 NEW(rslt);
1172 rslt.SetKind(vecTp);
1173 rslt.elemTp := e;
1174 RETURN rslt;
1175 END mkVectorOf;
1176
1177 (* ---------------------------- *)
1178
1179 PROCEDURE newRecTp*() : Record;
1180 VAR rslt : Record;
1181 BEGIN
1182 NEW(rslt);
1183 rslt.SetKind(recTp);
1184 RETURN rslt;
1185 END newRecTp;
1186
1187 (* ---------------------------- *)
1188
1189 PROCEDURE newEnuTp*() : Enum;
1190 VAR rslt : Enum;
1191 BEGIN
1192 NEW(rslt);
1193 rslt.SetKind(enuTp);
1194 RETURN rslt;
1195 END newEnuTp;
1196
1197 (* ---------------------------- *)
1198
1199 PROCEDURE newPtrTp*() : Pointer;
1200 VAR rslt : Pointer;
1201 BEGIN
1202 NEW(rslt);
1203 rslt.SetKind(ptrTp);
1204 RETURN rslt;
1205 END newPtrTp;
1206
1207 PROCEDURE mkPtrTo*(e : Sy.Type) : Pointer;
1208 VAR rslt : Pointer;
1209 BEGIN
1210 NEW(rslt);
1211 rslt.SetKind(ptrTp);
1212 rslt.boundTp := e;
1213 RETURN rslt;
1214 END mkPtrTo;
1215
1216 (* ---------------------------- *)
1217
1218 PROCEDURE newEvtTp*() : Procedure;
1219 VAR rslt : Event;
1220 BEGIN
1221 NEW(rslt);
1222 rslt.SetKind(evtTp);
1223 rslt.bndRec := newRecTp();
1224 rslt.bndRec.bindTp := rslt;
1225 rslt.bndRec.baseTp := CSt.ntvEvt;
1226 RETURN rslt;
1227 END newEvtTp;
1228
1229 (* ---------------------------- *)
1230
1231 PROCEDURE newPrcTp*() : Procedure;
1232 VAR rslt : Procedure;
1233 BEGIN
1234 NEW(rslt);
1235 rslt.SetKind(prcTp);
1236 RETURN rslt;
1237 END newPrcTp;
1238
1239 (* ---------------------------- *)
1240
1241 PROCEDURE newOvlTp*() : Overloaded;
1242 VAR rslt : Overloaded;
1243 BEGIN
1244 NEW(rslt);
1245 rslt.SetKind(ovlTp);
1246 RETURN rslt;
1247 END newOvlTp;
1248
1249 (* ============================================================ *)
1250 (* Some Helper procedures *)
1251 (* ============================================================ *)
1252
1253 PROCEDURE baseRecTp*(rec : Record) : Record;
1254 VAR
1255 base : Sy.Type;
1256 BEGIN
1257 IF (rec.baseTp = NIL) OR (rec.baseTp = anyRecTp) THEN RETURN NIL; END;
1258 base := rec.baseTp;
1259 WITH base : Record DO
1260 RETURN base;
1261 ELSE
1262 RETURN base.boundRecTp()(Record);
1263 END;
1264 END baseRecTp;
1265
1266 (* ---------------------------- *)
1267
1268 PROCEDURE newOvlIdent*(id : Sy.Idnt; rec : Record) : Id.OvlId;
1269 VAR
1270 oId : Id.OvlId;
1271 BEGIN
1272 oId := Id.newOvlId();
1273 oId.type := newOvlTp();
1274 oId.hash := id.hash;
1275 oId.dfScp := id.dfScp;
1276 oId.type.idnt := oId;
1277 oId.rec := rec;
1278 WITH id : Id.Procs DO
1279 Id.AppendProc(oId.list,id);
1280 ELSE
1281 oId.fld := id;
1282 END;
1283 RETURN oId;
1284 END newOvlIdent;
1285
1286 (* ---------------------------- *)
1287
1288 PROCEDURE needOvlId*(id : Id.Procs; rec : Record) : BOOLEAN;
1289 VAR
1290 ident : Sy.Idnt;
1291 base : Sy.Type;
1292 BEGIN
1293 rec := baseRecTp(rec);
1294 WHILE (rec # NIL) DO
1295 ident := rec.symTb.lookup(id.hash);
1296 IF ident # NIL THEN
1297 IF ident IS Id.OvlId THEN RETURN TRUE; END;
1298 IF ident IS Id.Procs THEN
1299 RETURN ~id.type(Procedure).formsMatch(ident.type(Procedure));
1300 END;
1301 (* allow declaration of new overloaded method *)
1302 END;
1303 rec := baseRecTp(rec);
1304 END;
1305 RETURN FALSE;
1306 END needOvlId;
1307
1308 (* ---------------------------- *)
1309
1310 PROCEDURE GetInheritedFeature*(hsh : INTEGER;
1311 OUT id : Sy.Idnt;
1312 VAR rec : Record);
1313 BEGIN
1314 id := rec.symTb.lookup(hsh);
1315 WHILE (id = NIL) & (rec.baseTp # NIL) &
1316 (rec.baseTp # anyRecTp) & (rec.baseTp # anyPtrTp) DO
1317 rec := baseRecTp(rec);
1318 IF rec = NIL THEN RETURN; END;
1319 id := rec.symTb.lookup(hsh);
1320 END;
1321 END GetInheritedFeature;
1322
1323 (* ---------------------------- *)
1324
1325 PROCEDURE findOverriddenProc*(proc : Id.Procs) : Id.Procs;
1326 VAR
1327 id : Sy.Idnt;
1328 rec : Record;
1329 ty : Sy.Type;
1330 pId : Id.Procs;
1331 BEGIN
1332 ty := proc.type.boundRecTp();
1333 IF ty = NIL THEN RETURN NIL; END;
1334 rec := baseRecTp(ty(Record));
1335 WHILE (rec # NIL) & (rec # anyRecTp) & (rec # anyPtrTp) DO
1336 id := rec.symTb.lookup(proc.hash);
1337 WITH id : Id.OvlId DO
1338 pId := id.findProc(proc);
1339 IF pId # NIL THEN RETURN pId; END;
1340 | id : Id.Procs DO
1341 IF proc.type.sigsMatch(id.type) THEN RETURN id; END;
1342 RETURN NIL;
1343 ELSE
1344 RETURN NIL;
1345 END;
1346 IF (rec.baseTp = NIL) THEN
1347 rec := NIL;
1348 ELSE
1349 rec := baseRecTp(rec);
1350 END;
1351 END;
1352 RETURN NIL;
1353 END findOverriddenProc;
1354
1355 (* ---------------------------- *)
1356
1357 PROCEDURE AddToOvlIdent(id : Sy.Idnt; oId : Id.OvlId; doKindCheck : BOOLEAN;
1358 VAR ok : BOOLEAN);
1359 BEGIN
1360 ok := TRUE;
1361 WITH id : Id.Procs DO
1362 Id.AppendProc(oId.list,id);
1363 ELSE
1364 IF oId.fld = NIL THEN
1365 oId.fld := id;
1366 ELSE
1367 ok := (doKindCheck & (oId.fld.kind = id.kind));
1368 END;
1369 END;
1370 END AddToOvlIdent;
1371
1372 (* ---------------------------- *)
1373
1374 PROCEDURE isBoxedStruct*(ptr : Sy.Type; dst : Sy.Type) : BOOLEAN;
1375 BEGIN
1376 RETURN ptr.isNativeObj() & dst.isRecordType() & ~dst.isExtnRecType();
1377 END isBoxedStruct;
1378
1379 (* ---------------------------- *)
1380
1381 PROCEDURE InsertInRec*(id : Sy.Idnt;
1382 rec : Record;
1383 doKindCheck : BOOLEAN;
1384 OUT oId : Id.OvlId;
1385 OUT ok : BOOLEAN);
1386 VAR
1387 existingId : Sy.Idnt;
1388 recScp : Record;
1389
1390 BEGIN
1391 oId := NIL;
1392 ok := TRUE;
1393 recScp := rec;
1394 GetInheritedFeature(id.hash, existingId, recScp);
1395 (*
1396 * If existingId = NIL (the usual case) all is ok.
1397 *)
1398 IF (Sy.isFn IN rec.xAttr) & (existingId # NIL) THEN
1399 (*
1400 * This is a foreign record, so that different rules
1401 * apply. Overloading is ok, and obscuring of
1402 * inherited field by local fields is allowed.
1403 *)
1404 IF recScp = rec THEN
1405 (*
1406 * The ident is for the same scope :
1407 * - if it is a method, and has same params then ... ok,
1408 * - else this is an overload, and must be marked,
1409 * - else if this is the same kind, then ... ok,
1410 * - else this is an error.
1411 *)
1412 WITH existingId : Id.Procs DO
1413 IF ~existingId.type.sigsMatch(id.type) THEN
1414 oId := newOvlIdent(existingId,rec);
1415 AddToOvlIdent(id,oId,doKindCheck,ok);
1416 rec.symTb.Overwrite(oId.hash,oId);
1417 END; (* and ok stays true! *)
1418 (*
1419 * | existingId : Id.FldId DO
1420 *)
1421 | existingId : Id.AbVar DO
1422 oId := newOvlIdent(existingId,rec);
1423 AddToOvlIdent(id,oId,doKindCheck,ok);
1424 rec.symTb.Overwrite(oId.hash,oId);
1425 | existingId : Id.OvlId DO
1426 oId := existingId;
1427 AddToOvlIdent(id,existingId,doKindCheck,ok);
1428 ELSE
1429 (*
1430 * Check if this is actually the same feature
1431 *)
1432 IF existingId.type IS Opaque THEN existingId.type := id.type;
1433 ELSIF id.type IS Opaque THEN id.type := existingId.type;
1434 END;
1435 ok := (existingId.kind = id.kind) &
1436 existingId.type.equalType(id.type);
1437
1438 END;
1439 ELSE
1440 (*
1441 * The ident is from enclosing scope :
1442 * - if it is a field ID then ... ok,
1443 * - if it is a method, and has same params then ... ok,
1444 * - else this is an overload, and must be marked.
1445 *)
1446 WITH existingId : Id.FldId DO
1447 ok := rec.symTb.enter(id.hash, id);
1448 | existingId : Id.Procs DO
1449 IF existingId.type.sigsMatch(id.type) THEN
1450 ok := rec.symTb.enter(id.hash, id);
1451 ELSE
1452 oId := newOvlIdent(id,rec);
1453 ok := rec.symTb.enter(oId.hash,oId);
1454 END;
1455 | existingId : Id.OvlId DO
1456 oId := existingId;
1457 AddToOvlIdent(id,existingId,doKindCheck,ok);
1458 ELSE (* must be a field *)
1459 ok := rec.symTb.enter(id.hash, id);
1460 END;
1461 END;
1462 ELSIF ~rec.symTb.enter(id.hash, id) THEN
1463 existingId := rec.symTb.lookup(id.hash);
1464 ok := doKindCheck & (existingId.kind = id.kind);
1465 END;
1466 END InsertInRec;
1467
1468 (* ---------------------------- *)
1469
1470 PROCEDURE Error145(start : Sy.Type);
1471 VAR sccTab : Sy.SccTable;
1472 BEGIN
1473 NEW(sccTab);
1474 sccTab.target := start;
1475 start.SccTab(sccTab);
1476 start.TypeErrStr(145, Sy.dumpList(sccTab.symTab));
1477 END Error145;
1478
1479 (* ============================================================ *)
1480 (* Implementation of Abstract methods *)
1481 (* ============================================================ *)
1482
1483 PROCEDURE (i : Base)resolve*(d : INTEGER) : Sy.Type;
1484 BEGIN RETURN i END resolve;
1485
1486 (* ---------------------------- *)
1487
1488 PROCEDURE (i : Enum)resolve*(d : INTEGER) : Sy.Type;
1489 BEGIN RETURN i END resolve;
1490
1491 (* ---------------------------- *)
1492
1493 PROCEDURE (i : Opaque)resolve*(d : INTEGER) : Sy.Type;
1494 VAR newTpId : Sy.Idnt;
1495 oldTpId : Sy.Idnt;
1496 BEGIN
1497 IF i.depth = initialMark THEN
1498 (*
1499 * If i.kind=tmpTp, this is a forward type, or
1500 * a sym-file temporary. If we cannot resolve
1501 * this to a real type, it is an error.
1502 *
1503 * If i.kind=namTp, this is a named opaque type,
1504 * we must look it up in the symTab. If we
1505 * do not find it, the type just stays opaque.
1506 *)
1507 i.depth := finishMark;
1508 oldTpId := i.idnt;
1509 newTpId := oldTpId.dfScp.symTb.lookup(oldTpId.hash);
1510 IF newTpId = NIL THEN
1511 oldTpId.IdError(2);
1512 ELSIF newTpId.kind # Id.typId THEN
1513 oldTpId.IdError(5);
1514 ELSIF newTpId.type # NIL THEN
1515 (*
1516 * This particular method might recurse, even for
1517 * correct programs, such as
1518 * TYPE A = POINTER TO B;
1519 * TYPE B = RECORD c : C END;
1520 * TYPE C = RECORD(A) ... END;
1521 * Thus we must not recurse until we have set the
1522 * resolved field, since we have now set the depth
1523 * mark and will not reenter the binding code again.
1524 *)
1525 i.resolved := newTpId.type;
1526 i.resolved := newTpId.type.resolve(d); (* Recurse! *)
1527 IF i.kind = tmpTp THEN
1528 IF i.resolved = i THEN oldTpId.IdError(125) END;
1529 ELSIF i.kind = namTp THEN
1530 IF (i.resolved = NIL) OR
1531 (i.resolved.kind = namTp) THEN i.resolved := i END;
1532 END;
1533 END;
1534 END;
1535 RETURN i.resolved;
1536 END resolve;
1537
1538 (* ---------------------------- *)
1539
1540 PROCEDURE (i : Array)resolve*(d : INTEGER) : Sy.Type, EXTENSIBLE;
1541 VAR e137,e145 : BOOLEAN;
1542 BEGIN
1543 IF i.depth = initialMark THEN
1544 e145 := FALSE;
1545 e137 := FALSE;
1546 i.depth := d;
1547 IF i.elemTp # NIL THEN i.elemTp := i.elemTp.resolve(d) END;
1548 IF (i.length # 0) &
1549 (i.elemTp # NIL) &
1550 i.elemTp.isOpenArrType() THEN
1551 i.TypeError(69);
1552 END;
1553 IF i.depth = errorMark THEN
1554 IF i.elemTp = i THEN e137 := TRUE ELSE e145 := TRUE END;
1555 i.TypeError(126);
1556 END;
1557 i.depth := finishMark;
1558 IF e145 THEN Error145(i);
1559 ELSIF e137 THEN i.TypeError(137);
1560 END;
1561 ELSIF i.depth = d THEN (* recursion through value types *)
1562 i.depth := errorMark;
1563 END;
1564 RETURN i;
1565 END resolve;
1566
1567 (* ---------------------------- *)
1568
1569 PROCEDURE (i : Vector)resolve*(d : INTEGER) : Sy.Type;
1570 VAR e137,e145 : BOOLEAN;
1571 BEGIN
1572 IF i.depth = initialMark THEN
1573 IF i.elemTp # NIL THEN i.elemTp := i.elemTp.resolve(d) END;
1574 i.depth := finishMark;
1575 END;
1576 RETURN i;
1577 END resolve;
1578
1579 (* ---------------------------- *)
1580
1581 PROCEDURE (x: Record)CopyFieldsOf(b : Sy.Type),NEW; (* final *)
1582 VAR bRecT : Record;
1583 nextF : Sy.Idnt;
1584 index : INTEGER;
1585 BEGIN
1586 IF (b # anyRecTp) & (b.depth # errorMark) THEN
1587 bRecT := b.boundRecTp()(Record);
1588 (*
1589 * First get the fields of the higher ancestors.
1590 *)
1591 IF bRecT.baseTp # NIL THEN x.CopyFieldsOf(bRecT.baseTp) END;
1592 (*
1593 * Now add the fields of the immediate base type
1594 *)
1595 FOR index := 0 TO bRecT.fields.tide-1 DO
1596 nextF := bRecT.fields.a[index];
1597 IF ~x.symTb.enter(nextF.hash, nextF) & ~(Sy.isFn IN bRecT.xAttr) THEN
1598 x.symTb.lookup(nextF.hash).IdError(82);
1599 END;
1600 END;
1601 END;
1602 END CopyFieldsOf;
1603
1604 (* ---------------------------- *)
1605
1606 PROCEDURE (i : Record)resolve*(d : INTEGER) : Sy.Type;
1607 (** Resolve this type, and any used in this type *)
1608 VAR baseT : Record;
1609 field : Sy.Idnt;
1610 index : INTEGER;
1611 hashN : INTEGER;
1612 nameS : Lv.CharOpen;
1613 ident : Sy.Idnt;
1614 intId : Sy.Idnt;
1615 intTp : Sy.Type;
1616 recId : Sy.Idnt;
1617 dBlk : Id.BlkId;
1618 ntvNm : RTS.NativeString;
1619 e137,e145 : BOOLEAN;
1620 (* ----------------------------------------- *)
1621 PROCEDURE refInNET(t : Sy.Type) : BOOLEAN;
1622 (*
1623 * This predicate is used for the .NET
1624 * platform, to set the "clsTp" attribute.
1625 * It implies that this type will have a
1626 * reference representation in .NET
1627 *)
1628 BEGIN
1629 IF t = NIL THEN
1630 RETURN FALSE; (* Actually we don't care here. *)
1631 ELSE
1632 WITH t : Record DO
1633 RETURN Sy.clsTp IN t.xAttr;
1634 | t : Array DO
1635 RETURN TRUE; (* arrays are references in NET *)
1636 | t : Event DO
1637 RETURN TRUE; (* events are references in NET *)
1638 ELSE RETURN FALSE; (* all others are value types. *)
1639 END;
1640 END;
1641 END refInNET;
1642 (* ----------------------------------------- *)
1643 BEGIN (* resolve *)
1644 IF i.depth = initialMark THEN
1645
1646 IF CSt.verbose THEN
1647 IF i.idnt # NIL THEN
1648 ntvNm := Sy.getName.NtStr(i.idnt);
1649 ELSIF (i.bindTp # NIL) & (i.bindTp.idnt # NIL) THEN
1650 ntvNm := Sy.getName.NtStr(i.bindTp.idnt);
1651 END;
1652 END;
1653 i.depth := d;
1654 e145 := FALSE;
1655 e137 := FALSE;
1656 (*
1657 * First: resolve the base type, if any,
1658 * or set the base type to the type ANYREC.
1659 *)
1660 baseT := NIL;
1661 IF i.baseTp = NIL THEN
1662 i.baseTp := anyRecTp;
1663 ELSIF i.baseTp = anyPtrTp THEN
1664 i.baseTp := anyRecTp;
1665 (*
1666 * Special case of baseTp of POINTER TO RTS.NativeObject ...
1667 *)
1668 ELSIF i.baseTp.isNativeObj() THEN
1669 IF i.baseTp IS Pointer THEN i.baseTp := i.baseTp.boundRecTp() END;
1670 ELSE (* the normal case *)
1671 i.baseTp := i.baseTp.resolve(d);
1672 (*
1673 * There is a special case here. If the base type
1674 * is an unresolved opaque from an unimported module
1675 * then leave well alone.
1676 *)
1677 IF i.baseTp # NIL THEN
1678 IF i.baseTp IS Opaque THEN
1679 i.baseTp := anyRecTp;
1680 ELSE
1681 i.baseTp := i.baseTp.boundRecTp();
1682 IF i.baseTp IS Record THEN baseT := i.baseTp(Record) END;
1683 IF i.baseTp = NIL THEN i.TypeError(14) END; (* not rec or ptr *)
1684 IF i.depth = errorMark THEN
1685 IF i.baseTp = i THEN e137 := TRUE ELSE e145 := TRUE END;
1686 i.TypeError(123);
1687 END;
1688 END;
1689 END;
1690 IF baseT # NIL THEN
1691 (*
1692 * Base is resolved, now check some semantic constraints.
1693 *)
1694 IF (isAbs = i.recAtt) &
1695 ~baseT.isAbsRecType() &
1696 ~(Sy.isFn IN baseT.xAttr) THEN
1697 i.TypeError(102); (* abstract record must have abstract base *)
1698 ELSIF baseT.isExtnRecType() THEN
1699 i.CopyFieldsOf(baseT);
1700 IF Sy.noNew IN baseT.xAttr THEN INCL(i.xAttr, Sy.noNew) END;
1701 (* ----- Code for extensible limited records ----- *)
1702 ELSIF baseT.isLimRecType() THEN
1703 IF ~i.isLimRecType() THEN
1704 i.TypeError(234); (* abstract record must have abstract base *)
1705 ELSIF i.isImportedType() # baseT.isImportedType() THEN
1706 i.TypeError(235); (* abstract record must have abstract base *)
1707 END;
1708 (* --- End code for extensible limited records --- *)
1709 ELSIF baseT.isInterfaceType() THEN
1710 i.TypeErrStr(154, baseT.name()); (* cannot extend interfaces *)
1711 ELSE
1712 i.TypeError(16); (* base type is not an extensible record *)
1713 END;
1714 IF (iFace = i.recAtt) &
1715 ~baseT.isNativeObj() THEN i.TypeError(156) END;
1716 (*
1717 * Propagate no-block-copy attribute to extensions.
1718 * Note the special case here: in .NET extensions
1719 * of System.ValueType may be copied freely.
1720 *)
1721 IF (Sy.noCpy IN baseT.xAttr) &
1722 (baseT # CSt.ntvVal) THEN INCL(i.xAttr, Sy.noCpy) END;
1723 END;
1724 END;
1725 (*
1726 * Interface types must be exported.
1727 *)
1728 IF i.recAtt = iFace THEN
1729 IF i.idnt # NIL THEN
1730 IF i.idnt.vMod = Sy.prvMode THEN i.TypeError(215) END;
1731 ELSIF (i.bindTp # NIL) & (i.bindTp.idnt # NIL) THEN
1732 IF i.bindTp.idnt.vMod = Sy.prvMode THEN i.TypeError(215) END;
1733 ELSE
1734 i.TypeError(214);
1735 END;
1736 END;
1737 (*
1738 * Now check semantics of interface implementation.
1739 *)
1740 IF (i.interfaces.tide > 0) & (baseT # NIL) THEN
1741 (*
1742 * (* Use this code to allow only direct foreign types. *)
1743 * IF ~(Sy.isFn IN baseT.xAttr) &
1744 * ~i.isImportedType() THEN i.TypeErrStr(157, baseT.name()) END;
1745 *)
1746
1747 (*
1748 * (* Use this code to allow only extensions of foreign types. *)
1749 * IF ~(Sy.noCpy IN baseT.xAttr) &
1750 * ~i.isImportedType() THEN i.TypeErrStr(157, baseT.name()) END;
1751 *)
1752 (* Remove both to allow all code to define interfaces *)
1753
1754 FOR index := 0 TO i.interfaces.tide-1 DO
1755 intTp := i.interfaces.a[index].resolve(d);
1756 IF intTp # NIL THEN
1757 intTp := intTp.boundRecTp();
1758 IF (intTp # NIL) &
1759 ~intTp.isInterfaceType() THEN
1760 i.TypeErrStr(158, intTp.name());
1761 END;
1762 END;
1763 END;
1764 END;
1765 i.depth := d;
1766 (*
1767 * Next: set basis of no-block-copy flag
1768 *)
1769 IF (Sy.isFn IN i.xAttr) &
1770 (Sy.clsTp IN i.xAttr) THEN INCL(i.xAttr, Sy.noCpy);
1771 END;
1772 (*
1773 * Next: resolve all field types.
1774 *)
1775 FOR index := 0 TO i.fields.tide-1 DO
1776 field := i.fields.a[index];
1777 IF field.type # NIL THEN field.type := field.type.resolve(d) END;
1778 IF i.depth = errorMark THEN
1779 IF field.type = i THEN e137 := TRUE ELSE e145 := TRUE END;
1780 field.IdError(124);
1781 i.depth := d;
1782 END;
1783 IF refInNET(field.type) THEN INCL(i.xAttr,Sy.clsTp) END;
1784 IF field.type IS Event THEN Sy.AppendIdnt(i.events, field) END;
1785 END;
1786
1787 (*
1788 * Next: resolve all method types. NEW!
1789 *)
1790 FOR index := 0 TO i.methods.tide-1 DO
1791 field := i.methods.a[index];
1792 IF field.type # NIL THEN field.type := field.type.resolve(d) END;
1793 END;
1794
1795 (*
1796 * Next: resolve types of all static members.
1797 *)
1798 FOR index := 0 TO i.statics.tide-1 DO
1799 field := i.statics.a[index];
1800 IF field.type # NIL THEN field.type := field.type.resolve(d) END;
1801 END;
1802
1803 i.depth := finishMark;
1804 IF e145 THEN Error145(i);
1805 ELSIF e137 THEN i.TypeError(137);
1806 END;
1807 ELSIF i.depth = d THEN (* recursion through value types *)
1808 i.depth := errorMark;
1809 END;
1810 (* ##### *)
1811 dBlk := i.defBlk();
1812 IF (dBlk # NIL) & (Sy.weak IN dBlk.xAttr) THEN INCL(i.xAttr, Sy.weak) END;
1813 (* ##### *)
1814 RETURN i;
1815 END resolve;
1816
1817 (* ---------------------------- *)
1818
1819 PROCEDURE (i : Record)FixDefScope*(s : Sy.Scope),NEW;
1820 VAR idx : INTEGER;
1821 idD : Sy.Idnt;
1822 BEGIN
1823 FOR idx := 0 TO i.methods.tide-1 DO
1824 idD := i.methods.a[idx];
1825 IF idD.dfScp # s THEN
1826 idD.dfScp := s;
1827 IF CSt.verbose THEN
1828 Console.WriteString("Fixing method module:");
1829 Console.WriteString(Sy.getName.ChPtr(idD));
1830 Console.WriteLn;
1831 END;
1832 ELSE
1833 RETURN
1834 END;
1835 END;
1836 FOR idx := 0 TO i.statics.tide-1 DO
1837 idD := i.statics.a[idx];
1838 IF idD.dfScp # s THEN
1839 idD.dfScp := s;
1840 IF CSt.verbose THEN
1841 Console.WriteString("Fixing static module:");
1842 Console.WriteString(Sy.getName.ChPtr(idD));
1843 Console.WriteLn;
1844 END;
1845 ELSE
1846 RETURN
1847 END;
1848 END;
1849 END FixDefScope;
1850
1851 (* ---------------------------- *)
1852
1853 PROCEDURE (i : Pointer)resolve*(d : INTEGER) : Sy.Type;
1854 VAR bndT : Sy.Type;
1855 BEGIN
1856 IF i.depth = initialMark THEN
1857 i.depth := d;
1858 bndT := i.boundTp;
1859 IF (bndT # NIL) & (*==> bound type is OK *)
1860 (bndT.idnt = NIL) THEN (*==> anon. bound type *)
1861 WITH bndT : Record DO
1862 IF bndT.bindTp = NIL THEN
1863 INCL(bndT.xAttr, Sy.clsTp);
1864 INCL(bndT.xAttr, Sy.anon);
1865 IF i.idnt # NIL THEN (*==> named ptr type *)
1866 (*
1867 * The anon record should have the same name as the
1868 * pointer type. The record is marked so that the
1869 * synthetic name <ptrName>"^" can be derived.
1870 * The visibility mode is the same as the pointer.
1871 *)
1872 bndT.bindTp := i;
1873 END;
1874 END;
1875 IF bndT.isForeign() THEN bndT.FixDefScope(i.idnt.dfScp) END;
1876 ELSE (* skip pointers to arrays *)
1877 END;
1878 END;
1879 IF bndT # NIL THEN
1880 i.boundTp := bndT.resolve(d+1);
1881 IF (i.boundTp # NIL) &
1882 ~(i.boundTp IS Array) &
1883 ~(i.boundTp IS Record) THEN i.TypeError(140) END;
1884 END;
1885 i.depth := finishMark;
1886 END;
1887 RETURN i;
1888 END resolve;
1889
1890 (* ---------------------------- *)
1891
1892 PROCEDURE (i : Procedure)resolve*(d : INTEGER) : Sy.Type;
1893 VAR idx : INTEGER;
1894 frm : Sy.Idnt;
1895 BEGIN
1896 IF i.depth = initialMark THEN
1897 i.depth := d;
1898 FOR idx := 0 TO i.formals.tide-1 DO
1899 frm := i.formals.a[idx];
1900 IF frm.type # NIL THEN frm.type := frm.type.resolve(d+1) END;
1901 END;
1902
1903 IF i.retType # NIL THEN i.retType := i.retType.resolve(d+1) END;
1904 i.depth := finishMark;
1905 END;
1906 RETURN i
1907 END resolve;
1908
1909 (* ---------------------------- *)
1910
1911 PROCEDURE (i : Overloaded)resolve*(d : INTEGER) : Sy.Type;
1912 BEGIN
1913 ASSERT(FALSE);
1914 RETURN NIL;
1915 END resolve;
1916
1917 (* ---------------------------- *)
1918
1919 PROCEDURE (i : Opaque)elaboration*() : Sy.Type;
1920 BEGIN
1921 IF i.resolved # NIL THEN RETURN i.resolved ELSE RETURN i END;
1922 END elaboration;
1923
1924 (* ============================================================ *)
1925
1926 PROCEDURE (i : Base)TypeErase*() : Sy.Type;
1927 BEGIN RETURN i END TypeErase;
1928
1929 (* ---------------------------- *)
1930
1931 PROCEDURE (i : Enum)TypeErase*() : Sy.Type;
1932 BEGIN RETURN i END TypeErase;
1933
1934 (* ---------------------------- *)
1935
1936 PROCEDURE (i : Opaque)TypeErase*() : Sy.Type;
1937 BEGIN RETURN i END TypeErase;
1938
1939 (* ---------------------------- *)
1940
1941 PROCEDURE (i : Array)TypeErase*() : Sy.Type;
1942 BEGIN RETURN i END TypeErase;
1943
1944 (* ---------------------------- *)
1945
1946 PROCEDURE (i : Record)TypeErase*() : Sy.Type;
1947 (* If the Record type is a compound type, return
1948 * its implementation type, otherwise erase the types
1949 * from the fields and methods of the record *)
1950 VAR
1951 index : INTEGER;
1952 id : Sy.Idnt;
1953 BEGIN
1954 IF i.isCompoundType() THEN
1955 RETURN i.ImplementationType();
1956 END;
1957
1958 (* Process the fields *)
1959 FOR index := 0 TO i.fields.tide-1 DO
1960 id := i.fields.a[index];
1961 IF id.type # NIL THEN
1962 i.fields.a[index].type := id.type.TypeErase();
1963 END;
1964 END;
1965
1966 (* Process the methods *)
1967 FOR index := 0 TO i.methods.tide-1 DO
1968 id := i.methods.a[index];
1969 IF id.type # NIL THEN
1970 i.methods.a[index].type := id.type.TypeErase();
1971 END;
1972 END;
1973
1974 RETURN i;
1975 END TypeErase;
1976
1977 (* ---------------------------- *)
1978
1979 PROCEDURE (i : Pointer)TypeErase*() : Sy.Type;
1980 (* Erase the bound type *)
1981 VAR bndT : Sy.Type;
1982 BEGIN
1983 bndT := i.boundTp;
1984 IF (bndT # NIL) THEN
1985 i.boundTp := bndT.TypeErase();
1986 END;
1987 RETURN i;
1988 END TypeErase;
1989
1990 (* ---------------------------- *)
1991
1992 PROCEDURE (i : Procedure)TypeErase*() : Sy.Type;
1993 (* Erase the types of the formals *)
1994 VAR
1995 index : INTEGER;
1996 id : Sy.Idnt;
1997 BEGIN
1998 (* Process the fields *)
1999 FOR index := 0 TO i.formals.tide-1 DO
2000 id := i.formals.a[index];
2001 IF id.type # NIL THEN
2002 i.formals.a[index].type := id.type.TypeErase();
2003 END;
2004 END;
2005 RETURN i
2006 END TypeErase;
2007
2008 (* ---------------------------- *)
2009
2010 PROCEDURE (i : Overloaded)TypeErase*() : Sy.Type;
2011 BEGIN RETURN i END TypeErase;
2012
2013 (* ============================================================ *)
2014
2015 PROCEDURE Insert(VAR s : Sy.SymbolTable; t : Sy.Type);
2016 VAR junk : BOOLEAN;
2017 BEGIN
2018 IF t.idnt # NIL THEN junk := s.enter(t.idnt.hash, t.idnt) END;
2019 END Insert;
2020
2021 (* ---------------------------------------------------- *)
2022
2023 PROCEDURE (i : Array)SccTab*(t : Sy.SccTable);
2024 BEGIN
2025 i.depth := initialMark;
2026 t.reached := FALSE;
2027 IF i.elemTp # NIL THEN
2028 IF i.elemTp = t.target THEN
2029 t.reached := TRUE;
2030 ELSIF i.elemTp.depth # initialMark THEN
2031 t.reached := FALSE;
2032 i.elemTp.SccTab(t);
2033 END;
2034 IF t.reached THEN Insert(t.symTab, i) END;
2035 END;
2036 i.depth := finishMark;
2037 END SccTab;
2038
2039 (* ---------------------------------------------------- *)
2040
2041 PROCEDURE (i : Record)SccTab*(t : Sy.SccTable);
2042 VAR index : INTEGER;
2043 found : BOOLEAN;
2044 field : Sy.Idnt;
2045 fldTp : Sy.Type;
2046 BEGIN
2047 i.depth := initialMark;
2048 found := FALSE;
2049 IF i.baseTp # NIL THEN
2050 fldTp := i.baseTp;
2051 IF fldTp = t.target THEN
2052 t.reached := TRUE;
2053 ELSIF fldTp.depth # initialMark THEN
2054 t.reached := FALSE;
2055 fldTp.SccTab(t);
2056 END;
2057 IF t.reached THEN found := TRUE END;
2058 END;
2059 FOR index := 0 TO i.fields.tide-1 DO
2060 field := i.fields.a[index];
2061 fldTp := field.type;
2062 IF fldTp # NIL THEN
2063 IF fldTp = t.target THEN
2064 t.reached := TRUE;
2065 ELSIF fldTp.depth # initialMark THEN
2066 t.reached := FALSE;
2067 fldTp.SccTab(t);
2068 END;
2069 IF t.reached THEN found := TRUE END;
2070 END;
2071 END;
2072 IF found THEN Insert(t.symTab, i); t.reached := TRUE END;
2073 i.depth := finishMark;
2074 END SccTab;
2075
2076 (* ---------------------------------------------------- *)
2077
2078 PROCEDURE (i : Base)SccTab*(t : Sy.SccTable);
2079 BEGIN (* skip *) END SccTab;
2080
2081 (* ---------------------------------------------------- *)
2082
2083 PROCEDURE (i : Opaque)SccTab*(t : Sy.SccTable);
2084 BEGIN (* skip *) END SccTab;
2085
2086 (* ---------------------------------------------------- *)
2087
2088 PROCEDURE (i : Pointer)SccTab*(t : Sy.SccTable);
2089 BEGIN (* skip *) END SccTab;
2090
2091 (* ---------------------------------------------------- *)
2092
2093 PROCEDURE (i : Enum)SccTab*(t : Sy.SccTable);
2094 BEGIN (* skip *) END SccTab;
2095
2096 (* ---------------------------------------------------- *)
2097
2098 PROCEDURE (i : Procedure)SccTab*(t : Sy.SccTable);
2099 BEGIN (* skip *) END SccTab;
2100
2101 (* ---------------------------------------------------- *)
2102
2103 PROCEDURE (i : Overloaded)SccTab*(t : Sy.SccTable);
2104 BEGIN ASSERT(FALSE); END SccTab;
2105
2106 (* ============================================================ *)
2107
2108 PROCEDURE update*(IN a : Sy.TypeSeq; t : Sy.Type) : Sy.Type;
2109 BEGIN
2110 IF t.dump-Sy.tOffset >= a.tide THEN
2111 Console.WriteInt(t.dump,0);
2112 Console.WriteInt(a.tide+Sy.tOffset,0);
2113 Console.WriteLn;
2114 END;
2115 IF t.kind = tmpTp THEN RETURN a.a[t.dump - Sy.tOffset] ELSE RETURN t END;
2116 END update;
2117
2118 (* ============================================================ *)
2119
2120 PROCEDURE (t : Base)TypeFix*(IN a : Sy.TypeSeq);
2121 BEGIN END TypeFix;
2122
2123 (* ---------------------------- *)
2124
2125 PROCEDURE (t : Enum)TypeFix*(IN a : Sy.TypeSeq);
2126 BEGIN END TypeFix;
2127
2128 (* ---------------------------- *)
2129
2130 PROCEDURE (t : Opaque)TypeFix*(IN a : Sy.TypeSeq);
2131 BEGIN END TypeFix;
2132
2133 (* ---------------------------- *)
2134
2135 PROCEDURE (t : Array)TypeFix*(IN a : Sy.TypeSeq);
2136 BEGIN
2137 t.elemTp := update(a, t.elemTp);
2138 END TypeFix;
2139
2140 (* ---------------------------- *)
2141
2142 PROCEDURE (t : Record)TypeFix*(IN a : Sy.TypeSeq);
2143 VAR i : INTEGER;
2144 f : Sy.Idnt;
2145 m : Id.MthId;
2146 b : Sy.Type;
2147 BEGIN
2148 IF t.baseTp # NIL THEN
2149 IF t.baseTp IS Pointer THEN t.baseTp := t.baseTp.boundRecTp() END;
2150 t.baseTp := update(a, t.baseTp);
2151 END;
2152 FOR i := 0 TO t.interfaces.tide - 1 DO
2153 b := t.interfaces.a[i];
2154 t.interfaces.a[i] := update(a, b);
2155 END;
2156 FOR i := 0 TO t.fields.tide - 1 DO
2157 f := t.fields.a[i];
2158 f.type := update(a, f.type);
2159 END;
2160 FOR i := 0 TO t.methods.tide - 1 DO
2161 f := t.methods.a[i];
2162 m := f(Id.MthId);
2163 m.bndType := update(a, m.bndType);
2164 b := update(a, m.rcvFrm.type);
2165 m.rcvFrm.type := b;
2166 f.type.TypeFix(a); (* recurse to param-types etc. *)
2167 END;
2168 FOR i := 0 TO t.statics.tide - 1 DO
2169 f := t.statics.a[i];
2170 f.type := update(a, f.type);
2171 IF f.type IS Procedure THEN f.type.TypeFix(a) END;
2172 END;
2173 END TypeFix;
2174
2175 (* ---------------------------- *)
2176
2177 PROCEDURE (t : Pointer)TypeFix*(IN a : Sy.TypeSeq);
2178 VAR bndT : Sy.Type;
2179 BEGIN
2180 bndT := update(a, t.boundTp);
2181 t.boundTp := bndT;
2182 IF bndT.idnt = NIL THEN
2183 WITH bndT : Record DO
2184 INCL(bndT.xAttr, Sy.clsTp);
2185 INCL(bndT.xAttr, Sy.anon);
2186 IF bndT.bindTp = NIL THEN bndT.bindTp := t END;
2187 ELSE (* ptr to array : skip *)
2188 END;
2189 END;
2190 END TypeFix;
2191
2192 (* ---------------------------- *)
2193
2194 PROCEDURE (t : Procedure)TypeFix*(IN a : Sy.TypeSeq);
2195 VAR i : INTEGER;
2196 f : Id.ParId;
2197 BEGIN
2198 IF t.retType # NIL THEN t.retType := update(a, t.retType) END;
2199 IF t.receiver # NIL THEN t.receiver := update(a, t.receiver) END;
2200 FOR i := 0 TO t.formals.tide - 1 DO
2201 f := t.formals.a[i];
2202 f.type := update(a, f.type);
2203 END;
2204 END TypeFix;
2205
2206 (* ---------------------------- *)
2207
2208 PROCEDURE (t : Overloaded)TypeFix*(IN a : Sy.TypeSeq);
2209 BEGIN
2210 ASSERT(FALSE);
2211 END TypeFix;
2212
2213 (* ============================================================ *)
2214 (* A type is "forced", i.e. must have its type *)
2215 (* structure emitted to the symbol file if it is any of ... *)
2216 (* i : a local type with an exported TypId, *)
2217 (* ii : an imported type with an exported local alias, *)
2218 (* iii : the base-type of a forced record, *)
2219 (* iv : a type with value semantics. *)
2220 (* Partly forced types have structure but not methods emitted. *)
2221 (* ============================================================ *)
2222
2223 PROCEDURE MarkModule(ty : Sy.Type);
2224 BEGIN
2225 IF (ty.idnt # NIL) & (ty.idnt.dfScp # NIL) THEN
2226 INCL(ty.idnt.dfScp(Id.BlkId).xAttr, Sy.need);
2227 END;
2228 END MarkModule;
2229
2230 (* ---------------------------- *)
2231
2232 PROCEDURE (i : Base)ConditionalMark*();
2233 BEGIN END ConditionalMark;
2234
2235 (* ---------------------------- *)
2236
2237 PROCEDURE (i : Enum)ConditionalMark*();
2238 BEGIN END ConditionalMark;
2239
2240 (* ---------------------------- *)
2241
2242 PROCEDURE (i : Opaque)ConditionalMark*();
2243 BEGIN
2244 MarkModule(i);
2245 END ConditionalMark;
2246
2247 (* ---------------------------- *)
2248
2249 PROCEDURE (i : Pointer)ConditionalMark*();
2250 BEGIN
2251 IF i.force = Sy.noEmit THEN
2252 IF ~i.isImportedType() THEN
2253 i.force := Sy.forced;
2254 i.boundTp.ConditionalMark();
2255 ELSE
2256 MarkModule(i);
2257 END;
2258 END;
2259 END ConditionalMark;
2260
2261 (* ---------------------------- *)
2262
2263 PROCEDURE (i : Record)ConditionalMark*();
2264 VAR idx : INTEGER;
2265 fTp : Sy.Type;
2266 (* ---------------------------- *)
2267 PROCEDURE blockOf(r : Record) : Id.BlkId;
2268 BEGIN
2269 IF r.bindTp # NIL THEN
2270 RETURN r.bindTp.idnt.dfScp(Id.BlkId);
2271 ELSE
2272 RETURN r.idnt.dfScp(Id.BlkId);
2273 END;
2274 END blockOf;
2275 (* ---------------------------- *)
2276 PROCEDURE ForceInterfaces(r : Record);
2277 VAR i : INTEGER;
2278 p : Sy.Type;
2279 BEGIN
2280 FOR i := 0 TO r.interfaces.tide-1 DO
2281 p := r.interfaces.a[i];
2282 p.force := Sy.forced;
2283 (*
2284 * WITH p : Pointer DO p.boundTp.force := Sy.forced END;
2285 *)
2286 WITH p : Pointer DO p.boundTp.force := Sy.forced ELSE END;
2287 END;
2288 END ForceInterfaces;
2289 (* ---------------------------- *)
2290 BEGIN
2291 IF (i.force = Sy.noEmit) THEN
2292 IF i.isImportedType() THEN
2293 i.force := Sy.partEmit;
2294 (*
2295 * IF ~CSt.special THEN i.force := Sy.partEmit END;
2296 *)
2297 INCL(blockOf(i).xAttr, Sy.need);
2298 IF i.bindTp # NIL THEN i.bindTp.ConditionalMark() END;
2299 IF (i.baseTp # NIL) &
2300 ~(i.baseTp IS Base) THEN i.baseTp.ConditionalMark() END;
2301 ELSE
2302 i.force := Sy.forced;
2303 IF i.bindTp # NIL THEN i.bindTp.UnconditionalMark() END;
2304
2305 IF (i.baseTp # NIL) & ~(i.baseTp IS Base) THEN
2306 i.baseTp.UnconditionalMark();
2307 (*
2308 * IF CSt.special THEN
2309 * i.baseTp.ConditionalMark();
2310 * ELSE
2311 * i.baseTp.UnconditionalMark();
2312 * END;
2313 *)
2314 END;
2315
2316 (*
2317 IF (i.baseTp # NIL) &
2318 ~(i.baseTp IS Base) THEN i.baseTp.UnconditionalMark() END;
2319 *)
2320 IF (i.interfaces.tide > 0) &
2321 i.isInterfaceType() THEN ForceInterfaces(i) END;
2322 END;
2323 FOR idx := 0 TO i.fields.tide-1 DO
2324 fTp := i.fields.a[idx].type;
2325 fTp.ConditionalMark();
2326 END;
2327 END;
2328 END ConditionalMark;
2329
2330 (* ---------------------------- *)
2331
2332 PROCEDURE (i : Array)ConditionalMark*();
2333 BEGIN
2334 IF (i.force = Sy.noEmit) THEN
2335 IF i.isImportedType() THEN
2336 INCL(i.idnt.dfScp(Id.BlkId).xAttr, Sy.need);
2337 ELSE
2338 i.force := Sy.forced;
2339 i.elemTp.ConditionalMark();
2340 END;
2341 END;
2342 END ConditionalMark;
2343
2344 (* ---------------------------- *)
2345
2346 PROCEDURE (i : Procedure)ConditionalMark*();
2347 BEGIN
2348 END ConditionalMark;
2349
2350 (* ---------------------------- *)
2351
2352 PROCEDURE (i : Overloaded)ConditionalMark*();
2353 BEGIN
2354 ASSERT(FALSE);
2355 END ConditionalMark;
2356
2357 (* ============================================================ *)
2358 (* Rules for unconditional marking don't care about imports. *)
2359 (* ============================================================ *)
2360
2361 PROCEDURE (i : Base)UnconditionalMark*();
2362 BEGIN END UnconditionalMark;
2363
2364 (* ---------------------------- *)
2365
2366 PROCEDURE (i : Opaque)UnconditionalMark*();
2367 BEGIN
2368 MarkModule(i);
2369 END UnconditionalMark;
2370
2371 (* ---------------------------- *)
2372
2373 PROCEDURE (i : Enum)UnconditionalMark*();
2374 BEGIN
2375 MarkModule(i);
2376 END UnconditionalMark;
2377
2378 (* ---------------------------- *)
2379
2380 PROCEDURE (i : Pointer)UnconditionalMark*();
2381 BEGIN
2382 i.boundTp.ConditionalMark();
2383 IF (i.force # Sy.forced) THEN
2384 i.force := Sy.forced;
2385 i.boundTp.ConditionalMark();
2386 MarkModule(i);
2387 END;
2388 END UnconditionalMark;
2389
2390 (* ---------------------------- *)
2391
2392 PROCEDURE (i : Record)UnconditionalMark*();
2393 VAR idx : INTEGER;
2394 fTp : Sy.Type;
2395 BEGIN
2396 IF (i.force # Sy.forced) THEN
2397 i.force := Sy.forced;
2398 IF i.baseTp # NIL THEN i.baseTp.UnconditionalMark() END;
2399 IF i.bindTp # NIL THEN i.bindTp.UnconditionalMark() END;
2400 FOR idx := 0 TO i.fields.tide-1 DO
2401 fTp := i.fields.a[idx].type;
2402 fTp.ConditionalMark();
2403 END;
2404 MarkModule(i);
2405 END;
2406 END UnconditionalMark;
2407
2408 (* ---------------------------- *)
2409
2410 PROCEDURE (i : Array)UnconditionalMark*();
2411 BEGIN
2412 IF (i.force # Sy.forced) THEN
2413 i.force := Sy.forced;
2414 i.elemTp.ConditionalMark();
2415 MarkModule(i);
2416 END;
2417 END UnconditionalMark;
2418
2419 (* ---------------------------- *)
2420
2421 PROCEDURE (i : Procedure)UnconditionalMark*();
2422 BEGIN
2423 END UnconditionalMark;
2424
2425 (* ---------------------------- *)
2426
2427 PROCEDURE (i : Overloaded)UnconditionalMark*();
2428 BEGIN
2429 ASSERT(FALSE);
2430 END UnconditionalMark;
2431
2432 (* ============================================================ *)
2433
2434 PROCEDURE (i : Pointer)superType*() : Sy.Type;
2435 BEGIN
2436 IF i.boundTp = NIL THEN RETURN NIL ELSE RETURN i.boundTp.superType() END;
2437 END superType;
2438
2439 (* ---------------------------- *)
2440
2441 PROCEDURE (i : Record)superType*() : Record;
2442 VAR valRec : BOOLEAN;
2443 baseT : Sy.Type;
2444 baseR : Record;
2445 BEGIN
2446 valRec := ~(Sy.clsTp IN i.xAttr);
2447 baseR := NIL;
2448 baseT := i.baseTp;
2449 IF valRec THEN
2450 baseR := CSt.ntvVal(Record);
2451 ELSIF ~baseT.isNativeObj() THEN
2452 WITH baseT : Record DO
2453 baseR := baseT;
2454 ELSE (* skip *)
2455 END;
2456 END;
2457 RETURN baseR;
2458 END superType;
2459
2460 (* ---------------------------- *)
2461
2462 PROCEDURE (i : Procedure)superType*() : Sy.Type;
2463 BEGIN
2464 RETURN NIL (* for the moment *)
2465 END superType;
2466
2467 (* ============================================================ *)
2468
2469 PROCEDURE (i : Pointer)boundRecTp*() : Sy.Type;
2470 BEGIN
2471 IF i.boundTp = NIL THEN RETURN NIL ELSE RETURN i.boundTp.boundRecTp() END;
2472 END boundRecTp;
2473
2474 (* ---------------------------- *)
2475
2476 PROCEDURE (i : Record)boundRecTp*() : Sy.Type;
2477 BEGIN
2478 RETURN i;
2479 END boundRecTp;
2480
2481 (* ---------------------------- *)
2482
2483 PROCEDURE (i : Event)boundRecTp*() : Sy.Type;
2484 BEGIN
2485 RETURN i.bndRec;
2486 END boundRecTp;
2487
2488 (* ---------------------------- *)
2489
2490 PROCEDURE (i : Opaque)boundRecTp*() : Sy.Type;
2491 BEGIN
2492 IF (i.resolved = NIL) OR
2493 (i.resolved IS Opaque) THEN
2494 RETURN NIL;
2495 ELSE
2496 RETURN i.resolved.boundRecTp();
2497 END;
2498 END boundRecTp;
2499
2500 (* ============================================================ *)
2501
2502 PROCEDURE (rec : Record)InsertMethod*(m : Sy.Idnt);
2503 VAR fwd : Sy.Idnt;
2504 mth : Id.MthId;
2505 ovl : Id.OvlId;
2506 BEGIN
2507 mth := m(Id.MthId);
2508 IF ~rec.symTb.enter(m.hash, m) THEN (* refused *)
2509 fwd := rec.symTb.lookup(m.hash);
2510 IF fwd IS Id.OvlId THEN
2511 ovl := fwd(Id.OvlId);
2512 fwd := ovl.findProc(mth);
2513 IF fwd = NIL THEN fwd := ovl; END;
2514 END;
2515 IF fwd.kind = Id.fwdMth THEN
2516 mth.CheckElab(fwd);
2517 rec.symTb.Overwrite(m.hash, m);
2518 ELSIF fwd.kind = Id.fwdPrc THEN
2519 fwd.IdError(63);
2520 ELSIF fwd IS Id.OvlId THEN
2521 ovl := fwd(Id.OvlId);
2522 (* currently disallow declaration of new overloaded method *)
2523 (* for name which is already overloaded *)
2524 fwd := findOverriddenProc(mth);
2525 IF fwd # NIL THEN
2526 Id.AppendProc(fwd(Id.OvlId).list,mth);
2527 ELSE
2528 m.IdErrorStr(207, rec.name());
2529 END;
2530 (* currently disallow declaration of new overloaded method *)
2531 (* for name which is NOT currently overloaded *)
2532 ELSE
2533 m.IdErrorStr(207, rec.name());
2534 END;
2535 ELSIF (Sy.noCpy IN rec.xAttr) & needOvlId(mth,rec) THEN
2536 ovl := newOvlIdent(mth,rec);
2537 rec.symTb.Overwrite(ovl.hash, ovl);
2538 END;
2539 (*
2540 * Special attribute processing for implement-only methods.
2541 *)
2542 IF (mth.kind = Id.conMth) &
2543 (* (mth.vMod = Sy.rdoMode) & *)
2544 ~(Id.newBit IN mth.mthAtt) THEN
2545 fwd := rec.inheritedFeature(mth);
2546 (*
2547 * Console.WriteString("Checking callable ");
2548 * Console.WriteString(rec.name());
2549 * Console.WriteString("::");
2550 * Console.WriteString(Sy.getName.ChPtr(mth));
2551 * Console.WriteLn;
2552 *)
2553 IF (fwd # NIL) & fwd(Id.MthId).callForbidden() THEN
2554 INCL(mth.mthAtt, Id.noCall);
2555 (*
2556 * Console.WriteString("Marking noCall on ");
2557 * Console.WriteString(rec.name());
2558 * Console.WriteString("::");
2559 * Console.WriteString(Sy.getName.ChPtr(mth));
2560 * Console.WriteLn;
2561 *)
2562 END;
2563 END;
2564 Sy.AppendIdnt(rec.methods, m);
2565 END InsertMethod;
2566
2567 (* ---------------------------- *)
2568
2569 PROCEDURE (bas : Record)superCtor*(pTp : Procedure) : Id.PrcId,NEW;
2570 VAR inx : INTEGER;
2571 stI : Sy.Idnt;
2572 BEGIN
2573 FOR inx := 0 TO bas.statics.tide-1 DO
2574 stI := bas.statics.a[inx];
2575 IF (stI.kind = Id.ctorP) &
2576 pTp.formsMatch(stI.type(Procedure)) THEN RETURN stI(Id.PrcId) END;
2577 END;
2578 RETURN NIL;
2579 END superCtor;
2580
2581
2582 PROCEDURE (rec : Record)AppendCtor*(p : Sy.Idnt);
2583 VAR prc : Id.Procs;
2584 (* ----------------------------- *)
2585 PROCEDURE onList(IN lst : Sy.IdSeq; proc : Id.Procs) : BOOLEAN;
2586 VAR inx : INTEGER;
2587 stI : Sy.Idnt;
2588 pTp : Procedure;
2589 BEGIN
2590 pTp := proc.type(Procedure);
2591 (*
2592 * Return true if the proc is already on the list.
2593 * Signal error if a different matching proc exists.
2594 *
2595 * The matching constructor in the list could
2596 * have any name. So we simply search the list
2597 * looking for *any* constructor which matches.
2598 *)
2599 FOR inx := 0 TO lst.tide-1 DO
2600 stI := lst.a[inx];
2601 IF (stI.kind = Id.ctorP) & pTp.formsMatch(stI.type(Procedure)) THEN
2602 IF stI = proc THEN RETURN TRUE ELSE proc.IdError(148) END;
2603 END;
2604 END;
2605 RETURN FALSE;
2606 END onList;
2607 (* ----------------------------- *)
2608 PROCEDURE mustList(recT : Record; proc : Id.Procs) : BOOLEAN;
2609 VAR prcT : Procedure;
2610 prcN : INTEGER;
2611 base : Sy.Type;
2612 list : BOOLEAN;
2613 BEGIN
2614 prcT := proc.type(Procedure);
2615 base := recT.baseTp;
2616 (*
2617 * Check for duplicate constructors with same signature
2618 *)
2619 list := onList(recT.statics, proc);
2620 IF (proc.basCll = NIL) OR
2621 (proc.basCll.actuals.tide = 0) THEN
2622 (*
2623 * Trying to call the noarg constructor
2624 * of the super type.
2625 *)
2626 prcN := prcT.formals.tide;
2627 WITH base : Record DO
2628 (*
2629 * This is allowed, unless the noNew flag is set
2630 * in the supertype.
2631 *)
2632 IF Sy.noNew IN base.xAttr THEN proc.IdError(203) END;
2633 RETURN ~list & (prcN # 0); (* never list a no-arg constructor *)
2634 | base : Base DO
2635 (*
2636 * This record extends the ANYREC type. As
2637 * a concession we allow no-arg constructors.
2638 *)
2639 RETURN ~list & (prcN # 0); (* never list a no-arg constructor *)
2640 END;
2641 ELSE
2642 (*
2643 * This calls an explicit constructor.
2644 *)
2645 RETURN ~list & (proc.basCll.sprCtor # NIL);
2646 END;
2647 END mustList;
2648 (* ----------------------------- *)
2649 BEGIN
2650 prc := p(Id.Procs);
2651 (*
2652 * First, we must check that there is a super
2653 * constructor with the correct signature.
2654 *)
2655 IF mustList(rec, prc) THEN Sy.AppendIdnt(rec.statics, p) END;
2656 IF prc.body # NIL THEN prc.body.StmtAttr(prc) END;;
2657 IF prc.rescue # NIL THEN prc.rescue.StmtAttr(prc) END;;
2658 END AppendCtor;
2659
2660 (* ---------------------------- *)
2661
2662 PROCEDURE (i : Procedure)boundRecTp*() : Sy.Type, EXTENSIBLE;
2663 BEGIN
2664 IF i.receiver = NIL THEN RETURN NIL ELSE RETURN i.receiver.boundRecTp() END
2665 END boundRecTp;
2666
2667 (* ============================================================ *)
2668
2669 PROCEDURE (i : Record)inheritedFeature*(id : Sy.Idnt) : Sy.Idnt;
2670 VAR
2671 rec : Record;
2672 idnt : Sy.Idnt;
2673 BEGIN
2674 rec := i; idnt := NIL;
2675 rec := baseRecTp(rec);
2676 WHILE (idnt = NIL) & (rec # NIL) DO
2677 idnt := rec.symTb.lookup(id.hash);
2678 IF (idnt # NIL) & (idnt IS Id.OvlId) & (id IS Id.Procs) THEN
2679 idnt := idnt(Id.OvlId).findProc(id(Id.Procs));
2680 END;
2681 rec := baseRecTp(rec);
2682 END;
2683 RETURN idnt;
2684 END inheritedFeature;
2685
2686 (* ============================================================ *)
2687 (* Diagnostic methods *)
2688 (* ============================================================ *)
2689
2690 PROCEDURE (s : Base)Diagnose*(i : INTEGER);
2691 BEGIN
2692 s.SuperDiag(i);
2693 END Diagnose;
2694
2695 (* ---------------------------------------------------- *)
2696
2697 PROCEDURE (s : Opaque)Diagnose*(i : INTEGER);
2698 VAR name : Lv.CharOpen;
2699 BEGIN
2700 s.SuperDiag(i);
2701 IF s.resolved # NIL THEN
2702 name := s.resolved.name();
2703 H.Indent(i+2); Console.WriteString("alias of " + name^);
2704 s.resolved.SuperDiag(i+2);
2705 ELSE
2706 H.Indent(i+2); Console.WriteString("opaque not resolved"); Console.WriteLn;
2707 END;
2708 END Diagnose;
2709
2710 (* ---------------------------------------------------- *)
2711
2712 PROCEDURE (s : Array)Diagnose*(i : INTEGER);
2713 BEGIN
2714 s.SuperDiag(i);
2715 H.Indent(i+2); Console.WriteString("Element type");
2716 IF s.elemTp # NIL THEN
2717 Console.WriteLn;
2718 s.elemTp.Diagnose(i+2);
2719 ELSE
2720 Console.WriteString(" NIL"); Console.WriteLn;
2721 END;
2722 END Diagnose;
2723
2724 (* ---------------------------------------------------- *)
2725
2726 PROCEDURE (s : Record)Diagnose*(i : INTEGER);
2727 VAR ix : INTEGER;
2728 id : Sy.Idnt;
2729 nm : FileNames.NameString;
2730 BEGIN
2731 s.SuperDiag(i);
2732 CASE s.recAtt OF
2733 | isAbs : Console.WriteString(" ABSTRACT"); Console.WriteLn;
2734 | limit : Console.WriteString(" LIMITED"); Console.WriteLn;
2735 | extns : Console.WriteString(" EXTENSIBLE"); Console.WriteLn;
2736 | iFace : Console.WriteString(" INTERFACE"); Console.WriteLn;
2737 ELSE
2738 END;
2739 IF Sy.fnInf IN s.xAttr THEN
2740 Console.WriteString(" [foreign-interface]"); Console.WriteLn;
2741 ELSIF Sy.isFn IN s.xAttr THEN
2742 Console.WriteString(" [foreign-class]"); Console.WriteLn;
2743 END;
2744 H.Indent(i); Console.WriteString("fields"); Console.WriteLn;
2745 FOR ix := 0 TO s.fields.tide-1 DO
2746 id := s.fields.a[ix];
2747 IF id # NIL THEN id.Diagnose(i+4) END;
2748 END;
2749 IF CSt.verbose THEN
2750 H.Indent(i); Console.WriteString("methods"); Console.WriteLn;
2751 FOR ix := 0 TO s.methods.tide-1 DO
2752 id := s.methods.a[ix];
2753 IF id # NIL THEN id.Diagnose(i+4) END;
2754 END;
2755 H.Indent(i); Console.WriteString("names"); Console.WriteLn;
2756 s.symTb.Dump(i+4);
2757 END;
2758 IF s.baseTp # NIL THEN
2759 H.Indent(i); Console.WriteString("base type"); Console.WriteLn;
2760 s.baseTp.Diagnose(i+4);
2761 END;
2762 Sy.DoXName(i, s.xName);
2763 Sy.DoXName(i, s.extrnNm);
2764 Sy.DoXName(i, s.scopeNm);
2765 END Diagnose;
2766
2767 (* ---------------------------------------------------- *)
2768
2769 PROCEDURE (s : Enum)Diagnose*(i : INTEGER);
2770 VAR ix : INTEGER;
2771 id : Sy.Idnt;
2772 nm : FileNames.NameString;
2773 BEGIN
2774 s.SuperDiag(i);
2775 H.Indent(i); Console.WriteString("consts"); Console.WriteLn;
2776 FOR ix := 0 TO s.statics.tide-1 DO
2777 id := s.statics.a[ix];
2778 IF id # NIL THEN id.Diagnose(i+4) END;
2779 END;
2780 Sy.DoXName(i, s.xName);
2781 END Diagnose;
2782
2783 (* ---------------------------------------------------- *)
2784
2785 PROCEDURE (s : Pointer)Diagnose*(i : INTEGER);
2786 BEGIN
2787 s.SuperDiag(i);
2788 H.Indent(i+2); Console.WriteString("Bound type");
2789 IF s.boundTp # NIL THEN
2790 Console.WriteLn;
2791 s.boundTp.Diagnose(i+2);
2792 ELSE
2793 Console.WriteString(" NIL"); Console.WriteLn;
2794 END;
2795 Sy.DoXName(i, s.xName);
2796 END Diagnose;
2797
2798 (* ---------------------------------------------------- *)
2799 PROCEDURE^ qualname(id : Sy.Idnt) : Lv.CharOpen;
2800 (* ---------------------------------------------------- *)
2801
2802 PROCEDURE (s : Procedure)DiagFormalType*(i : INTEGER);
2803 VAR ix : INTEGER;
2804 nm : FileNames.NameString;
2805 BEGIN
2806 IF s.formals.tide = 0 THEN
2807 Console.WriteString("()");
2808 ELSE
2809 Console.Write("(");
2810 Console.WriteLn;
2811 FOR ix := 0 TO s.formals.tide-1 DO
2812 H.Indent(i+4);
2813 s.formals.a[ix].DiagPar();
2814 IF ix < s.formals.tide-1 THEN Console.Write(";"); Console.WriteLn END;
2815 END;
2816 Console.Write(")");
2817 END;
2818 IF s.retType # NIL THEN
2819 Console.WriteString(" : ");
2820 Console.WriteString(qualname(s.retType.idnt));
2821 END;
2822 END DiagFormalType;
2823
2824 (* ---------------------------------------------------- *)
2825
2826 PROCEDURE (s : Procedure)Diagnose*(i : INTEGER);
2827 VAR ix : INTEGER;
2828 BEGIN
2829 H.Indent(i);
2830 IF s.receiver # NIL THEN
2831 Console.Write("(");
2832 Console.WriteString(s.name());
2833 Console.Write(")");
2834 END;
2835 Console.WriteString("PROC");
2836 s.DiagFormalType(i+4);
2837 Console.WriteLn;
2838 Sy.DoXName(i, s.xName);
2839 END Diagnose;
2840
2841 (* ---------------------------------------------------- *)
2842
2843 PROCEDURE (s : Overloaded)Diagnose*(i : INTEGER);
2844 BEGIN
2845 H.Indent(i);
2846 Console.WriteString("Overloaded Type");
2847 Console.WriteLn;
2848 END Diagnose;
2849
2850 (* ---------------------------------------------------- *)
2851 (* ---------------------------------------------------- *)
2852
2853 PROCEDURE qualname(id : Sy.Idnt) : Lv.CharOpen;
2854 BEGIN
2855 IF id = NIL THEN
2856 RETURN nilStr;
2857 ELSIF (id.dfScp = NIL) OR (id.dfScp.kind = Id.modId) THEN
2858 RETURN Sy.getName.ChPtr(id);
2859 ELSE
2860 RETURN Lv.strToCharOpen
2861 (Sy.getName.ChPtr(id.dfScp)^ + "." + Sy.getName.ChPtr(id)^);
2862 END;
2863 END qualname;
2864
2865 (* ---------------------------------------------------- *)
2866
2867 PROCEDURE (s : Base)name*() : Lv.CharOpen;
2868 BEGIN
2869 IF s.idnt = NIL THEN
2870 RETURN Lv.strToCharOpen("Anon-base-type");
2871 ELSE
2872 RETURN Sy.getName.ChPtr(s.idnt);
2873 END;
2874 END name;
2875
2876 (* ---------------------------------------------------- *)
2877
2878 PROCEDURE (s : Enum)name*() : Lv.CharOpen;
2879 BEGIN
2880 IF s.idnt = NIL THEN
2881 RETURN Lv.strToCharOpen("Anon-enum-type");
2882 ELSE
2883 RETURN Sy.getName.ChPtr(s.idnt);
2884 END;
2885 END name;
2886
2887 (* ---------------------------------------------------- *)
2888
2889 PROCEDURE (s : Opaque)name*() : Lv.CharOpen;
2890 BEGIN
2891 IF s.idnt = NIL THEN
2892 IF s.kind = namTp THEN
2893 RETURN Lv.strToCharOpen("Anon-opaque");
2894 ELSE
2895 RETURN Lv.strToCharOpen("Anon-temporary");
2896 END;
2897 ELSE
2898 RETURN qualname(s.idnt);
2899 END;
2900 END name;
2901
2902 (* ---------------------------------------------------- *)
2903
2904 PROCEDURE (s : Array)name*() : Lv.CharOpen, EXTENSIBLE;
2905 VAR elNm : Lv.CharOpen;
2906 BEGIN
2907 IF s.idnt = NIL THEN
2908 IF s.elemTp = NIL THEN elNm := nilStr ELSE elNm := s.elemTp.name() END;
2909 IF s.length = 0 THEN
2910 RETURN Lv.strToCharOpen("ARRAY OF " + elNm^);
2911 ELSE
2912 RETURN Lv.strToCharOpen("ARRAY " +
2913 Lv.intToCharOpen(s.length)^ +
2914 " OF " +
2915 elNm^);
2916 END;
2917 ELSE
2918 RETURN qualname(s.idnt);
2919 END;
2920 END name;
2921
2922 (* ---------------------------------------------------- *)
2923
2924 PROCEDURE (s : Vector)name*() : Lv.CharOpen;
2925 VAR elNm : Lv.CharOpen;
2926 BEGIN
2927 IF s.idnt = NIL THEN
2928 IF s.elemTp = NIL THEN elNm := nilStr ELSE elNm := s.elemTp.name() END;
2929 RETURN Lv.strToCharOpen("VECTOR OF " + elNm^);
2930 ELSE
2931 RETURN qualname(s.idnt);
2932 END;
2933 END name;
2934
2935 (* ---------------------------------------------------- *)
2936
2937 PROCEDURE cmpndName(s : Record) : Lv.CharOpen;
2938 (* Returns the name of a compound type as a list
2939 * of its (optional) class and its interfaces *)
2940 VAR
2941 itfList : Lv.CharOpen;
2942 i : INTEGER;
2943 BEGIN
2944 itfList := Lv.strToCharOpen("(");
2945 IF s.baseTp # NIL THEN
2946 itfList := Lv.strToCharOpen(itfList^ + s.baseTp.name()^ + ",");
2947 END;
2948 FOR i := 0 TO s.interfaces.tide - 1 DO
2949 itfList := Lv.strToCharOpen(itfList^ + s.interfaces.a[i].name()^);
2950 IF i # s.interfaces.tide - 1 THEN
2951 itfList := Lv.strToCharOpen(itfList^ + ",");
2952 END;
2953 END;
2954 RETURN Lv.strToCharOpen(itfList^ + ")");
2955 END cmpndName;
2956
2957 (* ---------------------------------------------------- *)
2958
2959 PROCEDURE (s : Record)name*() : Lv.CharOpen;
2960 BEGIN
2961 IF s.bindTp # NIL THEN
2962 RETURN Lv.strToCharOpen(s.bindTp.name()^ + "^");
2963 ELSIF s.idnt = NIL THEN
2964 IF s.recAtt = cmpnd THEN
2965 RETURN cmpndName(s);
2966 ELSE
2967 RETURN Lv.strToCharOpen("Anon-record");
2968 END;
2969 ELSE
2970 RETURN qualname(s.idnt);
2971 END;
2972 END name;
2973
2974 (* ---------------------------------------------------- *)
2975
2976 PROCEDURE (s : Pointer)name*() : Lv.CharOpen;
2977 VAR elNm : Lv.CharOpen;
2978 BEGIN
2979 IF s.idnt = NIL THEN
2980 IF s.boundTp = NIL THEN elNm := nilStr ELSE elNm := s.boundTp.name() END;
2981 RETURN Lv.strToCharOpen("POINTER TO " + elNm^);
2982 ELSE
2983 RETURN qualname(s.idnt);
2984 END;
2985 END name;
2986
2987 (* ---------------------------------------------------- *)
2988
2989 PROCEDURE (s : Procedure)name*() : Lv.CharOpen;
2990 BEGIN
2991 IF s.idnt = NIL THEN
2992 RETURN Lv.strToCharOpen("Anon-opaque-type");
2993 ELSE
2994 RETURN qualname(s.idnt);
2995 END;
2996 END name;
2997
2998 (* ---------------------------------------------------- *)
2999
3000 PROCEDURE (s : Overloaded)name*() : Lv.CharOpen;
3001 BEGIN
3002 RETURN Lv.strToCharOpen("Overloaded-type");
3003 END name;
3004
3005 (* ============================================================ *)
3006 BEGIN (* ====================================================== *)
3007 NEW(anyRecTp);
3008 NEW(anyPtrTp);
3009 nilStr := Lv.strToCharOpen("<nil>");
3010 END TypeDesc. (* ============================================== *)
3011 (* ============================================================ *)
[FORK] Old GPCP with patches
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024