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 / SymWriter.cp
1 MODULE SymWriter;
2 (* ========================================================================= *)
3 (* *)
4 (* Symbol file writing module for the .NET to Gardens Point Component *)
5 (* Pascal Symbols tool. *)
6 (* Copyright (c) Siu-Yuen Chan 2001. *)
7 (* *)
8 (* This module converts all meta information inside METASTORE (defined by *)
9 (* MetaStore module) into Gardens Point Component Pascal (GPCP) recognized *)
10 (* symbols, then writes the symbols to files in GPCP symbol file format. *)
11 (* ========================================================================= *)
12
13 IMPORT
14 ST := AscString,
15 Error,
16 RTS,
17 MS := MetaStore,
18 GF := GPBinFiles;
19
20 CONST
21 SymbolExt* = ".cps";
22
23 CONST
24 (* ModulesName Types *)
25 (* assembly name same as namespace name, and contains only one word,
26 e.g. Accessibility.dll has only a namespace named Accessibility,
27 and the module name should be:
28 Accessibility_["[Accessibility]Accessibility"] *)
29 SingleWord = 0;
30
31 (* assembly name same as namespace name, and contains multiple word,
32 e.g. Microsoft.Win32.InterOp.dll has a namespace named Microsoft.Win32.InterOp,
33 and the module name shoulle be:
34 Microsoft_Win32_InterOp_["[Microsoft.Win32.InterOp]Microsoft.Win32.InterOp"] *)
35 MultipleWord = 1;
36
37 (* assembly name different form namespace name, contains multiple word, and
38 with namespace name includes the entire assembly name
39 e.g. Microsoft.Win32.InterOp.dll has a namespace named Microsoft.Win32.InterOp.Trident,
40 and the module name shoulle be:
41 Microsoft_Win32_InterOp__Trident["[Microsoft.Win32.InterOp]Microsoft.Win32.InterOp.Trident"] *)
42 IncludeWord = 3;
43
44 (* assembly name different from namespace name, contains multiple word, and
45 with no relationship between assembly name and namespace name
46 e.g. mscorlib.dll has a namespace named System.Reflection,
47 and the module name should be:
48 mscorlib_System_Reflection["[mscorlib]System.Reflection"] *)
49 DifferentWord = 2;
50 (* ========================================================================= *
51 // Collected syntax ---
52 //
53 // SymFile = Header [String (falSy | truSy | <other attribute>)]
54 // [ VersionName ]
55 // {Import | Constant | Variable | Type | Procedure}
56 // TypeList Key.
57 // -- optional String is external name.
58 // -- falSy ==> Java class
59 // -- truSy ==> Java interface
60 // -- others ...
61 // Header = magic modSy Name.
62 // VersionName= numSy longint numSy longint numSy longint.
63 // -- mj# mn# bld rv# 8xbyte extract
64 // Import = impSy Name [String] Key.
65 // -- optional string is explicit external name of class
66 // Constant = conSy Name Literal.
67 // Variable = varSy Name TypeOrd.
68 // Type = typSy Name TypeOrd.
69 // Procedure = prcSy Name [String] FormalType.
70 // -- optional string is explicit external name of procedure
71 // Method = mthSy Name byte byte TypeOrd [String] FormalType.
72 // -- optional string is explicit external name of method
73 // FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd} endFm.
74 // -- optional phrase is return type for proper procedures
75 // TypeOrd = ordinal.
76 // TypeHeader = tDefS Ord [fromS Ord Name].
77 // -- optional phrase occurs if:
78 // -- type not from this module, i.e. indirect export
79 // TypeList = start { Array | Record | Pointer | ProcType } close.
80 // Array = TypeHeader arrSy TypeOrd (Byte | Number | <empty>) endAr.
81 // -- nullable phrase is array length for fixed length arrays
82 // Pointer = TypeHeader ptrSy TypeOrd.
83 // Event = TypeHeader evtSy FormalType.
84 // ProcType = TypeHeader pTpSy FormalType.
85 // Record = TypeHeader recSy recAtt [truSy | falSy]
86 // [basSy TypeOrd] [iFcSy {basSy TypeOrd}]
87 // {Name TypeOrd} {Method} endRc.
88 // -- truSy ==> is an extension of external interface
89 // -- falSy ==> is an extension of external class
90 // -- basSy option defines base type, if not ANY / j.l.Object
91 // NamedType = TypeHeader
92 // Name = namSy byte UTFstring.
93 // Literal = Number | String | Set | Char | Real | falSy | truSy.
94 // Byte = bytSy byte.
95 // String = strSy UTFstring.
96 // Number = numSy longint.
97 // Real = fltSy ieee-double.
98 // Set = setSy integer.
99 // Key = keySy integer..
100 // Char = chrSy unicode character.
101 //
102 // Notes on the syntax:
103 // All record types must have a Name field, even though this is often
104 // redundant. The issue is that every record type (including those that
105 // are anonymous in CP) corresponds to a IR class, and the definer
106 // and the user of the class _must_ agree on the IR name of the class.
107 // The same reasoning applies to procedure types, which must have equal
108 // interface names in all modules.
109 // ======================================================================== *)
110
111 CONST
112 modSy = ORD('H'); namSy = ORD('$'); bytSy = ORD('\');
113 numSy = ORD('#'); chrSy = ORD('c'); strSy = ORD('s');
114 fltSy = ORD('r'); falSy = ORD('0'); truSy = ORD('1');
115 impSy = ORD('I'); setSy = ORD('S'); keySy = ORD('K');
116 conSy = ORD('C'); typSy = ORD('T'); tDefS = ORD('t');
117 prcSy = ORD('P'); retSy = ORD('R'); mthSy = ORD('M');
118 varSy = ORD('V'); parSy = ORD('p'); start = ORD('&');
119 close = ORD('!'); recSy = ORD('{'); endRc = ORD('}');
120 frmSy = ORD('('); fromS = ORD('@'); endFm = ORD(')');
121 arrSy = ORD('['); endAr = ORD(']'); pTpSy = ORD('%');
122 ptrSy = ORD('^'); basSy = ORD('+'); eTpSy = ORD('e');
123 iFcSy = ORD('~'); evtSy = ORD('v');
124
125 CONST
126 magic = 0DEADD0D0H;
127 syMag = 0D0D0DEADH;
128 MAXMODULE = 64;
129 MAXTYPE = 256;
130
131 CONST
132 tOffset* = 16; (* backward compatibility with JavaVersion *)
133
134 CONST (* mode-kinds *)(* should follow exactly as defined in Symbol.cp *)
135 (* used in describing Type *)
136 prvMode = MS.Vprivate;
137 pubMode = MS.Vpublic;
138 rdoMode = MS.Vreadonly;
139 protect = MS.Vprotected;
140
141 CONST (* base-ordinals *)
142 notBs = MS.notBs;
143 boolN* = MS.boolN; (* BOOLEAN *)
144 sChrN* = MS.sChrN; (* SHORTCHAR *)
145 charN* = MS.charN; (* CHAR *)
146 uBytN* = MS.uBytN; (* UBYTE *)
147 byteN* = MS.byteN; (* BYTE *)
148 sIntN* = MS.sIntN; (* SHORTINT *)
149 intN* = MS.intN; (* INTEGER *)
150 lIntN* = MS.lIntN; (* LONGING *)
151 sReaN* = MS.sReaN; (* SHORTREAL *)
152 realN* = MS.realN; (* REAL *)
153 setN* = MS.setN; (* SET *)
154 anyRec* = MS.anyRec; (* ANYREC *)
155 anyPtr* = MS.anyPtr; (* ANYPTR *)
156 strN* = MS.strN; (* STRING (ARRAY OF CHAR) *)
157 sStrN* = MS.sStrN; (* SHORTSTRING (ARRAY OF SHORTCHAR) *)
158 metaN* = MS.metaN; (* META *)
159
160 CONST (* record attributes *)
161 noAtt* = ORD(MS.noAtt); (* no attribute *)
162 abstr* = ORD(MS.Rabstr); (* Is ABSTRACT *)
163 limit* = ORD(MS.Rlimit); (* Is LIMIT *)
164 extns* = ORD(MS.Rextns); (* Is EXTENSIBLE *)
165 iFace* = ORD(MS.RiFace); (* Is INTERFACE *)
166 nnarg* = ORD(MS.Rnnarg); (* Has NO NoArg Constructor ( cannot use NEW() ) *)
167 valTp* = ORD(MS.RvalTp); (* ValueType *)
168
169 CONST (* method attributes *)
170 newBit* = 0;
171 final* = MS.Mfinal;
172 isNew* = MS.Mnew;
173 isAbs* = MS.Mabstr;
174 empty* = MS.Mempty;
175 isExt* = MS.MisExt;
176 mask* = MS.Mmask;
177 covar* = MS.Mcovar; (* ==> covariant return type *)
178
179 CONST (* param-modes *)
180 val* = MS.IsVal; (* value parameter *)
181 in* = MS.IsIn; (* IN parameter *)
182 out* = MS.IsOut; (* OUT parameter *)
183 var* = MS.IsVar; (* VAR parameter *)
184 notPar* = MS.NotPar;
185
186 TYPE
187 (*
188 CharOpen = POINTER TO ARRAY OF CHAR;
189 *)
190 CharOpen = ST.CharOpen;
191
192 TypeSeq = POINTER TO
193 RECORD
194 tide: INTEGER;
195 high: INTEGER;
196 a: POINTER TO ARRAY OF MS.Type;
197 END;
198
199 ModuleSeq = POINTER TO
200 RECORD
201 tide: INTEGER;
202 high: INTEGER;
203 a: POINTER TO ARRAY OF MS.Namespace;
204 END;
205
206 Emiter = POINTER TO
207 RECORD
208 asbname: CharOpen;
209 asbfile: CharOpen;
210 nsname: CharOpen;
211 modname: CharOpen;
212 version: MS.Version;
213 token: MS.PublicKeyToken;
214 ns: MS.Namespace;
215 mnameKind: INTEGER;
216 maintyp: MS.Type;
217 file: GF.FILE;
218 cSum: INTEGER;
219 iNxt: INTEGER; (* next IMPORT Ord *)
220 oNxt: INTEGER; (* next TypeOrd *)
221 work: TypeSeq;
222 impo: ModuleSeq;
223 END;
224
225 VAR
226 PreEmit: BOOLEAN;
227
228
229 PROCEDURE ^ (et: Emiter) EmitDelegate(t: MS.DelegType), NEW;
230
231
232 PROCEDURE MakeTypeName(typ: MS.Type): CharOpen;
233 (* for handling the '+' sign inside the Beta2 nested type name *)
234 VAR
235 name: CharOpen;
236 idx: INTEGER;
237 BEGIN
238 name := typ.GetName();
239 IF typ.IsNested() THEN
240 idx := ST.StrChr(name, '+');
241 IF idx # ST.NotExist THEN
242 name[idx] := '$';
243 END; (* IF *)
244 ASSERT(ST.StrChr(name, '+') = ST.NotExist);
245 ELSE
246 END; (* IF *)
247 RETURN name;
248 END MakeTypeName;
249
250
251 PROCEDURE (et: Emiter) MakeFullTypeName(typ: MS.Type): CharOpen, NEW;
252 VAR
253 tnsname: CharOpen;
254 tasbname: CharOpen;
255 tmodname: CharOpen;
256 tname: CharOpen;
257 dim: INTEGER;
258 elm: MS.Type;
259 BEGIN
260 tnsname := typ.GetNamespaceName();
261 tasbname := typ.GetAssemblyName();
262 IF (tnsname^ = et.nsname^) & (tasbname^ = et.asbname^) THEN
263 (* local type *)
264 tname := MakeTypeName(typ);
265 ELSE
266 (* foreign type *)
267 tmodname := MS.MakeModuleName(tasbname, tnsname);
268 tmodname := ST.StrCatChr(tmodname, '.');
269 tname := ST.StrCat(tmodname, MakeTypeName(typ));
270 END; (* IF *)
271 RETURN tname;
272 END MakeFullTypeName;
273
274
275 PROCEDURE InitTypeSeq(seq: TypeSeq; capacity : INTEGER);
276 BEGIN
277 NEW(seq.a, capacity);
278 seq.high := capacity-1;
279 seq.tide := 0;
280 END InitTypeSeq;
281
282
283 PROCEDURE InitModuleSeq(seq: ModuleSeq; capacity : INTEGER);
284 BEGIN
285 NEW(seq.a, capacity);
286 seq.high := capacity-1;
287 seq.tide := 0;
288 END InitModuleSeq;
289
290
291 PROCEDURE ResetTypeSeq(VAR seq : TypeSeq);
292 VAR
293 i: INTEGER;
294 type: MS.Type;
295 BEGIN
296 IF seq.a = NIL THEN
297 InitTypeSeq(seq, 2);
298 ELSE
299 FOR i := 0 TO seq.tide-1 DO
300 type := seq.a[i]; seq.a[i] := NIL;
301 type.ClearTypeOrd();
302 type.ClearInHierarchy();
303 END; (* FOR *)
304 seq.tide := 0;
305 END; (* IF *)
306 END ResetTypeSeq;
307
308
309 PROCEDURE ResetModuleSeq(VAR seq : ModuleSeq);
310 VAR
311 i: INTEGER;
312 ns: MS.Namespace;
313 BEGIN
314 IF seq.a = NIL THEN
315 InitModuleSeq(seq, 2);
316 ELSE
317 FOR i := 0 TO seq.tide-1 DO
318 ns := seq.a[i]; seq.a[i] := NIL;
319 ns.ClearModuleOrd();
320 END; (* FOR *)
321 seq.tide := 0;
322 END; (* IF *)
323 END ResetModuleSeq;
324
325
326 PROCEDURE AppendType(VAR seq : TypeSeq; elem : MS.Type);
327 VAR
328 temp : POINTER TO ARRAY OF MS.Type;
329 i : INTEGER;
330 BEGIN
331 IF seq.a = NIL THEN
332 InitTypeSeq(seq, 2);
333 ELSIF seq.tide > seq.high THEN (* must expand *)
334 temp := seq.a;
335 seq.high := seq.high * 2 + 1;
336 NEW(seq.a, (seq.high+1));
337 FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
338 END;
339 seq.a[seq.tide] := elem; INC(seq.tide);
340 END AppendType;
341
342
343 PROCEDURE AppendModule(VAR seq : ModuleSeq; elem : MS.Namespace);
344 VAR
345 temp : POINTER TO ARRAY OF MS.Namespace;
346 i : INTEGER;
347 BEGIN
348 IF seq.a = NIL THEN
349 InitModuleSeq(seq, 2);
350 ELSIF seq.tide > seq.high THEN (* must expand *)
351 temp := seq.a;
352 seq.high := seq.high * 2 + 1;
353 NEW(seq.a, (seq.high+1));
354 FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
355 END;
356 seq.a[seq.tide] := elem; INC(seq.tide);
357 END AppendModule;
358
359
360 PROCEDURE (et: Emiter) AddToImpolist(ns: MS.Namespace), NEW;
361 BEGIN
362 IF (ns # et.ns) & ~ns.Dumped() THEN
363 ns.SetModuleOrd(et.iNxt); INC(et.iNxt);
364 AppendModule(et.impo, ns);
365 END; (* IF *)
366 END AddToImpolist;
367
368
369 PROCEDURE NewEmiter(): Emiter;
370 VAR
371 et: Emiter;
372 BEGIN
373 NEW(et);
374 (*
375 * Initialization: cSum starts at zero. Since impOrd of
376 * the module is zero, impOrd of the imports starts at 1.
377 *)
378 et.version := NIL;
379 et.token := NIL;
380 et.cSum := 0;
381 et.iNxt := 1;
382 et.oNxt := tOffset; (* 1-15 are reserved for base types *)
383 NEW(et.work);
384 InitTypeSeq(et.work, MAXTYPE);
385 NEW(et.impo);
386 InitModuleSeq(et.impo, MAXMODULE);
387 RETURN et;
388 END NewEmiter;
389
390
391 PROCEDURE (et: Emiter) Reset(), NEW;
392 BEGIN
393 et.cSum := 0;
394 et.iNxt := 1;
395 et.oNxt := tOffset; (* 1-15 are reserved for base types *)
396 ResetTypeSeq(et.work);
397 ResetModuleSeq(et.impo);
398 END Reset;
399
400 (* ================================================================ *)
401
402 PROCEDURE (et: Emiter) Write(chr: INTEGER), NEW;
403 VAR
404 tmp: INTEGER;
405 BEGIN [UNCHECKED_ARITHMETIC]
406 (* need to turn off overflow checking here *)
407 IF ~PreEmit THEN
408 tmp := et.cSum * 2 + chr;
409 IF et.cSum < 0 THEN INC(tmp) END;
410 et.cSum := tmp;
411 GF.WriteByte(et.file, chr);
412 END; (* IF *)
413 END Write;
414
415
416 PROCEDURE (et: Emiter) WriteByte(byt: INTEGER), NEW;
417 BEGIN
418 IF ~PreEmit THEN
419 ASSERT((byt <= 127) & (byt > 0));
420 et.Write(bytSy);
421 et.Write(byt);
422 END; (* IF *)
423 END WriteByte;
424
425
426 PROCEDURE (et: Emiter) WriteChar(chr: CHAR), NEW;
427 CONST
428 mask = {0 .. 7};
429 VAR
430 a, b, int: INTEGER;
431 BEGIN
432 IF ~PreEmit THEN
433 et.Write(chrSy);
434 int := ORD(chr);
435 b := ORD(BITS(int) * mask); int := ASH(int, -8);
436 a := ORD(BITS(int) * mask);
437 et.Write(a); et.Write(b);
438 END; (* IF *)
439 END WriteChar;
440
441
442 PROCEDURE (et: Emiter) Write4B(int: INTEGER), NEW;
443 CONST mask = {0 .. 7};
444 VAR a,b,c,d : INTEGER;
445 BEGIN
446 IF ~PreEmit THEN
447 d := ORD(BITS(int) * mask); int := ASH(int, -8);
448 c := ORD(BITS(int) * mask); int := ASH(int, -8);
449 b := ORD(BITS(int) * mask); int := ASH(int, -8);
450 a := ORD(BITS(int) * mask);
451 et.Write(a);
452 et.Write(b);
453 et.Write(c);
454 et.Write(d);
455 END; (* IF *)
456 END Write4B;
457
458
459 PROCEDURE (et: Emiter) Write8B(val: LONGINT), NEW;
460 BEGIN
461 IF ~PreEmit THEN
462 et.Write4B(RTS.hiInt(val));
463 et.Write4B(RTS.loInt(val));
464 END; (* IF *)
465 END Write8B;
466
467
468 PROCEDURE (et: Emiter) WriteNum(num: LONGINT), NEW;
469 BEGIN
470 IF ~PreEmit THEN
471 et.Write(numSy);
472 et.Write8B(num);
473 END; (* IF *)
474 END WriteNum;
475
476
477 PROCEDURE (et: Emiter) WriteReal(flt: REAL), NEW;
478 VAR
479 rslt: LONGINT;
480 BEGIN
481 IF ~PreEmit THEN
482 et.Write(fltSy);
483 rslt := RTS.realToLongBits(flt);
484 et.Write8B(rslt);
485 END; (* IF *)
486 END WriteReal;
487
488
489 PROCEDURE (et: Emiter) WriteOrd(ord: INTEGER), NEW;
490 BEGIN
491 IF ~PreEmit THEN
492 IF ord <= 7FH THEN
493 et.Write(ord);
494 ELSIF ord <= 7FFFH THEN
495 et.Write(128 + ord MOD 128); (* LS7-bits first *)
496 et.Write(ord DIV 128); (* MS8-bits next *)
497 ELSE
498 ASSERT(FALSE);
499 END; (* IF *)
500 END; (* IF *)
501 END WriteOrd;
502
503
504 PROCEDURE (et: Emiter) WriteStrUTF(IN nam: ARRAY OF CHAR), NEW;
505 VAR
506 buf : ARRAY 256 OF INTEGER;
507 num : INTEGER;
508 idx : INTEGER;
509 chr : INTEGER;
510 BEGIN
511 IF ~PreEmit THEN
512 num := 0;
513 idx := 0;
514 chr := ORD(nam[idx]);
515 WHILE chr # 0H DO
516 IF chr <= 7FH THEN (* [0xxxxxxx] *)
517 buf[num] := chr; INC(num);
518 ELSIF chr <= 7FFH THEN (* [110xxxxx,10xxxxxx] *)
519 buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
520 buf[num ] := 0C0H + chr; INC(num, 2);
521 ELSE (* [1110xxxx,10xxxxxx,10xxxxxx] *)
522 buf[num+2] := 080H + chr MOD 64; chr := chr DIV 64;
523 buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
524 buf[num ] := 0E0H + chr; INC(num, 3);
525 END; (* IF *)
526 INC(idx); chr := ORD(nam[idx]);
527 END; (* WHILE *)
528 et.Write(num DIV 256);
529 et.Write(num MOD 256);
530 FOR idx := 0 TO num-1 DO et.Write(buf[idx]) END;
531 END; (* IF *)
532 END WriteStrUTF;
533
534
535 PROCEDURE (et: Emiter) WriteOpenUTF(chOp: CharOpen), NEW;
536 VAR
537 buf : ARRAY 256 OF INTEGER;
538 num : INTEGER;
539 idx : INTEGER;
540 chr : INTEGER;
541 BEGIN
542 IF ~PreEmit THEN
543 num := 0;
544 idx := 0;
545 chr := ORD(chOp[0]);
546 WHILE chr # 0H DO
547 IF chr <= 7FH THEN (* [0xxxxxxx] *)
548 buf[num] := chr; INC(num);
549 ELSIF chr <= 7FFH THEN (* [110xxxxx,10xxxxxx] *)
550 buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
551 buf[num ] := 0C0H + chr; INC(num, 2);
552 ELSE (* [1110xxxx,10xxxxxx,10xxxxxx] *)
553 buf[num+2] := 080H + chr MOD 64; chr := chr DIV 64;
554 buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
555 buf[num ] := 0E0H + chr; INC(num, 3);
556 END; (* IF *)
557 INC(idx);
558 chr := ORD(chOp[idx]);
559 END; (* WHILE *)
560 et.Write(num DIV 256);
561 et.Write(num MOD 256);
562 FOR idx := 0 TO num-1 DO et.Write(buf[idx]) END;
563 END; (* IF *)
564 END WriteOpenUTF;
565
566
567 PROCEDURE (et: Emiter) WriteString(IN str: ARRAY OF CHAR), NEW;
568 BEGIN
569 IF ~PreEmit THEN
570 et.Write(strSy);
571 et.WriteStrUTF(str);
572 END; (* IF *)
573 END WriteString;
574
575
576 PROCEDURE (et: Emiter) IsTypeForeign(t: MS.Type): BOOLEAN, NEW;
577 VAR
578 tnsname: CharOpen;
579 tasbname: CharOpen;
580 BEGIN
581 IF t.GetNamespace() # NIL THEN
582 tnsname := t.GetNamespaceName();
583 tasbname := t.GetAssemblyName();
584 IF (tnsname^ = et.nsname^) & (tasbname^ = et.asbname^) THEN
585 (* local type *)
586 RETURN FALSE;
587 ELSE
588 RETURN TRUE;
589 END; (* IF *)
590 ELSE
591 RETURN FALSE;
592 END; (* IF *)
593 END IsTypeForeign;
594
595 (* ================================================================ *)
596
597 PROCEDURE (et: Emiter) EmitKey(key: INTEGER), NEW;
598 BEGIN
599 et.Write(keySy);
600 et.Write4B(key);
601 END EmitKey;
602
603
604 PROCEDURE (et: Emiter) EmitName(name: CharOpen; vMod: INTEGER), NEW;
605 BEGIN
606 et.Write(namSy);
607 et.Write(vMod);
608 et.WriteOpenUTF(name);
609 END EmitName;
610
611
612 PROCEDURE (et: Emiter) EmitString(IN nam: ARRAY OF CHAR), NEW;
613 BEGIN
614 et.Write(strSy);
615 et.WriteStrUTF(nam);
616 END EmitString;
617
618
619 PROCEDURE (et: Emiter) EmitScopeName(asbname: CharOpen; nsname: CharOpen), NEW;
620 VAR
621 scopeNm: CharOpen;
622 BEGIN
623 scopeNm := ST.StrCat(ST.ToChrOpen("["),asbname);
624 scopeNm := ST.StrCatChr(scopeNm,"]");
625 IF nsname^ # MS.NULLSPACE THEN
626 scopeNm := ST.StrCat(scopeNm,nsname);
627 END; (* IF *)
628 et.EmitString(scopeNm);
629 END EmitScopeName;
630
631
632 PROCEDURE (et: Emiter) EmitHeader(), NEW;
633 BEGIN
634 et.Write4B(RTS.loInt(magic));
635 et.Write(modSy);
636 et.EmitName(et.modname, prvMode); (* hardcode to prvMode doesn't matter for Module *)
637 et.EmitScopeName(et.asbfile, et.nsname); (* <== should be asbfile or asbname? *)
638 et.Write(falSy);
639 END EmitHeader;
640
641
642 PROCEDURE (et: Emiter) EmitVersion(), NEW;
643 VAR
644 i: INTEGER;
645 BEGIN
646 IF et.version # NIL THEN
647 (* pack major and minor into a longint *)
648 et.Write(numSy);
649 et.Write4B(et.version[MS.Major]);
650 et.Write4B(et.version[MS.Minor]);
651 (* pack build and revision into a longint *)
652 et.Write(numSy);
653 et.Write4B(et.version[MS.Build]);
654 et.Write4B(et.version[MS.Revis]);
655 (* pack public key token into a longint *)
656 IF et.token # NIL THEN
657 et.Write(numSy);
658 FOR i := 0 TO 7 DO et.Write(et.token[i]); END;
659 ELSE
660 et.WriteNum(0);
661 END; (* IF *)
662 END; (* IF *)
663 END EmitVersion;
664
665
666 PROCEDURE (et: Emiter) DirectImports(), NEW;
667 VAR
668 fns: MS.Namespace;
669 nstv: MS.OTraverser;
670 BEGIN
671 IF et.ns.HasForeignSpaces() THEN
672 NEW(nstv);
673 nstv.Initialize(et.ns.GetForeignSpaces());
674 fns := nstv.GetNextNamespace();
675 WHILE fns # NIL DO
676 (* assigns import modules ordinal *)
677 et.AddToImpolist(fns);
678 fns := nstv.GetNextNamespace();
679 END; (* WHILE *)
680 END; (* IF *)
681 END DirectImports;
682
683
684 PROCEDURE (et: Emiter) EmitImports(), NEW;
685 VAR
686 indx: INTEGER;
687 fns: MS.Namespace;
688 fasbname: CharOpen;
689 fasbfile: CharOpen;
690 fnsname: CharOpen;
691 fmodname: CharOpen;
692 BEGIN
693 indx := 0;
694 WHILE indx < et.impo.tide DO
695 et.Write(impSy);
696 fns := et.impo.a[indx];
697 fnsname := fns.GetName();
698 fasbfile := fns.GetAssemblyFile();
699 fasbname := fns.GetAssemblyName();
700 fmodname := MS.MakeModuleName(fasbname, fnsname);
701 et.EmitName(fmodname, prvMode); (* hardcode vMode to prvMode
702 doesn't matter for Imports *)
703 IF (ST.StrChr(fnsname,'.') # ST.NotExist) OR
704 (fasbname^ # fnsname^) THEN
705 et.EmitScopeName(fasbfile, fnsname);
706 END; (* IF *)
707 et.EmitKey(0); (* key is zero for foreigns *)
708 INC(indx);
709 END; (* WHILE *)
710 END EmitImports;
711
712
713 PROCEDURE (et: Emiter) AddToWorklist(typ: MS.Type), NEW;
714 BEGIN
715 typ.SetTypeOrd(et.oNxt); INC(et.oNxt);
716 AppendType(et.work, typ);
717 END AddToWorklist;
718
719
720 PROCEDURE (et: Emiter) EmitTypeOrd(t: MS.Type), NEW;
721 BEGIN
722 IF ~t.Dumped() THEN et.AddToWorklist(t); END;
723 et.WriteOrd(t.GetTypeOrd());
724 END EmitTypeOrd;
725
726
727 PROCEDURE (et: Emiter) EmitLocalTypeName(typ: MS.Type), NEW;
728 VAR
729 tname: CharOpen;
730 BEGIN
731 typ.SetInHierarchy();
732 tname := et.MakeFullTypeName(typ);
733 et.Write(typSy);
734 et.EmitName(tname, pubMode);
735 et.EmitTypeOrd(typ);
736 END EmitLocalTypeName;
737
738
739 PROCEDURE (et: Emiter) EmitLocalTypes(), NEW;
740 VAR
741 tv: MS.OTraverser;
742 t: MS.Type;
743 tname: CharOpen;
744 tord: INTEGER;
745 ntv: MS.OTraverser;
746 nt: MS.Type;
747 BEGIN
748 NEW(tv); tv.Initialize(et.ns.GetTypes());
749 t := tv.GetNextType();
750 WHILE t # NIL DO
751 IF t.IsExported() THEN
752 IF (et.mnameKind = SingleWord) & (t.GetName()^ = et.nsname^) THEN
753 IF t.IsInterface() THEN
754 (* if 't' is POINTER TO INTERFACE, it cannot be main type *)
755 et.EmitLocalTypeName(t);
756 ELSE
757 (* a gpcp module main type, don't emit this type *)
758 et.maintyp := t;
759 END; (* IF *)
760 ELSE
761 et.EmitLocalTypeName(t);
762 END; (* IF *)
763 END; (* IF *)
764 t := tv.GetNextType();
765 END; (* WHILE *)
766 END EmitLocalTypes;
767
768
769 PROCEDURE (et: Emiter) EmitTypes(), NEW;
770 BEGIN
771 et.EmitLocalTypes();
772 END EmitTypes;
773
774
775 PROCEDURE (et: Emiter) EmitTypeHeader(t: MS.Type), NEW;
776 BEGIN
777 et.Write(tDefS);
778 et.WriteOrd(t.GetTypeOrd());
779 IF et.IsTypeForeign(t) & ~t.IsAnonymous() THEN
780 et.Write(fromS);
781 et.WriteOrd(t.GetNamespace().GetModuleOrd());
782 et.EmitName(MakeTypeName(t), pubMode);
783 END; (* IF *)
784 END EmitTypeHeader;
785
786
787 PROCEDURE (et: Emiter) EmitNamedType(t: MS.Type), NEW;
788 BEGIN
789 et.EmitTypeHeader(t);
790 END EmitNamedType;
791
792
793 PROCEDURE (et: Emiter) EmitArrayType(t: MS.ArrayType), NEW;
794 VAR
795 elm: MS.Type;
796 len: INTEGER;
797 BEGIN
798 et.EmitTypeHeader(t);
799 et.Write(arrSy);
800 et.EmitTypeOrd(t.GetElement());
801 len := t.GetLength();
802 IF len > 127 THEN
803 et.WriteNum(len);
804 ELSIF len > 0 THEN
805 et.WriteByte(len);
806 ELSE
807 END; (* IF *)
808 et.Write(endAr);
809 END EmitArrayType;
810
811
812 PROCEDURE (et: Emiter) EmitPointerType(t: MS.PointerType), NEW;
813 VAR
814 tgt: MS.Type;
815 BEGIN
816 IF t.IsDelegate() THEN
817 tgt := t.GetTarget();
818 WITH tgt: MS.DelegType DO
819 tgt.SetTypeOrd(t.GetTypeOrd());
820 et.EmitDelegate(tgt);
821 tgt.ClearTypeOrd();
822 ELSE
823 ASSERT(FALSE);
824 END; (* WITH *)
825
826 ELSE
827 et.EmitTypeHeader(t);
828 et.Write(ptrSy);
829 tgt := t.GetTarget();
830 IF t.IsInHierarchy() THEN
831 tgt.SetInHierarchy();
832 ELSE
833 END; (* IF *)
834 et.EmitTypeOrd(tgt);
835 END; (* IF *)
836 END EmitPointerType;
837
838
839 PROCEDURE (et: Emiter) EmitMethodAttribute(m: MS.Method), NEW;
840 VAR
841 mthAtt: SET;
842 dt: MS.Type;
843 BEGIN
844 mthAtt := {};
845 IF m.IsNew() THEN
846 mthAtt := isNew;
847 END; (* IF *)
848 dt := m.GetDeclaringType();
849 IF m.IsAbstract() THEN
850 mthAtt := mthAtt + isAbs;
851 ELSIF (dt.IsAbstract() OR dt.IsExtensible()) & m.IsExtensible() THEN
852 mthAtt := mthAtt + isExt;
853 END; (* IF *)
854 et.Write(ORD(mthAtt));
855 END EmitMethodAttribute;
856
857
858 PROCEDURE (et: Emiter) EmitReceiverInfo (m: MS.Method), NEW;
859 VAR
860 rcvr: MS.Type;
861 BEGIN
862 rcvr := m.GetDeclaringType();
863 IF rcvr IS MS.ValueType THEN
864 et.Write(in); (* IN par mode for value type in dll's sym *)
865 ELSE
866 et.Write(val); (* value par mode for obj ref type in dll's sym *)
867 END; (* IF *)
868 et.EmitTypeOrd(rcvr);
869 END EmitReceiverInfo;
870
871
872 PROCEDURE (et: Emiter)EmitAnonymousArrayPointerType(t: MS.PointerType): MS.PointerType, NEW;
873 VAR
874 ptype: MS.PointerType;
875 tgt: MS.Type;
876 BEGIN
877 ptype := NIL;
878 tgt := t.GetTarget();
879 WITH tgt: MS.ArrayType DO
880 ptype := tgt.GetAnonymousPointerType();
881 IF ptype = NIL THEN
882 ptype := MS.MakeAnonymousPointerType(tgt);
883 END; (* IF *)
884 ELSE
885 ASSERT(FALSE);
886 END; (* IF *)
887
888 et.EmitTypeOrd(ptype);
889 RETURN ptype;
890 END EmitAnonymousArrayPointerType;
891
892
893 PROCEDURE (et: Emiter) EmitFormals(m: MS.Method), NEW;
894 VAR
895 rtype: MS.Type;
896 tv: MS.FTraverser;
897 formals: MS.FormalList;
898 f: MS.Formal;
899 ftype: MS.Type;
900 dmyPType: MS.PointerType;
901 BEGIN
902 WITH m: MS.Function DO
903 rtype := m.GetReturnType();
904 et.Write(retSy);
905 et.EmitTypeOrd(rtype);
906 ELSE
907 END; (* WITH *)
908 et.Write(frmSy);
909 formals := m.GetFormals();
910 IF formals.Length() # 0 THEN
911 NEW(tv); tv.Initialize(formals);
912 f := tv.GetNextFormal();
913 WHILE f # NIL DO
914 et.Write(parSy);
915 et.Write(f.GetParameterMode());
916 ftype := f.GetType();
917 WITH ftype: MS.PointerType DO
918 IF ftype.IsArrayPointer() THEN
919 dmyPType := et.EmitAnonymousArrayPointerType(ftype); (* what if the formal type is array pointer but not anonymous (created by GPCP) *)
920 f.SetType(dmyPType, FALSE);
921 ELSE
922 et.EmitTypeOrd(ftype);
923 END; (* IF *)
924 ELSE
925 et.EmitTypeOrd(ftype);
926 END; (* IF *)
927
928 f := tv.GetNextFormal();
929 END; (* WHILE *)
930 END; (* IF *)
931 et.Write(endFm);
932 END EmitFormals;
933
934
935 PROCEDURE RequireInvokeName(mth: MS.Method): BOOLEAN;
936 BEGIN
937 IF mth.IsConstructor() THEN
938 (* constructors always require invoke name *)
939 RETURN TRUE;
940 ELSE
941 IF MS.WithoutMethodNameMangling() THEN
942 RETURN FALSE
943 ELSE
944 RETURN mth.IsOverload();
945 END;
946 END; (* IF *)
947 END RequireInvokeName;
948
949
950 PROCEDURE (et: Emiter) EmitVirtMethods(t: MS.Type), NEW;
951 VAR
952 tv: MS.OTraverser;
953 m : MS.Method;
954 mname: CharOpen;
955 vMod: INTEGER;
956 BEGIN
957 NEW(tv); tv.Initialize(t.GetVirtualMethods());
958 m := tv.GetNextMethod();
959 WHILE m # NIL DO
960 IF m.IsExported() THEN
961 mname := m.GetName();
962 et.Write(mthSy);
963 vMod := pubMode;
964 IF m.IsProtected() THEN
965 vMod := protect;
966 END; (* IF *)
967 et.EmitName(mname, vMod);
968 et.EmitMethodAttribute(m);
969 et.EmitReceiverInfo(m);
970 IF RequireInvokeName(m) THEN
971 et.EmitString(m.GetInvokeName());
972 END; (* IF *)
973 et.EmitFormals(m);
974 END; (* IF *)
975 m := tv.GetNextMethod();
976 END; (* WHILE *)
977 END EmitVirtMethods;
978
979
980 PROCEDURE (et: Emiter) EmitImplInterfaces(t: MS.Type), NEW;
981 (* [iFcSy {basSy TypeOrd}]
982 *)
983 VAR
984 tv: MS.OTraverser;
985 it: MS.Type;
986 BEGIN
987 et.Write(iFcSy);
988 NEW(tv); tv.Initialize(t.GetInterfaces());
989 it := tv.GetNextType();
990 WHILE it # NIL DO
991 IF it.IsExported() THEN
992 et.Write(basSy);
993 et.EmitTypeOrd(it);
994 IF t.IsInterface() THEN
995 (* interface (t) inherits other interface (it) *)
996 it.SetInHierarchy(); (* to force emiting of parent interface (it) methods *)
997 END; (* IF *)
998 END; (* IF *)
999 it := tv.GetNextType();
1000 END; (* WHILE *)
1001 END EmitImplInterfaces;
1002
1003
1004 PROCEDURE (et: Emiter) EmitInterfaceType(t: MS.IntfcType), NEW;
1005 VAR
1006 recAtt: INTEGER;
1007 base: MS.Type;
1008 BEGIN
1009 recAtt := iFace;
1010 et.EmitTypeHeader(t);
1011 et.Write(recSy);
1012 et.Write(recAtt);
1013 et.Write(truSy);
1014 base := t.GetBaseType();
1015 IF base # NIL THEN
1016 et.Write(basSy);
1017 et.EmitTypeOrd(base);
1018 END; (* IF *)
1019
1020 IF t.HasImplInterfaces() THEN
1021 et.EmitImplInterfaces(t);
1022 END; (* IF *)
1023
1024 IF t.HasVirtualMethods() THEN
1025 et.EmitVirtMethods(t);
1026 END; (* IF *)
1027 et.Write(endRc);
1028 END EmitInterfaceType;
1029
1030
1031 PROCEDURE (et: Emiter)EmitFields(t: MS.Type), NEW;
1032 VAR
1033 tv: MS.OTraverser;
1034 flist: MS.OrderList;
1035 f: MS.Field;
1036 vMod: INTEGER;
1037 ftype: MS.Type;
1038 dmyPType: MS.PointerType;
1039 BEGIN
1040 flist := t.GetInstanceFields();
1041 IF flist = NIL THEN RETURN END;
1042 NEW(tv); tv.Initialize(flist);
1043 f := tv.GetNextField();
1044 WHILE f # NIL DO
1045 IF f.IsExported() THEN
1046 vMod := pubMode;
1047 IF f.IsProtected() THEN
1048 vMod := protect;
1049 END; (* IF *)
1050 et.EmitName(f.GetName(), vMod);
1051 ftype := f.GetType();
1052 WITH ftype: MS.PointerType DO
1053 IF ftype.IsArrayPointer() THEN
1054 dmyPType := et.EmitAnonymousArrayPointerType(ftype); (* what if the field type is array pointer but not anonymous (created by GPCP) *)
1055 f.SetType(dmyPType);
1056 ELSE
1057 et.EmitTypeOrd(ftype);
1058 END; (* IF *)
1059 ELSE
1060 et.EmitTypeOrd(ftype);
1061 END; (* IF *)
1062 END; (* IF *)
1063 f := tv.GetNextField();
1064 END; (* WHILE *)
1065 END EmitFields;
1066
1067
1068 PROCEDURE (et: Emiter) EmitEventFields(t: MS.Type), NEW;
1069 VAR
1070 tv: MS.OTraverser;
1071 elist: MS.OrderList;
1072 e: MS.Event;
1073
1074 ename: CharOpen;
1075 htype: MS.Type;
1076 tname: CharOpen;
1077 BEGIN
1078 NEW(tv); tv.Initialize(t.GetEventList());
1079 e := tv.GetNextEvent();
1080 WHILE e # NIL DO
1081 et.EmitName(e.GetName(), pubMode); (* event always be exported for an public record *)
1082 et.EmitTypeOrd(e.GetHandlerType()); (* we put the handler type(as .NET does) *)
1083 e := tv.GetNextEvent();
1084 END; (* WHILE *)
1085 END EmitEventFields;
1086
1087
1088 PROCEDURE (et: Emiter) EmitVariables(t: MS.Type), NEW;
1089 VAR
1090 tv: MS.OTraverser;
1091 flist: MS.OrderList;
1092 f: MS.Field;
1093 vMod: INTEGER;
1094 ftype: MS.Type;
1095 dmyPType: MS.PointerType;
1096 BEGIN
1097 flist := t.GetStaticFields();
1098 IF flist = NIL THEN RETURN END;
1099 NEW(tv); tv.Initialize(flist);
1100 f := tv.GetNextField();
1101 WHILE f # NIL DO
1102 IF f.IsExported() THEN
1103 et.Write(varSy);
1104 vMod := pubMode;
1105 IF f.IsProtected() THEN
1106 vMod := protect;
1107 END; (* IF *)
1108 et.EmitName(f.GetName(), vMod);
1109 ftype := f.GetType();
1110 WITH ftype: MS.PointerType DO
1111 IF ftype.IsArrayPointer() THEN
1112 dmyPType := et.EmitAnonymousArrayPointerType(ftype); (* what if the field type is array pointer but not anonymous (created by GPCP) *)
1113 f.SetType(dmyPType);
1114 ELSE
1115 et.EmitTypeOrd(ftype);
1116 END; (* IF *)
1117 ELSE
1118 et.EmitTypeOrd(ftype);
1119 END; (* IF *)
1120 END; (* IF *)
1121 f := tv.GetNextField();
1122 END; (* WHILE *)
1123 END EmitVariables;
1124
1125
1126 PROCEDURE (et: Emiter) EmitValue(lit: MS.Literal), NEW;
1127 BEGIN
1128 WITH lit: MS.BoolLiteral DO
1129 IF lit.GetValue() THEN et.Write(truSy); ELSE et.Write(falSy); END;
1130 | lit: MS.CharLiteral DO
1131 et.WriteChar(lit.GetValue());
1132 | lit: MS.StrLiteral DO
1133 et.WriteString(lit.GetValue());
1134 | lit: MS.NumLiteral DO
1135 et.WriteNum(lit.GetValue());
1136 | lit: MS.FloatLiteral DO
1137 et.WriteReal(lit.GetValue());
1138 ELSE
1139 END; (* WITH *)
1140 END EmitValue;
1141
1142
1143 PROCEDURE (et: Emiter) EmitConstants(t: MS.Type), NEW;
1144 VAR
1145 tv: MS.OTraverser;
1146 c: MS.Constant;
1147 vMod: INTEGER;
1148 BEGIN
1149 NEW(tv); tv.Initialize(t.GetConstants());
1150 c := tv.GetNextConstant();
1151 WHILE c # NIL DO
1152 IF c.IsExported() THEN
1153 et.Write(conSy);
1154 vMod := pubMode;
1155 IF c.IsProtected() THEN
1156 vMod := protect;
1157 END; (* IF *)
1158 et.EmitName(c.GetName(), vMod);
1159 et.EmitValue(c.GetValue());
1160 END; (* IF *)
1161 c := tv.GetNextConstant();
1162 END; (* WHILE *)
1163 END EmitConstants;
1164
1165
1166 PROCEDURE (et: Emiter) EmitStaticMethods(t: MS.Type), NEW;
1167 VAR
1168 tv: MS.OTraverser;
1169 m : MS.Method;
1170 mname: CharOpen;
1171 vMod: INTEGER;
1172 BEGIN
1173 NEW(tv); tv.Initialize(t.GetStaticMethods());
1174 m := tv.GetNextMethod();
1175 WHILE m # NIL DO
1176 IF (m.GetDeclaringType() = et.maintyp) & (m.IsConstructor()) THEN
1177 (* don't emit any maintyp's constructor for a GPCP module *)
1178 ELSE
1179 IF m.IsExported() THEN
1180 mname := m.GetName();
1181 IF mname^ # "Main" THEN
1182 et.Write(prcSy);
1183 vMod := pubMode;
1184 IF m.IsProtected() THEN vMod := protect; END;
1185 et.EmitName(mname, vMod);
1186 IF RequireInvokeName(m) THEN et.EmitString(m.GetInvokeName()); END;
1187 IF m.IsConstructor() THEN et.Write(truSy); END;
1188 et.EmitFormals(m);
1189 END; (* IF *)
1190 END; (* IF *)
1191 END; (* IF *)
1192 m := tv.GetNextMethod();
1193 END; (* WHILE *)
1194 END EmitStaticMethods;
1195
1196
1197 PROCEDURE (et: Emiter) EmitStrucType(t: MS.ValueType), NEW;
1198 (*
1199 ** Record = TypeHeader recSy recAtt [truSy | falSy | <others>]
1200 * [basSy TypeOrd] [iFcSy {basSy TypeOrd}]
1201 ** {Name TypeOrd} {Method} {Statics} endRc.
1202 *)
1203 VAR
1204 recAtt: INTEGER;
1205 base: MS.Type;
1206 basevalue: MS.Type;
1207 BEGIN
1208 recAtt := noAtt;
1209 IF t.IsAbstract() THEN
1210 recAtt := abstr;
1211 ELSIF t.IsExtensible() THEN
1212 recAtt := extns;
1213 END; (* IF *)
1214 IF ~t.HasNoArgConstructor() THEN INC(recAtt, nnarg); END;
1215 IF t.IsValueType() THEN INC(recAtt, valTp); END;
1216 et.EmitTypeHeader(t);
1217 et.Write(recSy);
1218 et.Write(recAtt);
1219 et.Write(falSy);
1220 base := t.GetBaseType();
1221 IF (base # NIL) & (base # MS.baseTypeArray[anyRec]) THEN (* <== *)
1222 et.Write(basSy);
1223 WITH base: MS.PointerType DO
1224 basevalue := base.GetTarget();
1225 IF t.IsInHierarchy() THEN
1226 base.SetInHierarchy();
1227 basevalue.SetInHierarchy();
1228 IF ~base.Dumped() THEN
1229 et.AddToWorklist(base);
1230 ELSE
1231 END; (* IF *)
1232 ELSE
1233 END; (* IF *)
1234 (* request by Diane, base type is class, rather than record *)
1235 et.EmitTypeOrd(base);
1236 ELSE
1237 ASSERT(base.GetTypeOrd() = anyRec);
1238 END; (* WITH *)
1239 ELSE
1240 (* no base type declared, so use ANYREC as its base type *)
1241 et.Write(basSy);
1242 et.Write(anyRec);
1243 END; (* IF *)
1244
1245 IF t.HasImplInterfaces() THEN et.EmitImplInterfaces(t); END;
1246 IF t.HasInstanceFields() THEN et.EmitFields(t); END;
1247 IF t.HasEvents() THEN et.EmitEventFields(t); END;
1248 IF t.HasVirtualMethods() THEN et.EmitVirtMethods(t); END;
1249 IF t.HasConstants() THEN et.EmitConstants(t); END;
1250 IF t.HasStaticFields() THEN et.EmitVariables(t); END;
1251 IF t.HasStaticMethods() THEN et.EmitStaticMethods(t); END;
1252
1253 et.Write(endRc);
1254 END EmitStrucType;
1255
1256
1257 PROCEDURE (et: Emiter) EmitEnumType(t: MS.EnumType), NEW;
1258 BEGIN
1259 et.EmitTypeHeader(t);
1260 et.Write(eTpSy);
1261 et.EmitConstants(t);
1262 et.Write(endRc);
1263 END EmitEnumType;
1264
1265
1266 PROCEDURE (et: Emiter) EmitDelegate(t: MS.DelegType), NEW;
1267 VAR
1268 imth: MS.Method;
1269 BEGIN
1270 et.EmitTypeHeader(t);
1271 IF t.IsMulticast() THEN
1272 et.Write(evtSy);
1273 ELSE
1274 et.Write(pTpSy);
1275 END; (* IF *)
1276 imth := t.GetInvokeMethod();
1277 et.EmitFormals(imth);
1278 END EmitDelegate;
1279
1280
1281 PROCEDURE (et: Emiter) EmitTypeList(), NEW;
1282 VAR
1283 indx: INTEGER;
1284 type: MS.Type;
1285 ns: MS.Namespace;
1286 nt: MS.Type;
1287 ntv: MS.OTraverser;
1288 tgt: MS.Type;
1289 BEGIN
1290 et.Write(start);
1291 indx := 0;
1292 WHILE indx < et.work.tide DO
1293 type := et.work.a[indx];
1294 ns := type.GetNamespace();
1295 IF ns # NIL THEN et.AddToImpolist(ns); END;
1296 WITH type: MS.PointerType DO
1297 tgt := type.GetTarget();
1298 WITH tgt: MS.RecordType DO
1299 IF type.IsInHierarchy() THEN
1300 et.EmitPointerType(type);
1301 ELSIF ~et.IsTypeForeign(type) THEN
1302 (* a non-Exported type but referenced by other type *)
1303 et.EmitPointerType(type);
1304 ELSE
1305 et.EmitNamedType(type);
1306 END; (* IF *)
1307 | tgt: MS.ArrayType DO
1308 et.EmitPointerType(type);
1309 ELSE
1310 END; (* WITH *)
1311 | type: MS.ArrayType DO
1312 et.EmitArrayType(type);
1313 | type: MS.RecordType DO
1314 WITH type: MS.IntfcType DO
1315 et.EmitInterfaceType(type);
1316 | type: MS.ValueType DO
1317 WITH type: MS.EnumType DO
1318 et.EmitEnumType(type);
1319 | type: MS.PrimType DO (* for IntPtr and UIntPtr *)
1320 IF type.IsInHierarchy() THEN
1321 et.EmitStrucType(type);
1322 ELSIF ~et.IsTypeForeign(type) THEN
1323 (* a non-Exported type but referenced by other type *)
1324 et.EmitStrucType(type);
1325 ELSE
1326 et.EmitNamedType(type);
1327 END; (* IF *)
1328 ELSE
1329 END; (* WITH *)
1330 ELSE
1331 END; (* WITH *)
1332 | type: MS.NamedType DO
1333 et.EmitNamedType(type);
1334 ELSE
1335 END; (* WITH *)
1336 INC(indx);
1337 END; (* WHILE *)
1338 et.Write(close);
1339 END EmitTypeList;
1340
1341
1342 PROCEDURE (et: Emiter) EmitModule(), NEW;
1343 (*
1344 * SymFile =
1345 * Header [String (falSy | truSy | <others>)]
1346 * {Import | Constant | Variable | Type | Procedure | Method} TypeList.
1347 * Header = magic modSy Name.
1348 *)
1349 BEGIN
1350 (* Walk through all types to gather info about import modules *)
1351 PreEmit := TRUE;
1352 et.DirectImports();
1353 et.EmitTypes();
1354 IF et.maintyp # NIL THEN
1355 IF et.maintyp.HasStaticFields() THEN
1356 et.EmitVariables(et.maintyp);
1357 END; (* IF *)
1358 IF et.maintyp.HasStaticMethods() THEN
1359 et.EmitStaticMethods(et.maintyp);
1360 END; (* IF *)
1361 END; (* IF *)
1362 et.EmitTypeList();
1363
1364
1365 (* Now really emit type info *)
1366 PreEmit := FALSE;
1367 et.EmitHeader();
1368 et.EmitVersion();
1369 et.EmitImports();
1370 et.EmitTypes();
1371 IF et.maintyp # NIL THEN
1372 IF et.maintyp.HasConstants() THEN
1373 et.EmitConstants(et.maintyp);
1374 END; (* IF *)
1375 IF et.maintyp.HasStaticFields() THEN
1376 et.EmitVariables(et.maintyp);
1377 END; (* IF *)
1378 IF et.maintyp.HasStaticMethods() THEN
1379 et.EmitStaticMethods(et.maintyp);
1380 END; (* IF *)
1381 END; (* IF *)
1382 et.EmitTypeList();
1383 et.EmitKey(0);
1384 END EmitModule;
1385
1386
1387 PROCEDURE EmitSymbolFiles*(asb: MS.Assembly);
1388 VAR
1389 et: Emiter;
1390 filename: CharOpen;
1391 tv: MS.OTraverser;
1392 onewordname: BOOLEAN;
1393 samewordname: BOOLEAN;
1394 inclwordname: BOOLEAN;
1395 BEGIN
1396 NEW(tv); tv.Initialize(asb.GetNamespaces());
1397 et := NewEmiter();
1398 et.asbname := asb.GetName();
1399 et.asbfile := asb.GetFileName();
1400 et.version := asb.GetVersion();
1401 et.token := asb.GetPublicKeyToken();
1402 et.ns := tv.GetNextNamespace();
1403 IF et.ns # NIL THEN
1404 et.nsname := et.ns.GetName();
1405 onewordname := MS.IsOneWordName(et.asbname, et.nsname);
1406 samewordname := MS.IsSameWordName(et.asbname, et.nsname);
1407 IF onewordname & samewordname & (asb.NamespaceCount() = 1) THEN
1408 (* It is very likely to be a GPCP compiled DLL or exe *)
1409 et.mnameKind := SingleWord;
1410 et.modname := MS.MakeModuleName(et.asbname, et.nsname);
1411 filename := ST.StrCat(et.modname, ST.ToChrOpen(SymbolExt));
1412 et.file := GF.createFile(filename);
1413 IF et.file = NIL THEN
1414 Error.WriteString("Cannot create file <" + filename^ + ">"); Error.WriteLn;
1415 ASSERT(FALSE);
1416 RETURN;
1417 END; (* IF *)
1418 et.EmitModule();
1419 GF.CloseFile(et.file);
1420 et.Reset();
1421 ELSE
1422 REPEAT
1423 IF ~onewordname & samewordname THEN
1424 (* cannot be null namespace here *)
1425 et.mnameKind := MultipleWord;
1426 ELSE
1427 et.mnameKind := DifferentWord;
1428 END; (* IF *)
1429 et.modname := MS.MakeModuleName(et.asbname, et.nsname);
1430 filename := ST.StrCat(et.modname, ST.ToChrOpen(SymbolExt));
1431 et.file := GF.createFile(filename);
1432 IF et.file = NIL THEN
1433 Error.WriteString("Cannot create file <" + filename^ + ">"); Error.WriteLn;
1434 ASSERT(FALSE);
1435 RETURN;
1436 END; (* IF *)
1437 et.EmitModule();
1438 GF.CloseFile(et.file);
1439 et.Reset();
1440 et.ns := tv.GetNextNamespace();
1441
1442 IF et.ns # NIL THEN
1443 et.nsname := et.ns.GetName();
1444 onewordname := (ST.StrChr(et.nsname,'.') = ST.NotExist);
1445 samewordname := (et.asbname^ = ST.StrSubChr(et.nsname,'.','_')^);
1446 END; (* IF *)
1447 UNTIL et.ns = NIL;
1448 END; (* IF *)
1449 END; (* IF *)
1450 END EmitSymbolFiles;
1451
1452 END SymWriter.
[FORK] Old GPCP with patches
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024