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 / SymReader.cp
1 MODULE SymReader;
2 (* ========================================================================= *)
3 (* *)
4 (* Symbol file reading module for the .NET to Gardens Point Component *)
5 (* Pascal Symbols tool. *)
6 (* Copyright (c) Siu-Yuen Chan 2001. *)
7 (* *)
8 (* This module reads Gardens Point Component Pascal (GPCP) symbol files *)
9 (* and stores all meta information read into METASTORE (defined by *)
10 (* MetaStore module). *)
11 (* ========================================================================= *)
12
13 IMPORT
14 Error,
15 GPFiles,
16 GF := GPBinFiles,
17 MS := MetaStore,
18 MP := MetaParser,
19 ST := AscString,
20 RTS;
21
22 (* ========================================================================= *
23 // Collected syntax ---
24 //
25 // SymFile = Header [String (falSy | truSy | <other attribute>)]
26 // {Import | Constant | Variable | Type | Procedure}
27 // TypeList Key.
28 // -- optional String is external name.
29 // -- falSy ==> Java class
30 // -- truSy ==> Java interface
31 // -- others ...
32 // Header = magic modSy Name.
33 // VersionName= numSy longint numSy longint numSy longint.
34 // -- mj# mn# bld rv# 8xbyte extract
35 // Import = impSy Name [String] Key.
36 // -- optional string is explicit external name of class
37 // Constant = conSy Name Literal.
38 // Variable = varSy Name TypeOrd.
39 // Type = typSy Name TypeOrd.
40 // Procedure = prcSy Name [String] FormalType.
41 // -- optional string is explicit external name of procedure
42 // Method = mthSy Name byte byte TypeOrd [String] FormalType.
43 // -- optional string is explicit external name of method
44 // FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd} endFm.
45 // -- optional phrase is return type for proper procedures
46 // TypeOrd = ordinal.
47 // TypeHeader = tDefS Ord [fromS Ord Name].
48 // -- optional phrase occurs if:
49 // -- type not from this module, i.e. indirect export
50 // TypeList = start { Array | Record | Pointer | ProcType } close.
51 // Array = TypeHeader arrSy TypeOrd (Byte | Number | <empty>) endAr.
52 // -- nullable phrase is array length for fixed length arrays
53 // Pointer = TypeHeader ptrSy TypeOrd.
54 // Event = TypeHeader evtSy FormalType.
55 // ProcType = TypeHeader pTpSy FormalType.
56 // Record = TypeHeader recSy recAtt [truSy | falSy]
57 // [basSy TypeOrd] [iFcSy {basSy TypeOrd}]
58 // {Name TypeOrd} {Method} endRc.
59 // -- truSy ==> is an extension of external interface
60 // -- falSy ==> is an extension of external class
61 // -- basSy option defines base type, if not ANY / j.l.Object
62 // NamedType = TypeHeader
63 // Name = namSy byte UTFstring.
64 // Literal = Number | String | Set | Char | Real | falSy | truSy.
65 // Byte = bytSy byte.
66 // String = strSy UTFstring.
67 // Number = numSy longint.
68 // Real = fltSy ieee-double.
69 // Set = setSy integer.
70 // Key = keySy integer..
71 // Char = chrSy unicode character.
72 //
73 // Notes on the syntax:
74 // All record types must have a Name field, even though this is often
75 // redundant. The issue is that every record type (including those that
76 // are anonymous in CP) corresponds to a IR class, and the definer
77 // and the user of the class _must_ agree on the IR name of the class.
78 // The same reasoning applies to procedure types, which must have equal
79 // interface names in all modules.
80 // ======================================================================== *)
81
82
83 CONST
84 modSy = ORD('H'); namSy = ORD('$'); bytSy = ORD('\');
85 numSy = ORD('#'); chrSy = ORD('c'); strSy = ORD('s');
86 fltSy = ORD('r'); falSy = ORD('0'); truSy = ORD('1');
87 impSy = ORD('I'); setSy = ORD('S'); keySy = ORD('K');
88 conSy = ORD('C'); typSy = ORD('T'); tDefS = ORD('t');
89 prcSy = ORD('P'); retSy = ORD('R'); mthSy = ORD('M');
90 varSy = ORD('V'); parSy = ORD('p'); start = ORD('&');
91 close = ORD('!'); recSy = ORD('{'); endRc = ORD('}');
92 frmSy = ORD('('); fromS = ORD('@'); endFm = ORD(')');
93 arrSy = ORD('['); endAr = ORD(']'); pTpSy = ORD('%');
94 ptrSy = ORD('^'); basSy = ORD('+'); eTpSy = ORD('e');
95 iFcSy = ORD('~'); evtSy = ORD('v');
96
97 CONST
98 tOffset* = 16; (* backward compatibility with JavaVersion *)
99 iOffset = 1;
100
101 CONST
102 magic = 0DEADD0D0H;
103 syMag = 0D0D0DEADH;
104 dumped* = -1;
105
106 CONST (* record attributes *)
107 noAtt* = ORD(MS.noAtt); (* no attribute *)
108 abstr* = ORD(MS.Rabstr); (* Is ABSTRACT *)
109 limit* = ORD(MS.Rlimit); (* Is LIMIT *)
110 extns* = ORD(MS.Rextns); (* Is EXTENSIBLE *)
111 iFace* = ORD(MS.RiFace); (* Is INTERFACE *)
112 nnarg* = ORD(MS.Rnnarg); (* Has NO NoArg Constructor ( cannot use NEW() ) *)
113 valTp* = ORD(MS.RvalTp); (* ValueType *)
114
115
116 TYPE
117 (*
118 CharOpen* = POINTER TO ARRAY OF CHAR;
119 *)
120 CharOpen* = ST.CharOpen;
121
122 TypeSeq = POINTER TO
123 RECORD
124 tide: INTEGER;
125 high: INTEGER;
126 a: POINTER TO ARRAY OF MS.Type;
127 END;
128
129 ScopeSeq = POINTER TO
130 RECORD
131 tide: INTEGER;
132 high: INTEGER;
133 a: POINTER TO ARRAY OF MS.Namespace;
134 END;
135
136 Reader* = POINTER TO
137 RECORD
138 file: GF.FILE;
139 fasb: MS.Assembly;
140 fns : MS.Namespace;
141 sSym : INTEGER; (* the symbol read in *)
142 cAtt : CHAR; (* character attribute *)
143 iAtt : INTEGER; (* integer attribute *)
144 lAtt : LONGINT; (* long attribute *)
145 rAtt : REAL; (* real attribute *)
146 sAtt : ARRAY 128 OF CHAR; (* string attribute *)
147 sArray: ScopeSeq;
148 tArray: TypeSeq;
149 tNxt : INTEGER;
150 END;
151
152 (* for building temporary formal list *)
153 FmlList = POINTER TO
154 RECORD
155 fml: MS.Formal;
156 nxt: FmlList;
157 END;
158
159
160
161 PROCEDURE InitTypeSeq(seq: TypeSeq; capacity : INTEGER);
162 BEGIN
163 NEW(seq.a, capacity);
164 seq.high := capacity-1;
165 seq.tide := 0;
166 END InitTypeSeq;
167
168
169 PROCEDURE AppendType(VAR seq : TypeSeq; elem : MS.Type);
170 VAR
171 temp : POINTER TO ARRAY OF MS.Type;
172 i : INTEGER;
173 BEGIN
174 IF seq.a = NIL THEN
175 InitTypeSeq(seq, 2);
176 ELSIF seq.tide > seq.high THEN (* must expand *)
177 temp := seq.a;
178 seq.high := seq.high * 2 + 1;
179 NEW(seq.a, (seq.high+1));
180 FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
181 END; (* IF *)
182 seq.a[seq.tide] := elem; INC(seq.tide);
183 END AppendType;
184
185
186 PROCEDURE InitScopeSeq(seq: ScopeSeq; capacity : INTEGER);
187 BEGIN
188 NEW(seq.a, capacity);
189 seq.high := capacity-1;
190 seq.tide := 0;
191 END InitScopeSeq;
192
193
194 PROCEDURE AppendScope(VAR seq : ScopeSeq; elem : MS.Namespace);
195 VAR
196 temp : POINTER TO ARRAY OF MS.Namespace;
197 i : INTEGER;
198 BEGIN
199 IF seq.a = NIL THEN
200 InitScopeSeq(seq, 2);
201 ELSIF seq.tide > seq.high THEN (* must expand *)
202 temp := seq.a;
203 seq.high := seq.high * 2 + 1;
204 NEW(seq.a, (seq.high+1));
205 FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
206 END; (* IF *)
207 seq.a[seq.tide] := elem; INC(seq.tide);
208 END AppendScope;
209
210
211 PROCEDURE (rd: Reader) Read(): INTEGER, NEW;
212 BEGIN
213 RETURN GF.readByte(rd.file);
214 END Read;
215
216
217 PROCEDURE (rd: Reader) ReadChar(): CHAR, NEW;
218 BEGIN
219 RETURN CHR(rd.Read() * 256 + rd.Read());
220 END ReadChar;
221
222
223 PROCEDURE (rd: Reader) ReadInt(): INTEGER, NEW;
224 BEGIN [UNCHECKED_ARITHMETIC]
225 (* overflow checking off here *)
226 RETURN ((rd.Read() * 256 + rd.Read()) * 256 + rd.Read()) * 256 + rd.Read();
227 END ReadInt;
228
229
230 PROCEDURE (rd: Reader) ReadLong(): LONGINT, NEW;
231 VAR
232 result : LONGINT;
233 index : INTEGER;
234 BEGIN [UNCHECKED_ARITHMETIC]
235 (* overflow checking off here *)
236 result := rd.Read();
237 FOR index := 1 TO 7 DO
238 result := result * 256 + rd.Read();
239 END; (* FOR *)
240 RETURN result;
241 END ReadLong;
242
243
244 PROCEDURE (rd: Reader) ReadReal(): REAL, NEW;
245 VAR
246 result : LONGINT;
247 BEGIN
248 result := rd.ReadLong();
249 RETURN RTS.longBitsToReal(result);
250 END ReadReal;
251
252
253 PROCEDURE (rd: Reader) ReadOrd(): INTEGER, NEW;
254 VAR
255 chr : INTEGER;
256 BEGIN
257 chr := rd.Read();
258 IF chr <= 07FH THEN RETURN chr;
259 ELSE
260 DEC(chr, 128);
261 RETURN chr + rd.Read() * 128;
262 END; (* IF *)
263 END ReadOrd;
264
265
266 PROCEDURE (rd: Reader) ReadUTF(OUT nam : ARRAY OF CHAR), NEW;
267 CONST
268 bad = "Bad UTF-8 string";
269 VAR
270 num : INTEGER;
271 bNm : INTEGER;
272 idx : INTEGER;
273 chr : INTEGER;
274 BEGIN
275 num := 0;
276 bNm := rd.Read() * 256 + rd.Read();
277 FOR idx := 0 TO bNm-1 DO
278 chr := rd.Read();
279 IF chr <= 07FH THEN (* [0xxxxxxx] *)
280 nam[num] := CHR(chr); INC(num);
281 ELSIF chr DIV 32 = 06H THEN (* [110xxxxx,10xxxxxx] *)
282 bNm := chr MOD 32 * 64;
283 chr := rd.Read();
284 IF chr DIV 64 = 02H THEN
285 nam[num] := CHR(bNm + chr MOD 64); INC(num);
286 ELSE
287 RTS.Throw(bad);
288 END; (* IF *)
289 ELSIF chr DIV 16 = 0EH THEN (* [1110xxxx,10xxxxxx,10xxxxxx] *)
290 bNm := chr MOD 16 * 64;
291 chr := rd.Read();
292 IF chr DIV 64 = 02H THEN
293 bNm := (bNm + chr MOD 64) * 64;
294 chr := rd.Read();
295 IF chr DIV 64 = 02H THEN
296 nam[num] := CHR(bNm + chr MOD 64); INC(num);
297 ELSE
298 RTS.Throw(bad);
299 END; (* IF *)
300 ELSE
301 RTS.Throw(bad);
302 END; (* IF *)
303 ELSE
304 RTS.Throw(bad);
305 END; (* IF *)
306 END; (* FOR *)
307 nam[num] := 0X;
308 END ReadUTF;
309
310
311 PROCEDURE (rd: Reader) GetSym(), NEW;
312 BEGIN
313 rd.sSym := rd.Read();
314 CASE rd.sSym OF
315 | namSy :
316 rd.iAtt := rd.Read(); rd.ReadUTF(rd.sAtt);
317 | strSy :
318 rd.ReadUTF(rd.sAtt);
319 | retSy, fromS, tDefS, basSy :
320 rd.iAtt := rd.ReadOrd();
321 | bytSy :
322 rd.iAtt := rd.Read();
323 | keySy, setSy :
324 rd.iAtt := rd.ReadInt();
325 | numSy :
326 rd.lAtt := rd.ReadLong();
327 | fltSy :
328 rd.rAtt := rd.ReadReal();
329 | chrSy :
330 rd.cAtt := rd.ReadChar();
331 ELSE (* nothing to do *)
332 END; (* CASE *)
333 END GetSym;
334
335
336 PROCEDURE (rd: Reader) Abandon(), NEW;
337 BEGIN
338 RTS.Throw(ST.StrCat(ST.ToChrOpen("Bad symbol file format - "),
339 ST.ToChrOpen(GF.getFullPathName(rd.file))));
340 END Abandon;
341
342
343 PROCEDURE (rd: Reader) ReadPast(sym : INTEGER), NEW;
344 BEGIN
345 IF rd.sSym # sym THEN rd.Abandon(); END;
346 rd.GetSym();
347 END ReadPast;
348
349
350 PROCEDURE NewReader*(file: GF.FILE) : Reader;
351 VAR
352 new: Reader;
353 BEGIN
354 NEW(new);
355 NEW(new.tArray);
356 NEW(new.sArray);
357 new.file := file;
358 InitTypeSeq(new.tArray, 8);
359 InitScopeSeq(new.sArray, 8);
360 new.tNxt := tOffset;
361 RETURN new;
362 END NewReader;
363
364
365 PROCEDURE (rd: Reader) TypeOf(ord : INTEGER): MS.Type, NEW;
366 VAR
367 newT : MS.TempType;
368 indx : INTEGER;
369 rslt : MS.Type;
370 BEGIN
371 IF ord < tOffset THEN (* builtin type *)
372 rslt := MS.baseTypeArray[ord];
373 IF rslt = NIL THEN
374 rslt := MS.MakeDummyPrimitive(ord);
375 END; (* IF *)
376 RETURN rslt;
377 ELSIF ord - tOffset < rd.tArray.tide THEN (* type already read *)
378 RETURN rd.tArray.a[ord - tOffset];
379 ELSE
380 indx := rd.tArray.tide + tOffset;
381 REPEAT
382 (* create types and append to tArray until ord is reached *)
383 (* details of these types are to be fixed later *)
384 newT := MS.NewTempType();
385 newT.SetTypeOrd(indx); INC(indx);
386 AppendType(rd.tArray, newT);
387 UNTIL indx > ord;
388 RETURN newT;
389 END; (* IF *)
390 END TypeOf;
391
392
393 PROCEDURE (rd: Reader) GetTypeFromOrd(): MS.Type, NEW;
394 VAR
395 ord : INTEGER;
396 BEGIN
397 ord := rd.ReadOrd();
398 rd.GetSym();
399 RETURN rd.TypeOf(ord);
400 END GetTypeFromOrd;
401
402
403 PROCEDURE (rd: Reader) GetHeader(modname: CharOpen), NEW;
404 VAR
405 marker: INTEGER;
406 idx1, idx2: INTEGER;
407 scopeNm: CharOpen;
408 str: CharOpen;
409 BEGIN
410 marker := rd.ReadInt();
411 IF marker = RTS.loInt(magic) THEN
412 (* normal case, nothing to do *)
413 ELSIF marker = RTS.loInt(syMag) THEN
414 (* should never reach here for foreign module *)
415 ELSE
416 (* Error *)
417 Error.WriteString("File <");
418 Error.WriteString(GF.getFullPathName(rd.file));
419 Error.WriteString("> wrong format"); Error.WriteLn;
420 RETURN;
421 END; (* IF *)
422 rd.GetSym();
423 rd.ReadPast(modSy);
424 IF rd.sSym = namSy THEN
425 IF modname^ # ST.ToChrOpen(rd.sAtt)^ THEN
426 Error.WriteString("Wrong name in symbol file. Expected <");
427 Error.WriteString(modname); Error.WriteString(">, found <");
428 Error.WriteString(rd.sAtt); Error.WriteString(">"); Error.WriteLn;
429 HALT(1);
430 END; (* IF *)
431 rd.GetSym();
432 ELSE
433 RTS.Throw("Bad symfile header");
434 END; (* IF *)
435 IF rd.sSym = strSy THEN (* optional name *)
436 (* non-GPCP module *)
437 scopeNm := ST.ToChrOpen(rd.sAtt);
438 idx1 := ST.StrChr(scopeNm, '['); idx2 := ST.StrChr(scopeNm, ']');
439 str := ST.SubStr(scopeNm,idx1+1, idx2-1);
440 rd.fasb := MS.GetAssemblyByName(ST.StrSubChr(str,'.','_'));
441 ASSERT(rd.fasb # NIL);
442 str := ST.SubStr(scopeNm, idx2+1, LEN(scopeNm)-1);
443 rd.fns := rd.fasb.GetNamespace(str);
444 ASSERT(rd.fns # NIL);
445
446 rd.GetSym();
447 IF (rd.sSym = falSy) OR (rd.sSym = truSy) THEN
448 rd.GetSym();
449 ELSE
450 RTS.Throw("Bad explicit name");
451 END; (* IF *)
452 ELSE
453 (* GPCP module *)
454 rd.fasb := MS.GetAssemblyByName(modname);
455 ASSERT(rd.fasb # NIL);
456 rd.fns := rd.fasb.GetNamespace(modname);
457 ASSERT(rd.fns # NIL);
458 END; (* IF *)
459 END GetHeader;
460
461
462 PROCEDURE (rd: Reader) GetVersionName(), NEW;
463 VAR
464 i: INTEGER;
465 version: MS.Version;
466 token: MS.PublicKeyToken;
467 BEGIN
468 (* get the assembly version *)
469 ASSERT(rd.sSym = numSy); NEW(version);
470 version[MS.Major] := RTS.loShort(RTS.hiInt(rd.lAtt));
471 version[MS.Minor] := RTS.loShort(RTS.loInt(rd.lAtt));
472 rd.GetSym();
473 version[MS.Build] := RTS.loShort(RTS.hiInt(rd.lAtt));
474 version[MS.Revis] := RTS.loShort(RTS.loInt(rd.lAtt));
475 rd.fasb.SetVersion(version);
476 (* get the assembly public key token *)
477 rd.sSym := rd.Read();
478 ASSERT(rd.sSym = numSy); NEW(token);
479 FOR i := 0 TO 7 DO
480 token[i] := RTS.loByte(RTS.loShort(rd.Read()));
481 END;
482 rd.fasb.SetPublicKeyToken(token);
483 (* get next symbol *)
484 rd.GetSym();
485 END GetVersionName;
486
487
488 PROCEDURE (rd: Reader)GetLiteral(): MS.Literal, NEW;
489 VAR
490 lit: MS.Literal;
491 BEGIN
492 CASE rd.sSym OF
493 | truSy :
494 lit := MS.MakeBoolLiteral(TRUE);
495 | falSy :
496 lit := MS.MakeBoolLiteral(FALSE);
497 | numSy :
498 lit := MS.MakeLIntLiteral(rd.lAtt);
499 | chrSy :
500 lit := MS.MakeCharLiteral(rd.cAtt);
501 | fltSy :
502 lit := MS.MakeRealLiteral(rd.rAtt);
503 | setSy :
504 lit := MS.MakeSetLiteral(BITS(rd.iAtt));
505 | strSy :
506 lit := MS.MakeStrLiteral(ST.ToChrOpen(rd.sAtt)); (* implicit rd.sAtt^ *)
507 ELSE
508 RETURN NIL;
509 END; (* CASE *)
510 rd.GetSym(); (* read past value *)
511 RETURN lit;
512 END GetLiteral;
513
514
515 PROCEDURE (rd: Reader) Import, NEW;
516 VAR
517 mname: CharOpen;
518 asbname: CharOpen;
519 asbfile: CharOpen;
520 nsname: CharOpen;
521 scopeNm: CharOpen;
522 idx1, idx2: INTEGER;
523 len: INTEGER;
524 asb: MS.Assembly;
525 ns: MS.Namespace;
526 BEGIN
527 rd.ReadPast(namSy);
528 mname := ST.ToChrOpen(rd.sAtt);
529 IF rd.sSym = strSy THEN
530 (* non-GPCP module *)
531 scopeNm := ST.ToChrOpen(rd.sAtt);
532 idx1 := ST.StrChr(scopeNm, '['); idx2 := ST.StrChr(scopeNm, ']');
533 asbfile := ST.SubStr(scopeNm,idx1+1, idx2-1);
534 nsname := ST.SubStr(scopeNm, idx2+1, LEN(scopeNm)-1);
535 rd.GetSym();
536 ELSE
537 (* possible GPCP module *)
538 len := LEN(mname);
539 IF mname[len-2] = '_' THEN mname := ST.SubStr(mname, 0, len-3); END;
540 asbfile := mname;
541 nsname := mname; (* or it can be assigned as MS.NULLSPACE *)
542 END; (* IF *)
543 (* need to get the assembly real name here *)
544 asbname := MP.GetAssemblyRealName(asbfile);
545 asb := MS.InsertAssembly(asbname, asbfile);
546 ns := asb.InsertNamespace(nsname);
547 AppendScope(rd.sArray, ns);
548 rd.ReadPast(keySy);
549 END Import;
550
551
552 PROCEDURE (rd: Reader) ParseType, NEW;
553 VAR
554 typ: MS.TempType;
555 ord: INTEGER;
556 BEGIN
557 typ := MS.NewTempType(); (* this is a temporay type, not the final type *)
558 typ.SetName(ST.ToChrOpen(rd.sAtt));
559 typ.SetFullName(ST.StrCat(ST.StrCatChr(rd.fns.GetName(),'.'),typ.GetName()));
560 typ.SetVisibility(rd.iAtt);
561 ord := rd.ReadOrd();
562 IF ord >= tOffset THEN
563 ASSERT(rd.tNxt = ord);
564 typ.SetTypeOrd(ord);
565 AppendType(rd.tArray, typ); INC(rd.tNxt);
566 typ.SetNamespace(rd.fns);
567 ELSE
568 (* primitive types *)
569 END; (* IF *)
570 rd.GetSym();
571 END ParseType;
572
573
574 PROCEDURE (rd: Reader) GetFormalTypes(): MS.FormalList, NEW;
575 (*
576 // FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd} endFm.
577 // -- optional phrase is return type for proper procedures
578 *)
579 CONST
580 FNAME = "arg";
581 VAR
582 rslt: MS.FormalList;
583 ftype: MS.Type;
584 fmode: INTEGER;
585 count: INTEGER;
586 temp: FmlList;
587 head: FmlList;
588 last: FmlList;
589 fml: MS.Formal;
590 pos: INTEGER;
591 str: CharOpen;
592 nametype: MS.Type;
593 unresolved: INTEGER;
594 BEGIN
595 head := NIL; last := NIL; count := 0; ftype := NIL; NEW(str,3); unresolved := 0;
596 rd.ReadPast(frmSy);
597 WHILE rd.sSym = parSy DO
598 fmode := rd.Read();
599 ftype := rd.GetTypeFromOrd();
600 RTS.IntToStr(count, str);
601 WITH ftype: MS.NamedType DO
602 fml := MS.MakeFormal(ST.StrCat(ST.ToChrOpen(FNAME),str), ftype, fmode);
603 | ftype: MS.TempType DO
604 fml := MS.MakeFormal(ST.StrCat(ST.ToChrOpen(FNAME),str), MS.dmyTyp, fmode);
605 (* collect reference if TempType/NamedType *)
606 ftype.AddReferenceFormal(fml);
607 INC(unresolved);
608 ELSE
609 fml := MS.MakeFormal(ST.StrCat(ST.ToChrOpen(FNAME),str), ftype, fmode);
610 END; (* WITH *)
611
612 (* add the formal to a temporary formals linkedlist *)
613 NEW(temp); temp.nxt := NIL; temp.fml := fml;
614 IF last # NIL THEN last.nxt := temp; last := temp; ELSE last := temp; head := temp; END;
615 INC(count);
616 END; (* WHILE *)
617 rd.ReadPast(endFm);
618
619 (* now I know how many formals for the method *)
620 rslt := MS.CreateFormalList(count);
621 temp := head; pos := 0;
622 WHILE temp # NIL DO
623 rslt.AddFormal(temp.fml, pos);
624 temp := temp.nxt; INC(pos);
625 END; (* WHILE *)
626 rslt.ostd := unresolved;
627 RETURN rslt;
628 END GetFormalTypes;
629
630
631 PROCEDURE FixProcTypes(rec: MS.RecordType; newM: MS.Method; fl: MS.FormalList; rtype: MS.Type);
632 VAR
633 newF: MS.Method;
634 BEGIN
635 IF MS.WithoutMethodNameMangling() THEN
636 newF := newM;
637 WITH newF: MS.Function DO
638 WITH rtype: MS.TempType DO
639 (* not a concrete return type *)
640 WITH rtype: MS.NamedType DO
641 (* return type name is resolved *)
642 IF fl.ostd = 0 THEN
643 (* no unresolved formal types names *)
644 newM.FixSigCode(); (* fix the sigcode of newM *)
645 newM := rec.AddMethod(newM);
646 ELSE
647 (* need to AddMethod after formal type names resolved *)
648 END; (* IF *)
649 ELSE
650 (* return type name is unresolved *)
651 INC(newF.ostd);
652 (* need to AddMethod after return type name and formal type names resolved *)
653 END; (* IF *)
654
655 (* collect reference if TempType/NamedType *)
656 rtype.AddReferenceFunction(newF);
657 ELSE
658 (* concrete return type ==> type name is solved *)
659 IF fl.ostd = 0 THEN
660 (* no unresolved formal types names *)
661 newM.FixSigCode(); (* fix the sigcode of newM *)
662 newM := rec.AddMethod(newM);
663 ELSE
664 (* need to AddMethod after formal type names resolved *)
665 END; (* IF *)
666 END; (* WITH *)
667 ELSE
668 (* not a function *)
669 IF fl.ostd = 0 THEN
670 (* no unresolved formal types names *)
671 newM.FixSigCode(); (* fix the sigcode of newM *)
672 newM := rec.AddMethod(newM);
673 ELSE
674 (* need to AddMethod after formal type names resolved *)
675 END; (* IF *)
676 END; (* WITH *)
677 ELSE
678 newM.FixSigCode(); (* fix the sigcode of newM *)
679 newM := rec.AddMethod(newM);
680 WITH newM: MS.Function DO
681 WITH rtype: MS.TempType DO
682 (* collect reference if TempType/NamedType *)
683 rtype.AddReferenceFunction(newM);
684 ELSE
685 END; (* WITH *)
686 ELSE
687 END; (* IF *)
688 END; (* IF *)
689 END FixProcTypes;
690
691
692 PROCEDURE (rd: Reader) ParseMethod(rec: MS.RecordType), NEW;
693 VAR
694 newM: MS.Method;
695 newF: MS.Method;
696 mAtt: SET;
697 vMod: INTEGER;
698 rFrm: INTEGER;
699 fl: MS.FormalList;
700 rtype: MS.Type;
701 rectyp: MS.Type;
702 mname: CharOpen;
703 ovlname: CharOpen;
704 BEGIN
705 NEW(newM);
706 mname := ST.ToChrOpen(rd.sAtt);
707 vMod := rd.iAtt;
708 (* byte1 is the method attributes *)
709 mAtt := BITS(rd.Read());
710 (* byte2 is param form of receiver *)
711 rFrm := rd.Read();
712 (* next 1 or 2 bytes are rcv-type *)
713 rectyp := rd.TypeOf(rd.ReadOrd());
714 rd.GetSym();
715 ovlname := NIL;
716
717 IF ~MS.WithoutMethodNameMangling() THEN
718 IF rd.sSym = strSy THEN
719 (* optional invoking method name *)
720 ovlname := mname;
721 mname := ST.ToChrOpen(rd.sAtt);
722 rd.GetSym();
723 END; (* IF *)
724 END; (* IF *)
725
726 rtype := NIL;
727 IF rd.sSym = retSy THEN
728 rtype := rd.TypeOf(rd.iAtt);
729 rd.GetSym();
730 END; (* IF *)
731 fl := rd.GetFormalTypes();
732
733 newM := rec.MakeMethod(mname, MS.Mnonstatic, rtype, fl);
734 IF (rectyp # NIL) & (rectyp # rec) THEN newM.SetDeclaringType(rectyp); END;
735
736 IF MS.WithoutMethodNameMangling() THEN
737 ELSE
738 IF ovlname # NIL THEN
739 newM.SetOverload(ovlname); (* fix the sigcode of newM *)
740 ELSE
741 END;
742 END; (* IF *)
743
744 newM.SetVisibility(vMod);
745 newM.InclAttributes(mAtt);
746 FixProcTypes(rec, newM, fl, rtype);
747 END ParseMethod;
748
749
750 PROCEDURE (rd: Reader) ParseProcedure(rec: MS.RecordType), NEW;
751 VAR
752 newP: MS.Method;
753 newF: MS.Method;
754 vMod: INTEGER;
755 rFrm: INTEGER;
756 fl: MS.FormalList;
757 rtype: MS.Type;
758 rectyp: MS.Type;
759 pname: CharOpen;
760 ivkname: CharOpen;
761 ovlname: CharOpen;
762 isCtor: BOOLEAN;
763 idx: INTEGER;
764 BEGIN
765 NEW(newP);
766 pname := ST.ToChrOpen(rd.sAtt);
767 vMod := rd.iAtt;
768
769 rd.ReadPast(namSy);
770 ivkname := NIL; ovlname := NIL; isCtor := FALSE;
771
772 IF rd.sSym = strSy THEN
773 (* optional string of invoke name if overloaded method OR Constructor *)
774 ivkname := ST.ToChrOpen(rd.sAtt);
775 rd.GetSym();
776
777 IF rd.sSym = truSy THEN
778 (* optional truSy shows that procedure is a constructor *)
779 isCtor := TRUE;
780 IF LEN(pname) > LEN(MS.replCtor) THEN
781 (* overload constructor name is in the form of "init_..." *)
782 ovlname := pname;
783 idx := ST.StrChr(ovlname,'_');
784 IF idx # ST.NotExist THEN
785 pname := ST.SubStr(ovlname, 0, idx-1);
786 ELSE
787 ASSERT(FALSE);
788 END; (* IF *)
789 ELSE
790 (* constructor is not overloaded *)
791 END; (* IF *)
792 rd.GetSym();
793 ELSE
794 (* not a constructor *)
795 ovlname := pname;
796 pname := ivkname;
797 END; (* IF *)
798 END; (* IF *)
799
800 rtype := NIL;
801 IF rd.sSym = retSy THEN
802 rtype := rd.TypeOf(rd.iAtt);
803 rd.GetSym();
804 END; (* IF *)
805 fl := rd.GetFormalTypes();
806
807 newP := rec.MakeMethod(pname, MS.Mstatic, rtype, fl);
808 IF isCtor THEN
809 newP.SetConstructor();
810 newP.SetInvokeName(ivkname);
811 END; (* IF *)
812
813 IF MS.WithoutMethodNameMangling() THEN
814 ELSE
815 IF ovlname # NIL THEN
816 newP.SetOverload(ovlname); (* fix the sigcode of newM *)
817 END;
818 END; (* IF *)
819
820 newP.SetVisibility(vMod);
821 FixProcTypes(rec, newP, fl, rtype);
822 END ParseProcedure;
823
824
825 PROCEDURE (rd: Reader) ParseRecordField(rec: MS.RecordType), NEW;
826 VAR
827 fldname: CharOpen;
828 fvmod: INTEGER;
829 ftyp: MS.Type;
830 fld: MS.Field;
831 BEGIN
832 fldname := ST.ToChrOpen(rd.sAtt);
833 fvmod := rd.iAtt;
834 ftyp := rd.TypeOf(rd.ReadOrd());
835
836 WITH ftyp: MS.NamedType DO
837 fld := rec(MS.ValueType).MakeField(fldname, ftyp, FALSE);
838 | ftyp: MS.TempType DO
839 fld := rec(MS.ValueType).MakeField(fldname, MS.dmyTyp, FALSE);
840 (* collect reference if TempType/NamedType *)
841 ftyp.AddReferenceField(fld);
842 ELSE
843 fld := rec(MS.ValueType).MakeField(fldname, ftyp, FALSE);
844 END; (* WITH *)
845
846 fld.SetVisibility(fvmod);
847 WITH rec: MS.PrimType DO (* for IntPtr and UIntPtr, otherwise StrucType *)
848 ASSERT(rec.AddField(fld, FALSE));
849 ELSE (* IntfcType should not has data member *)
850 ASSERT(FALSE);
851 END; (* WITH *)
852 END ParseRecordField;
853
854
855 PROCEDURE (rd: Reader) ParseStaticVariable(rec: MS.RecordType), NEW;
856 (* Variable = varSy Name TypeOrd. *)
857 VAR
858 varname: CharOpen;
859 vvmod: INTEGER;
860 vtyp: MS.Type;
861 newV : MS.Field;
862 BEGIN
863 varname := ST.ToChrOpen(rd.sAtt);
864 vvmod := rd.iAtt;
865 vtyp := rd.TypeOf(rd.ReadOrd());
866
867 WITH vtyp: MS.NamedType DO
868 newV := rec(MS.ValueType).MakeField(varname, vtyp, FALSE);
869 | vtyp: MS.TempType DO
870 newV := rec(MS.ValueType).MakeField(varname, MS.dmyTyp, FALSE);
871 (* collect reference if TempType/NamedType *)
872 vtyp.AddReferenceField(newV);
873 ELSE
874 newV := rec(MS.ValueType).MakeField(varname, vtyp, FALSE);
875 END; (* WITH *)
876
877 newV.SetVisibility(vvmod);
878 WITH rec: MS.PrimType DO (* for IntPtr and UIntPtr, otherwise StrucType *)
879 ASSERT(rec.AddField(newV, TRUE));
880 ELSE (* IntfcType should not has data member *)
881 ASSERT(FALSE);
882 END; (* WITH *)
883 rd.GetSym();
884 END ParseStaticVariable;
885
886
887 PROCEDURE (rd: Reader) ParseConstant(rec: MS.RecordType), NEW;
888 (* Constant = conSy Name Literal. *)
889 (* Assert: f.sSym = namSy. *)
890 VAR
891 cname: CharOpen;
892 cvmod: INTEGER;
893 ctyp: MS.Type;
894 cvalue: MS.Literal;
895 newC : MS.Field;
896 tord: INTEGER;
897 BEGIN
898 cname := ST.ToChrOpen(rd.sAtt);
899 cvmod := rd.iAtt;
900 rd.ReadPast(namSy);
901 cvalue := rd.GetLiteral();
902
903 IF cvalue IS MS.BoolLiteral THEN
904 tord := MS.boolN;
905 ELSIF cvalue IS MS.LIntLiteral THEN
906 tord := MS.lIntN;
907 ELSIF cvalue IS MS.CharLiteral THEN
908 tord := MS.charN;
909 ELSIF cvalue IS MS.RealLiteral THEN
910 tord := MS.realN;
911 ELSIF cvalue IS MS.SetLiteral THEN
912 tord := MS.setN;
913 ELSIF cvalue IS MS.StrLiteral THEN
914 tord := MS.strN;
915 ELSE
916 tord := MS.unCertain;
917 END; (* IF *)
918 ctyp := MS.baseTypeArray[tord];
919 IF ctyp = NIL THEN
920 ctyp := MS.MakeDummyPrimitive(tord);
921 END; (* IF *)
922 newC := rec(MS.ValueType).MakeConstant(cname, ctyp, cvalue);
923
924 newC.SetVisibility(cvmod);
925 WITH rec: MS.ValueType DO
926 ASSERT(rec.AddField(newC, TRUE));
927 ELSE (* IntfcType should not has data member *)
928 ASSERT(FALSE);
929 END; (* WITH *)
930
931 END ParseConstant;
932
933
934 PROCEDURE (rd: Reader) ParsePointerType(old: MS.Type): MS.Type, NEW;
935 VAR
936 indx: INTEGER;
937 rslt: MS.PointerType;
938 junk: MS.Type;
939 ns: MS.Namespace;
940 tname: CharOpen;
941 ftname: CharOpen;
942 target: MS.Type;
943 BEGIN
944 (* read the target type ordinal *)
945 indx := rd.ReadOrd();
946 WITH old: MS.PointerType DO
947 rslt := old;
948 (*
949 * Check if there is space in the tArray for this
950 * element, otherwise expand using typeOf().
951 *)
952 IF indx - tOffset >= rd.tArray.tide THEN
953 junk := rd.TypeOf(indx);
954 END; (* IF *)
955 rd.tArray.a[indx-tOffset] := rslt.GetTarget();
956 | old: MS.TempType DO
957 ns := old.GetNamespace();
958 IF ns = NIL THEN
959 (* it is an anonymous pointer to array type *)
960 old.SetAnonymous();
961 target := rd.TypeOf(indx);
962 rslt := MS.MakeAnonymousPointerType(target);
963 ELSE
964 tname := old.GetName();
965 ftname := old.GetFullName();
966 target := rd.TypeOf(indx);
967 target.SetNamespace(ns); (* the the default namespace of the target *)
968 rslt := ns.InsertPointer(tname,ftname,target);
969 rslt.SetVisibility(old.GetVisibility());
970 END; (* IF *)
971
972 (* changed from TempType to PointerType, so fix all references to the type *)
973 MS.FixReferences(old, rslt);
974
975 IF target.GetName() = NIL THEN
976 target.SetAnonymous();
977 target.SetVisibility(MS.Vprivate);
978 (* collect reference if TempType/NamedType *)
979 target(MS.TempType).AddSrcPointerType(rslt); (* <== should that be for all TempType target?? *)
980 ELSE
981 END; (* IF *)
982 ELSE
983 ASSERT(FALSE); rslt := NIL;
984 END; (* WITH *)
985 rd.GetSym();
986 RETURN rslt;
987 END ParsePointerType;
988
989
990 PROCEDURE (rd: Reader) ParseArrayType(tpTemp: MS.Type): MS.Type, NEW;
991 VAR
992 rslt: MS.Type;
993 ns: MS.Namespace;
994 elemTp: MS.Type;
995 length: INTEGER;
996 tname: CharOpen;
997 ftname: CharOpen;
998 sptr: MS.PointerType;
999 sptrname: CharOpen;
1000 typOrd: INTEGER;
1001 BEGIN
1002 typOrd := rd.ReadOrd();
1003 elemTp := rd.TypeOf(typOrd);
1004 ns := tpTemp.GetNamespace();
1005 IF ns = NIL THEN
1006 (* its name (currently "DummyType") can only be fixed after its element type is determined *)
1007 tpTemp.SetAnonymous();
1008 IF typOrd < tOffset THEN
1009 (* element type is primitive, and was already create by TypeOf() calling MakeDummyPrimitive() *)
1010 tname := elemTp.GetName();
1011 tname := ST.StrCat(tname, MS.anonArr); (* append "_arr" *)
1012 ns := elemTp.GetNamespace(); (* []SYSTEM - for dummy primitives *)
1013 ftname := ST.StrCatChr(ns.GetName(), '.');
1014 ftname := ST.StrCat(ftname, tname);
1015 ELSE
1016 ns := elemTp.GetNamespace();
1017 IF ns # NIL THEN
1018 (* the anonymous array element is already known *)
1019 tname := elemTp.GetName();
1020 tname := ST.StrCat(tname, MS.anonArr); (* append "_arr" *)
1021 ftname := ST.StrCatChr(ns.GetName(), '.');
1022 ftname := ST.StrCat(ftname, tname);
1023 ELSE
1024 (* cannot insert this type as its element type is still unknown, and so is its namespace ??? *)
1025 tname := ST.NullString;
1026 ftname := tname;
1027 END; (* IF *)
1028 END; (* IF *)
1029 ELSE
1030 IF ~tpTemp.IsAnonymous() THEN
1031 tname := tpTemp.GetName();
1032 ftname := tpTemp.GetFullName();
1033 ELSE
1034 (* if array is anonymous and has namespace,
1035 then either its element type has been parsed (ARRAY OF ParsedElement),
1036 or it has a src pointer type (Arr1AnonymousArray = POINTER TO ARRAY OF something) *)
1037 tname := elemTp.GetName();
1038 IF tname # NIL THEN
1039 tname := ST.StrCat(tname, MS.anonArr); (* append "_arr" *)
1040 ELSE
1041 sptr := tpTemp(MS.TempType).GetNonAnonymousPTCrossRef();
1042 sptrname := sptr.GetName();
1043 tname := ST.SubStr(sptrname, 4, LEN(sptrname)-1); (* get rid of "Arr1" *)
1044 tname := ST.StrCat(tname, MS.anonArr); (* append "_arr" *)
1045 END; (* IF *)
1046 ftname := ST.StrCatChr(ns.GetName(), '.');
1047 ftname := ST.StrCat(ftname, tname);
1048 END; (* IF *)
1049 END; (* IF *)
1050 rd.GetSym();
1051 IF rd.sSym = bytSy THEN
1052 length := rd.iAtt;
1053 rd.GetSym();
1054 ELSIF rd.sSym = numSy THEN
1055 length := SHORT(rd.lAtt);
1056 rd.GetSym();
1057 ELSE
1058 length := 0;
1059 END; (* IF *)
1060
1061 IF ns # NIL THEN
1062 rslt := ns.InsertArray(tname, ftname, 1, length, elemTp);
1063 rslt.SetVisibility(tpTemp.GetVisibility());
1064
1065 (* changed from TempType to ArrayType, so fix all references to the type *)
1066 MS.FixReferences(tpTemp, rslt);
1067
1068 IF tpTemp.IsAnonymous() THEN
1069 rslt.SetAnonymous();
1070 ELSE
1071 rslt.NotAnonymous();
1072 END; (* IF *)
1073 ELSE
1074 (* add this to defer anonymous array insertion list*)
1075 tpTemp(MS.TempType).SetDimension(1);
1076 tpTemp(MS.TempType).SetLength(length);
1077 elemTp(MS.TempType).AddAnonymousArrayType(tpTemp(MS.TempType));
1078 rslt := tpTemp;
1079 END; (* IF *)
1080
1081 rd.ReadPast(endAr);
1082 RETURN rslt;
1083 END ParseArrayType;
1084
1085
1086 PROCEDURE (rd: Reader) ParseRecordType(old: MS.Type; typIdx: INTEGER): MS.RecordType, NEW;
1087 (* Assert: at entry the current symbol is recSy. *)
1088 (* Record = TypeHeader recSy recAtt [truSy | falSy | <others>] *)
1089 (* [basSy TypeOrd] [iFcSy {basSy TypeOrd}] *)
1090 (* {Name TypeOrd} {Method} {Statics} endRc. *)
1091 VAR
1092 rslt: MS.RecordType;
1093 recAtt: INTEGER;
1094 oldS: INTEGER;
1095 fldD: MS.Field;
1096 mthD: MS.Method;
1097 conD: MS.Constant;
1098 isValueType: BOOLEAN; (* is ValueType *)
1099 hasNarg: BOOLEAN; (* has noarg constructor ( can use NEW() ) *)
1100 ns: MS.Namespace;
1101 tname: CharOpen;
1102 ftname: CharOpen;
1103 attr: MS.Attribute;
1104 tt: INTEGER;
1105 sptr: MS.PointerType;
1106 base: MS.Type;
1107 itfc: MS.Type;
1108 tord: INTEGER; (* temporary type storage *)
1109 ttyp: MS.Type; (* temporary type storage *)
1110 fldname: CharOpen;
1111 fvmod: INTEGER;
1112 BEGIN
1113 WITH old: MS.RecordType DO
1114 rslt := old;
1115 recAtt := rd.Read(); (* record attribute *) (* <==== *)
1116 rd.GetSym(); (* falSy *)
1117 rd.GetSym(); (* optional basSy *)
1118 IF rd.sSym = basSy THEN rd.GetSym() END;
1119 | old: MS.TempType DO
1120
1121 ns := old.GetNamespace();
1122 IF ~old.IsAnonymous() THEN
1123 tname := old.GetName();
1124 ftname := old.GetFullName();
1125 ELSE
1126 (* if record is anonymous, it has only one src pointer type *)
1127 sptr := old(MS.TempType).GetFirstPTCrossRef();
1128 tname := ST.StrCat(sptr.GetName(), MS.anonRec);
1129 ftname := ST.StrCatChr(ns.GetName(), '.');
1130 ftname := ST.StrCat(ftname, tname);
1131 END; (* IF *)
1132
1133 recAtt := rd.Read(); (* <==== *)
1134 (* check for ValueType *)
1135 IF recAtt >= valTp THEN
1136 isValueType := TRUE; recAtt := recAtt MOD valTp;
1137 ELSE
1138 isValueType := FALSE;
1139 END; (* IF *)
1140
1141 (* check for no NOARG constructor *)
1142 IF recAtt >= nnarg THEN
1143 hasNarg := FALSE; recAtt := recAtt MOD nnarg;
1144 ELSE
1145 hasNarg := TRUE;
1146 END; (* IF *)
1147
1148 (* Record default to Struct, change to Class if found to be ClassType later (when it has event?) *)
1149 tt := MS.Struct;
1150 IF recAtt = iFace THEN tt := MS.Interface; END;
1151
1152 rd.GetSym();
1153 IF rd.sSym = falSy THEN
1154 ELSIF rd.sSym = truSy THEN
1155 END; (* IF *)
1156
1157 rslt := ns.InsertRecord(tname, ftname, tt);
1158 rslt.SetVisibility(old.GetVisibility());
1159
1160 IF isValueType THEN rslt.InclAttributes(MS.RvalTp); END;
1161 IF hasNarg THEN rslt.SetHasNoArgConstructor(); END;
1162
1163 CASE recAtt OF
1164 abstr : rslt.InclAttributes(MS.Rabstr);
1165 | limit : (* foreign has no LIMITED attribute *)
1166 | extns : rslt.InclAttributes(MS.Rextns);
1167 ELSE
1168 (* noAtt *)
1169 END; (* CASE *)
1170
1171 rd.GetSym();
1172 IF rd.sSym = basSy THEN
1173 base := rd.TypeOf(rd.iAtt);
1174 WITH base: MS.NamedType DO
1175 rslt.SetBaseType(base);
1176 | base: MS.TempType DO
1177 (* base is a temp type *)
1178 (* collect reference if TempType/NamedType *)
1179 base(MS.TempType).AddDeriveRecordType(rslt);
1180 ELSE
1181 (* base has already been parsed *)
1182 rslt.SetBaseType(base);
1183 END; (* WITH *)
1184 rd.GetSym();
1185 END; (* IF *)
1186
1187 IF rd.sSym = iFcSy THEN
1188 rd.GetSym();
1189 WHILE rd.sSym = basSy DO
1190
1191 itfc := rd.TypeOf(rd.iAtt);
1192 WITH itfc: MS.NamedType DO
1193 (* add to interface list of rslt *)
1194 rslt.AddInterface(itfc);
1195 | itfc: MS.TempType DO
1196 (* itfc is a temp type *)
1197 (* collect reference *)
1198 itfc(MS.TempType).AddImplRecordType(rslt);
1199 ELSE
1200 (* itfc has already been parsed *)
1201 (* add to interface list of rslt *)
1202 rslt.AddInterface(itfc);
1203 END; (* WITH *)
1204 rd.GetSym();
1205 END; (* WHILE *)
1206 END; (* IF *)
1207
1208 (* changed from TempType to RecordType, so fix all references to the type *)
1209 MS.FixReferences(old, rslt);
1210 (* need to be here as its methods, fields, etc. may reference to this new type *)
1211 rd.tArray.a[typIdx] := rslt;
1212 ELSE
1213 ASSERT(FALSE); rslt := NIL;
1214 END; (* WITH *)
1215
1216 WHILE rd.sSym = namSy DO
1217 (* check for record fields *)
1218 rd.ParseRecordField(rslt);
1219 rd.GetSym();
1220 (* insert the field to the record's field list *)
1221 END; (* WHILE *)
1222
1223 WHILE (rd.sSym = mthSy) OR (rd.sSym = prcSy) OR
1224 (rd.sSym = varSy) OR (rd.sSym = conSy) DO
1225 oldS := rd.sSym; rd.GetSym();
1226 IF oldS = mthSy THEN
1227 rd.ParseMethod(rslt);
1228 ELSIF oldS = prcSy THEN
1229 rd.ParseProcedure(rslt);
1230 ELSIF oldS = varSy THEN
1231 rd.ParseStaticVariable(rslt);
1232 ELSIF oldS = conSy THEN
1233 rd.ParseConstant(rslt);
1234 ELSE
1235 rd.Abandon();
1236 END; (* IF *)
1237 END; (* WHILE *)
1238 rd.ReadPast(endRc);
1239 RETURN rslt;
1240 END ParseRecordType;
1241
1242
1243 PROCEDURE (rd: Reader) ParseEnumType(tpTemp: MS.Type): MS.Type, NEW;
1244 VAR
1245 rslt: MS.EnumType;
1246 const: MS.Constant;
1247 ns: MS.Namespace;
1248 tname: CharOpen;
1249 ftname: CharOpen;
1250 BEGIN
1251 rslt := NIL;
1252 ns := tpTemp.GetNamespace();
1253 tname := tpTemp.GetName();
1254 ftname := tpTemp.GetFullName();
1255 rslt := ns.InsertRecord(tname, ftname, MS.Enum)(MS.EnumType);
1256 rslt.SetVisibility(tpTemp.GetVisibility());
1257
1258 (* changed from TempType to EnumType, so fix all references to the type *)
1259 MS.FixReferences(tpTemp, rslt);
1260
1261 rd.GetSym();
1262 WHILE rd.sSym = conSy DO
1263 rd.GetSym();
1264 rd.ParseConstant(rslt);
1265 END; (* WHILE *)
1266 rd.ReadPast(endRc);
1267 RETURN rslt;
1268 END ParseEnumType;
1269
1270
1271 PROCEDURE (rd: Reader) ParseDelegType(old: MS.Type; isMul: BOOLEAN): MS.Type, NEW;
1272 VAR
1273 rslt: MS.PointerType;
1274 ns: MS.Namespace;
1275 tname: CharOpen;
1276 ftname: CharOpen;
1277 ttname: CharOpen;
1278 tftname: CharOpen;
1279 target: MS.RecordType;
1280 rtype: MS.Type;
1281 fl: MS.FormalList;
1282 newM: MS.Method;
1283 newF: MS.Method;
1284 BEGIN
1285 (* create the pointer *)
1286 WITH old: MS.PointerType DO
1287 rslt := old;
1288 | old: MS.TempType DO
1289 ns := old.GetNamespace();
1290
1291 (* pointer name *)
1292 tname := old.GetName();
1293 ftname := old.GetFullName();
1294
1295 (* target name *)
1296 ttname := ST.StrCat(tname, MS.anonRec);
1297 tftname := ST.StrCatChr(ns.GetName(), '.');
1298 tftname := ST.StrCat(tftname, ttname);
1299
1300 (* create the target record *)
1301 target := ns.InsertRecord(ttname, tftname, MS.Delegate);
1302 target.SetNamespace(ns); (* the the default namespace of the target *)
1303 target.SetAnonymous();
1304 IF isMul THEN target.SetMulticast() END;
1305
1306 (* target visibility *)
1307 target.SetVisibility(MS.Vprivate);
1308 (* Delegate is not value type *)
1309 (* Delegate has no noarg constructor *)
1310 (* Delegate is neither abstract, nor extensible *)
1311 (* lost information on base type of Delegate *)
1312 (* lost information on interface implemented by Delegate *)
1313
1314 rslt := ns.InsertPointer(tname,ftname,target);
1315 rslt.SetVisibility(old.GetVisibility());
1316
1317 (* changed from TempType to PointerType, so fix all references to the type *)
1318 MS.FixReferences(old, rslt);
1319
1320 (* the "Invoke" method of delegate *)
1321 rd.GetSym();
1322
1323 rtype := NIL;
1324 IF rd.sSym = retSy THEN
1325 rtype := rd.TypeOf(rd.iAtt);
1326 rd.GetSym();
1327 END; (* IF *)
1328
1329 fl := rd.GetFormalTypes();
1330
1331 newM := target.MakeMethod(ST.ToChrOpen("Invoke"), MS.Mnonstatic, rtype, fl);
1332 newM.SetVisibility(MS.Vpublic); (* "Invoke" method has Public visiblilty *)
1333
1334 (* "Invoke" method has final {} attribute (or should it has NEW attribute) *)
1335 (* newM.InclAttributes(MS.Mnew); *)
1336
1337 FixProcTypes(target, newM, fl, rtype);
1338 ELSE
1339 ASSERT(FALSE); rslt := NIL;
1340 END; (* WITH *)
1341
1342 RETURN rslt;
1343 END ParseDelegType;
1344
1345
1346 PROCEDURE (rd: Reader) ParseTypeList*(), NEW;
1347 (* TypeList = start { Array | Record | Pointer *)
1348 (* | ProcType } close. *)
1349 (* TypeHeader = tDefS Ord [fromS Ord Name]. *)
1350 VAR
1351 typOrd: INTEGER;
1352 typIdx: INTEGER;
1353 tpTemp : MS.Type;
1354 modOrd : INTEGER;
1355 impMod : MS.Namespace;
1356 tpDesc : MS.Type;
1357 BEGIN
1358 impMod := NIL;
1359 WHILE rd.sSym = tDefS DO
1360 (* Do type header *)
1361 typOrd := rd.iAtt;
1362 typIdx := typOrd - tOffset;
1363 tpTemp := rd.tArray.a[typIdx];
1364
1365 rd.ReadPast(tDefS);
1366 (* The fromS symbol appears if the type is imported *)
1367 IF rd.sSym = fromS THEN
1368 modOrd := rd.iAtt;
1369 impMod := rd.sArray.a[modOrd-1];
1370 rd.GetSym();
1371 (* With the strict ordering of the imports,
1372 * it may be unnecessary to create this object
1373 * in case the other module has been fully read
1374 * already?
1375 * It is also possible that the type has
1376 * been imported already, but just as an opaque.
1377 *)
1378 tpTemp.SetNamespace(impMod);
1379 rd.ReadPast(namSy);
1380
1381
1382 IF tpTemp.GetName() = NIL THEN
1383 tpTemp.SetName(ST.ToChrOpen(rd.sAtt));
1384 ELSE
1385 END; (* IF *)
1386 tpTemp.SetFullName(ST.StrCat(ST.StrCatChr(impMod.GetName(),'.'), tpTemp.GetName()));
1387 END; (* IF *)
1388
1389 (* GetTypeinfo *)
1390 CASE rd.sSym OF
1391 | arrSy :
1392 tpDesc := rd.ParseArrayType(tpTemp);
1393 rd.tArray.a[typIdx] := tpDesc;
1394 | recSy :
1395 tpDesc := rd.ParseRecordType(tpTemp, typIdx);
1396 rd.tArray.a[typIdx] := tpDesc;
1397 | ptrSy :
1398 tpDesc := rd.ParsePointerType(tpTemp);
1399 rd.tArray.a[typIdx] := tpDesc;
1400 | evtSy :
1401 tpDesc := rd.ParseDelegType(tpTemp, TRUE);
1402 rd.tArray.a[typIdx] := tpDesc;
1403 | pTpSy :
1404 tpDesc := rd.ParseDelegType(tpTemp, FALSE);
1405 rd.tArray.a[typIdx] := tpDesc;
1406 | eTpSy :
1407 tpDesc := rd.ParseEnumType(tpTemp);
1408 rd.tArray.a[typIdx] := tpDesc;
1409 ELSE
1410 (* NamedTypes come here *)
1411 IF impMod = NIL THEN impMod := rd.fns; END;
1412 (* the outcome could be a PointerType, ArrayType or RecordType if it already exist *)
1413 tpDesc := impMod.InsertNamedType(tpTemp.GetName(), tpTemp.GetFullName());
1414 rd.tArray.a[typIdx] := tpDesc;
1415 (* changed from TempType to NamedType, so fix all references to the type *)
1416 MS.FixReferences(tpTemp, tpDesc);
1417 END; (* CASE *)
1418 END; (* WHILE *)
1419 rd.ReadPast(close);
1420 END ParseTypeList;
1421
1422
1423 PROCEDURE (rd: Reader) InsertMainClass(): MS.PointerType, NEW;
1424 VAR
1425 tname : ST.CharOpen;
1426 tgtname: ST.CharOpen;
1427 target : MS.RecordType;
1428 rslt : MS.PointerType;
1429 base : MS.Type;
1430 ns : MS.Namespace;
1431 asb : MS.Assembly;
1432 BEGIN
1433 ASSERT(ST.StrCmp(rd.fasb.GetName(), rd.fns.GetName()) = ST.Equal);
1434 tname := rd.fns.GetName();
1435 tgtname := ST.StrCat(tname, MS.anonRec);
1436 target := rd.fns.InsertRecord(tgtname, tgtname, MS.Struct);
1437 target.SetVisibility(MS.Vpublic);
1438 target.SetHasNoArgConstructor();
1439 base := MS.GetTypeByName(ST.ToChrOpen("mscorlib"),ST.ToChrOpen("System"),ST.ToChrOpen("Object"));
1440 ASSERT(base # NIL); (* mscorlib_System.Object should always exist *)
1441 target.SetBaseType(base);
1442 rslt := rd.fns.InsertPointer(tname,tname,target);
1443 rslt.SetVisibility(MS.Vpublic);
1444 RETURN rslt;
1445 END InsertMainClass;
1446
1447
1448 PROCEDURE ParseSymbolFile*(symfile: GF.FILE; modname: CharOpen);
1449 VAR
1450 rd: Reader;
1451 oldS: INTEGER;
1452 class: MS.PointerType;
1453 rec: MS.Type;
1454 BEGIN
1455 rec := NIL;
1456 rd := NewReader(symfile);
1457 rd.GetHeader(modname);
1458 IF rd.sSym = numSy THEN rd.GetVersionName(); END; (* optional strong name info. *)
1459 LOOP
1460 oldS := rd.sSym;
1461 rd.GetSym();
1462 CASE oldS OF
1463 | start : EXIT;
1464 | impSy : rd.Import();
1465 | typSy : rd.ParseType();
1466 | conSy : (* a global variable belongs to an GPCP module, e.g. ["[GPFiles]GPFiles"] *)
1467 IF rec = NIL THEN
1468 class := rd.InsertMainClass();
1469 rec := class.GetTarget();
1470 END; (* IF *)
1471 WITH rec: MS.RecordType DO
1472 rd.ParseConstant(rec);
1473 ELSE
1474 ASSERT(FALSE);
1475 END; (* WITH *)
1476 | prcSy : (* a global variable belongs to an GPCP module, e.g. ["[GPFiles]GPFiles"] *)
1477 IF rec = NIL THEN
1478 class := rd.InsertMainClass();
1479 rec := class.GetTarget();
1480 END; (* IF *)
1481 WITH rec: MS.RecordType DO
1482 rd.ParseProcedure(rec);
1483 ELSE
1484 ASSERT(FALSE);
1485 END; (* WITH *)
1486 | varSy : (* a global variable belongs to an GPCP module, e.g. ["[GPFiles]GPFiles"] *)
1487 IF rec = NIL THEN
1488 class := rd.InsertMainClass();
1489 rec := class.GetTarget();
1490 END; (* IF *)
1491 WITH rec: MS.RecordType DO
1492 rd.ParseStaticVariable(rec);
1493 ELSE
1494 ASSERT(FALSE);
1495 END; (* WITH *)
1496 ELSE
1497 RTS.Throw("Bad object");
1498 END; (* CASE *)
1499 END; (* LOOP *)
1500 rd.ParseTypeList();
1501 IF rd.sSym # keySy THEN RTS.Throw("Missing keySy"); END;
1502 END ParseSymbolFile;
1503
1504
1505 END SymReader.
1506
[FORK] Old GPCP with patches
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024