2 (* ========================================================================= *)
4 (* Symbol file writing module for the .NET to Gardens Point Component *)
5 (* Pascal Symbols tool. *)
6 (* Copyright (c) Siu-Yuen Chan 2001. *)
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 (* ========================================================================= *)
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"] *)
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"] *)
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"] *)
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"] *)
50 (* ========================================================================= *
51 // Collected syntax ---
53 // SymFile = Header [String (falSy | truSy | <other attribute>)]
55 // {Import | Constant | Variable | Type | Procedure}
57 // -- optional String is external name.
58 // -- falSy ==> Java class
59 // -- truSy ==> Java interface
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
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.
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.
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 // ======================================================================== *)
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'
);
132 tOffset
* = 16; (* backward compatibility with JavaVersion *)
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
;
141 CONST (* base-ordinals *)
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 *)
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 *)
169 CONST (* method attributes *)
177 covar
* = MS
.Mcovar
; (* ==> covariant return type *)
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 *)
188 CharOpen = POINTER TO ARRAY OF CHAR;
190 CharOpen
= ST
.CharOpen
;
196 a
: POINTER TO ARRAY OF MS
.Type
;
199 ModuleSeq
= POINTER TO
203 a
: POINTER TO ARRAY OF MS
.Namespace
;
213 token
: MS
.PublicKeyToken
;
219 iNxt
: INTEGER; (* next IMPORT Ord *)
220 oNxt
: INTEGER; (* next TypeOrd *)
229 PROCEDURE ^
(et
: Emiter
) EmitDelegate(t
: MS
.DelegType
), NEW;
232 PROCEDURE MakeTypeName(typ
: MS
.Type
): CharOpen
;
233 (* for handling the '+' sign inside the Beta2 nested type name *)
238 name
:= typ
.GetName();
239 IF typ
.IsNested() THEN
240 idx
:= ST
.StrChr(name
, '
+'
);
241 IF idx
# ST
.NotExist
THEN
244 ASSERT(ST
.StrChr(name
, '
+'
) = ST
.NotExist
);
251 PROCEDURE (et
: Emiter
) MakeFullTypeName(typ
: MS
.Type
): CharOpen
, NEW;
260 tnsname
:= typ
.GetNamespaceName();
261 tasbname
:= typ
.GetAssemblyName();
262 IF (tnsname^
= et
.nsname^
) & (tasbname^
= et
.asbname^
) THEN
264 tname
:= MakeTypeName(typ
);
267 tmodname
:= MS
.MakeModuleName(tasbname
, tnsname
);
268 tmodname
:= ST
.StrCatChr(tmodname
, '
.'
);
269 tname
:= ST
.StrCat(tmodname
, MakeTypeName(typ
));
272 END MakeFullTypeName
;
275 PROCEDURE InitTypeSeq(seq
: TypeSeq
; capacity
: INTEGER);
277 NEW(seq
.a
, capacity
);
278 seq
.high
:= capacity
-1;
283 PROCEDURE InitModuleSeq(seq
: ModuleSeq
; capacity
: INTEGER);
285 NEW(seq
.a
, capacity
);
286 seq
.high
:= capacity
-1;
291 PROCEDURE ResetTypeSeq(VAR seq
: TypeSeq
);
299 FOR i
:= 0 TO seq
.tide
-1 DO
300 type
:= seq
.a
[i
]; seq
.a
[i
] := NIL;
302 type
.ClearInHierarchy();
309 PROCEDURE ResetModuleSeq(VAR seq
: ModuleSeq
);
315 InitModuleSeq(seq
, 2);
317 FOR i
:= 0 TO seq
.tide
-1 DO
318 ns
:= seq
.a
[i
]; seq
.a
[i
] := NIL;
326 PROCEDURE AppendType(VAR seq
: TypeSeq
; elem
: MS
.Type
);
328 temp
: POINTER TO ARRAY OF MS
.Type
;
333 ELSIF seq
.tide
> seq
.high
THEN (* must expand *)
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;
339 seq
.a
[seq
.tide
] := elem
; INC(seq
.tide
);
343 PROCEDURE AppendModule(VAR seq
: ModuleSeq
; elem
: MS
.Namespace
);
345 temp
: POINTER TO ARRAY OF MS
.Namespace
;
349 InitModuleSeq(seq
, 2);
350 ELSIF seq
.tide
> seq
.high
THEN (* must expand *)
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;
356 seq
.a
[seq
.tide
] := elem
; INC(seq
.tide
);
360 PROCEDURE (et
: Emiter
) AddToImpolist(ns
: MS
.Namespace
), NEW;
362 IF (ns
# et
.ns
) & ~ns
.Dumped() THEN
363 ns
.SetModuleOrd(et
.iNxt
); INC(et
.iNxt
);
364 AppendModule(et
.impo
, ns
);
369 PROCEDURE NewEmiter(): Emiter
;
375 * Initialization: cSum starts at zero. Since impOrd of
376 * the module is zero, impOrd of the imports starts at 1.
382 et
.oNxt
:= tOffset
; (* 1-15 are reserved for base types *)
384 InitTypeSeq(et
.work
, MAXTYPE
);
386 InitModuleSeq(et
.impo
, MAXMODULE
);
391 PROCEDURE (et
: Emiter
) Reset(), NEW;
395 et
.oNxt
:= tOffset
; (* 1-15 are reserved for base types *)
396 ResetTypeSeq(et
.work
);
397 ResetModuleSeq(et
.impo
);
400 (* ================================================================ *)
402 PROCEDURE (et
: Emiter
) Write(chr
: INTEGER), NEW;
405 BEGIN [UNCHECKED_ARITHMETIC
]
406 (* need to turn off overflow checking here *)
408 tmp
:= et
.cSum
* 2 + chr
;
409 IF et
.cSum
< 0 THEN INC(tmp
) END;
411 GF
.WriteByte(et
.file
, chr
);
416 PROCEDURE (et
: Emiter
) WriteByte(byt
: INTEGER), NEW;
419 ASSERT((byt
<= 127) & (byt
> 0));
426 PROCEDURE (et
: Emiter
) WriteChar(chr
: CHAR), NEW;
435 b
:= ORD(BITS(int
) * mask
); int
:= ASH(int
, -8);
436 a
:= ORD(BITS(int
) * mask
);
437 et
.Write(a
); et
.Write(b
);
442 PROCEDURE (et
: Emiter
) Write4B(int
: INTEGER), NEW;
443 CONST mask
= {0 .. 7};
444 VAR a
,b
,c
,d
: INTEGER;
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
);
459 PROCEDURE (et
: Emiter
) Write8B(val
: LONGINT), NEW;
462 et
.Write4B(RTS
.hiInt(val
));
463 et
.Write4B(RTS
.loInt(val
));
468 PROCEDURE (et
: Emiter
) WriteNum(num
: LONGINT), NEW;
477 PROCEDURE (et
: Emiter
) WriteReal(flt
: REAL), NEW;
483 rslt
:= RTS
.realToLongBits(flt
);
489 PROCEDURE (et
: Emiter
) WriteOrd(ord
: INTEGER), NEW;
494 ELSIF ord
<= 7FFFH
THEN
495 et
.Write(128 + ord
MOD 128); (* LS7-bits first *)
496 et
.Write(ord
DIV 128); (* MS8-bits next *)
504 PROCEDURE (et
: Emiter
) WriteStrUTF(IN nam
: ARRAY OF CHAR), NEW;
506 buf
: ARRAY 256 OF INTEGER;
514 chr
:= ORD(nam
[idx
]);
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);
526 INC(idx
); chr
:= ORD(nam
[idx
]);
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;
535 PROCEDURE (et
: Emiter
) WriteOpenUTF(chOp
: CharOpen
), NEW;
537 buf
: ARRAY 256 OF INTEGER;
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);
558 chr
:= ORD(chOp
[idx
]);
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;
567 PROCEDURE (et
: Emiter
) WriteString(IN str
: ARRAY OF CHAR), NEW;
576 PROCEDURE (et
: Emiter
) IsTypeForeign(t
: MS
.Type
): BOOLEAN, NEW;
581 IF t
.GetNamespace() # NIL THEN
582 tnsname
:= t
.GetNamespaceName();
583 tasbname
:= t
.GetAssemblyName();
584 IF (tnsname^
= et
.nsname^
) & (tasbname^
= et
.asbname^
) THEN
595 (* ================================================================ *)
597 PROCEDURE (et
: Emiter
) EmitKey(key
: INTEGER), NEW;
604 PROCEDURE (et
: Emiter
) EmitName(name
: CharOpen
; vMod
: INTEGER), NEW;
608 et
.WriteOpenUTF(name
);
612 PROCEDURE (et
: Emiter
) EmitString(IN nam
: ARRAY OF CHAR), NEW;
619 PROCEDURE (et
: Emiter
) EmitScopeName(asbname
: CharOpen
; nsname
: CharOpen
), NEW;
623 scopeNm
:= ST
.StrCat(ST
.ToChrOpen("["),asbname
);
624 scopeNm
:= ST
.StrCatChr(scopeNm
,"]");
625 IF nsname^
# MS
.NULLSPACE
THEN
626 scopeNm
:= ST
.StrCat(scopeNm
,nsname
);
628 et
.EmitString(scopeNm
);
632 PROCEDURE (et
: Emiter
) EmitHeader(), NEW;
634 et
.Write4B(RTS
.loInt(magic
));
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? *)
642 PROCEDURE (et
: Emiter
) EmitVersion(), NEW;
646 IF et
.version
# NIL THEN
647 (* pack major and minor into a longint *)
649 et
.Write4B(et
.version
[MS
.Major
]);
650 et
.Write4B(et
.version
[MS
.Minor
]);
651 (* pack build and revision into a longint *)
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
658 FOR i
:= 0 TO 7 DO et
.Write(et
.token
[i
]); END;
666 PROCEDURE (et
: Emiter
) DirectImports(), NEW;
671 IF et
.ns
.HasForeignSpaces() THEN
673 nstv
.Initialize(et
.ns
.GetForeignSpaces());
674 fns
:= nstv
.GetNextNamespace();
676 (* assigns import modules ordinal *)
677 et
.AddToImpolist(fns
);
678 fns
:= nstv
.GetNextNamespace();
684 PROCEDURE (et
: Emiter
) EmitImports(), NEW;
694 WHILE indx
< et
.impo
.tide
DO
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
);
707 et
.EmitKey(0); (* key is zero for foreigns *)
713 PROCEDURE (et
: Emiter
) AddToWorklist(typ
: MS
.Type
), NEW;
715 typ
.SetTypeOrd(et
.oNxt
); INC(et
.oNxt
);
716 AppendType(et
.work
, typ
);
720 PROCEDURE (et
: Emiter
) EmitTypeOrd(t
: MS
.Type
), NEW;
722 IF ~t
.Dumped() THEN et
.AddToWorklist(t
); END;
723 et
.WriteOrd(t
.GetTypeOrd());
727 PROCEDURE (et
: Emiter
) EmitLocalTypeName(typ
: MS
.Type
), NEW;
731 typ
.SetInHierarchy();
732 tname
:= et
.MakeFullTypeName(typ
);
734 et
.EmitName(tname
, pubMode
);
736 END EmitLocalTypeName
;
739 PROCEDURE (et
: Emiter
) EmitLocalTypes(), NEW;
748 NEW(tv
); tv
.Initialize(et
.ns
.GetTypes());
749 t
:= tv
.GetNextType();
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
);
757 (* a gpcp module main type, don't emit this type *)
761 et
.EmitLocalTypeName(t
);
764 t
:= tv
.GetNextType();
769 PROCEDURE (et
: Emiter
) EmitTypes(), NEW;
775 PROCEDURE (et
: Emiter
) EmitTypeHeader(t
: MS
.Type
), NEW;
778 et
.WriteOrd(t
.GetTypeOrd());
779 IF et
.IsTypeForeign(t
) & ~t
.IsAnonymous() THEN
781 et
.WriteOrd(t
.GetNamespace().GetModuleOrd());
782 et
.EmitName(MakeTypeName(t
), pubMode
);
787 PROCEDURE (et
: Emiter
) EmitNamedType(t
: MS
.Type
), NEW;
789 et
.EmitTypeHeader(t
);
793 PROCEDURE (et
: Emiter
) EmitArrayType(t
: MS
.ArrayType
), NEW;
798 et
.EmitTypeHeader(t
);
800 et
.EmitTypeOrd(t
.GetElement());
801 len
:= t
.GetLength();
812 PROCEDURE (et
: Emiter
) EmitPointerType(t
: MS
.PointerType
), NEW;
816 IF t
.IsDelegate() THEN
817 tgt
:= t
.GetTarget();
818 WITH tgt
: MS
.DelegType
DO
819 tgt
.SetTypeOrd(t
.GetTypeOrd());
820 et
.EmitDelegate(tgt
);
827 et
.EmitTypeHeader(t
);
829 tgt
:= t
.GetTarget();
830 IF t
.IsInHierarchy() THEN
831 tgt
.SetInHierarchy();
839 PROCEDURE (et
: Emiter
) EmitMethodAttribute(m
: MS
.Method
), NEW;
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
;
854 et
.Write(ORD(mthAtt
));
855 END EmitMethodAttribute
;
858 PROCEDURE (et
: Emiter
) EmitReceiverInfo (m
: MS
.Method
), NEW;
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 *)
866 et
.Write(val
); (* value par mode for obj ref type in dll's sym *)
868 et
.EmitTypeOrd(rcvr
);
869 END EmitReceiverInfo
;
872 PROCEDURE (et
: Emiter
)EmitAnonymousArrayPointerType(t
: MS
.PointerType
): MS
.PointerType
, NEW;
874 ptype
: MS
.PointerType
;
878 tgt
:= t
.GetTarget();
879 WITH tgt
: MS
.ArrayType
DO
880 ptype
:= tgt
.GetAnonymousPointerType();
882 ptype
:= MS
.MakeAnonymousPointerType(tgt
);
888 et
.EmitTypeOrd(ptype
);
890 END EmitAnonymousArrayPointerType
;
893 PROCEDURE (et
: Emiter
) EmitFormals(m
: MS
.Method
), NEW;
897 formals
: MS
.FormalList
;
900 dmyPType
: MS
.PointerType
;
902 WITH m
: MS
.Function
DO
903 rtype
:= m
.GetReturnType();
905 et
.EmitTypeOrd(rtype
);
909 formals
:= m
.GetFormals();
910 IF formals
.Length() # 0 THEN
911 NEW(tv
); tv
.Initialize(formals
);
912 f
:= tv
.GetNextFormal();
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
);
922 et
.EmitTypeOrd(ftype
);
925 et
.EmitTypeOrd(ftype
);
928 f
:= tv
.GetNextFormal();
935 PROCEDURE RequireInvokeName(mth
: MS
.Method
): BOOLEAN;
937 IF mth
.IsConstructor() THEN
938 (* constructors always require invoke name *)
941 IF MS
.WithoutMethodNameMangling() THEN
944 RETURN mth
.IsOverload();
947 END RequireInvokeName
;
950 PROCEDURE (et
: Emiter
) EmitVirtMethods(t
: MS
.Type
), NEW;
957 NEW(tv
); tv
.Initialize(t
.GetVirtualMethods());
958 m
:= tv
.GetNextMethod();
960 IF m
.IsExported() THEN
961 mname
:= m
.GetName();
964 IF m
.IsProtected() THEN
967 et
.EmitName(mname
, vMod
);
968 et
.EmitMethodAttribute(m
);
969 et
.EmitReceiverInfo(m
);
970 IF RequireInvokeName(m
) THEN
971 et
.EmitString(m
.GetInvokeName());
975 m
:= tv
.GetNextMethod();
980 PROCEDURE (et
: Emiter
) EmitImplInterfaces(t
: MS
.Type
), NEW;
981 (* [iFcSy {basSy TypeOrd}]
988 NEW(tv
); tv
.Initialize(t
.GetInterfaces());
989 it
:= tv
.GetNextType();
991 IF it
.IsExported() THEN
994 IF t
.IsInterface() THEN
995 (* interface (t) inherits other interface (it) *)
996 it
.SetInHierarchy(); (* to force emiting of parent interface (it) methods *)
999 it
:= tv
.GetNextType();
1001 END EmitImplInterfaces
;
1004 PROCEDURE (et
: Emiter
) EmitInterfaceType(t
: MS
.IntfcType
), NEW;
1010 et
.EmitTypeHeader(t
);
1014 base
:= t
.GetBaseType();
1017 et
.EmitTypeOrd(base
);
1020 IF t
.HasImplInterfaces() THEN
1021 et
.EmitImplInterfaces(t
);
1024 IF t
.HasVirtualMethods() THEN
1025 et
.EmitVirtMethods(t
);
1028 END EmitInterfaceType
;
1031 PROCEDURE (et
: Emiter
)EmitFields(t
: MS
.Type
), NEW;
1034 flist
: MS
.OrderList
;
1038 dmyPType
: MS
.PointerType
;
1040 flist
:= t
.GetInstanceFields();
1041 IF flist
= NIL THEN RETURN END;
1042 NEW(tv
); tv
.Initialize(flist
);
1043 f
:= tv
.GetNextField();
1045 IF f
.IsExported() THEN
1047 IF f
.IsProtected() THEN
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
);
1057 et
.EmitTypeOrd(ftype
);
1060 et
.EmitTypeOrd(ftype
);
1063 f
:= tv
.GetNextField();
1068 PROCEDURE (et
: Emiter
) EmitEventFields(t
: MS
.Type
), NEW;
1071 elist
: MS
.OrderList
;
1078 NEW(tv
); tv
.Initialize(t
.GetEventList());
1079 e
:= tv
.GetNextEvent();
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();
1085 END EmitEventFields
;
1088 PROCEDURE (et
: Emiter
) EmitVariables(t
: MS
.Type
), NEW;
1091 flist
: MS
.OrderList
;
1095 dmyPType
: MS
.PointerType
;
1097 flist
:= t
.GetStaticFields();
1098 IF flist
= NIL THEN RETURN END;
1099 NEW(tv
); tv
.Initialize(flist
);
1100 f
:= tv
.GetNextField();
1102 IF f
.IsExported() THEN
1105 IF f
.IsProtected() THEN
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
);
1115 et
.EmitTypeOrd(ftype
);
1118 et
.EmitTypeOrd(ftype
);
1121 f
:= tv
.GetNextField();
1126 PROCEDURE (et
: Emiter
) EmitValue(lit
: MS
.Literal
), NEW;
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());
1143 PROCEDURE (et
: Emiter
) EmitConstants(t
: MS
.Type
), NEW;
1149 NEW(tv
); tv
.Initialize(t
.GetConstants());
1150 c
:= tv
.GetNextConstant();
1152 IF c
.IsExported() THEN
1155 IF c
.IsProtected() THEN
1158 et
.EmitName(c
.GetName(), vMod
);
1159 et
.EmitValue(c
.GetValue());
1161 c
:= tv
.GetNextConstant();
1166 PROCEDURE (et
: Emiter
) EmitStaticMethods(t
: MS
.Type
), NEW;
1173 NEW(tv
); tv
.Initialize(t
.GetStaticMethods());
1174 m
:= tv
.GetNextMethod();
1176 IF (m
.GetDeclaringType() = et
.maintyp
) & (m
.IsConstructor()) THEN
1177 (* don't emit any maintyp's constructor for a GPCP module *)
1179 IF m
.IsExported() THEN
1180 mname
:= m
.GetName();
1181 IF mname^
# "Main" THEN
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;
1192 m
:= tv
.GetNextMethod();
1194 END EmitStaticMethods
;
1197 PROCEDURE (et
: Emiter
) EmitStrucType(t
: MS
.ValueType
), NEW;
1199 ** Record = TypeHeader recSy recAtt [truSy | falSy | <others>]
1200 * [basSy TypeOrd] [iFcSy {basSy TypeOrd}]
1201 ** {Name TypeOrd} {Method} {Statics} endRc.
1209 IF t
.IsAbstract() THEN
1211 ELSIF t
.IsExtensible() THEN
1214 IF ~t
.HasNoArgConstructor() THEN INC(recAtt
, nnarg
); END;
1215 IF t
.IsValueType() THEN INC(recAtt
, valTp
); END;
1216 et
.EmitTypeHeader(t
);
1220 base
:= t
.GetBaseType();
1221 IF (base
# NIL) & (base
# MS
.baseTypeArray
[anyRec
]) THEN (* <== *)
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
);
1234 (* request by Diane, base type is class, rather than record *)
1235 et
.EmitTypeOrd(base
);
1237 ASSERT(base
.GetTypeOrd() = anyRec
);
1240 (* no base type declared, so use ANYREC as its base type *)
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;
1257 PROCEDURE (et
: Emiter
) EmitEnumType(t
: MS
.EnumType
), NEW;
1259 et
.EmitTypeHeader(t
);
1261 et
.EmitConstants(t
);
1266 PROCEDURE (et
: Emiter
) EmitDelegate(t
: MS
.DelegType
), NEW;
1270 et
.EmitTypeHeader(t
);
1271 IF t
.IsMulticast() THEN
1276 imth
:= t
.GetInvokeMethod();
1277 et
.EmitFormals(imth
);
1281 PROCEDURE (et
: Emiter
) EmitTypeList(), NEW;
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
);
1305 et
.EmitNamedType(type
);
1307 | tgt
: MS
.ArrayType
DO
1308 et
.EmitPointerType(type
);
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
);
1326 et
.EmitNamedType(type
);
1332 | type
: MS
.NamedType
DO
1333 et
.EmitNamedType(type
);
1342 PROCEDURE (et
: Emiter
) EmitModule(), NEW;
1345 * Header [String (falSy | truSy | <others>)]
1346 * {Import | Constant | Variable | Type | Procedure | Method} TypeList.
1347 * Header = magic modSy Name.
1350 (* Walk through all types to gather info about import modules *)
1354 IF et
.maintyp
# NIL THEN
1355 IF et
.maintyp
.HasStaticFields() THEN
1356 et
.EmitVariables(et
.maintyp
);
1358 IF et
.maintyp
.HasStaticMethods() THEN
1359 et
.EmitStaticMethods(et
.maintyp
);
1365 (* Now really emit type info *)
1371 IF et
.maintyp
# NIL THEN
1372 IF et
.maintyp
.HasConstants() THEN
1373 et
.EmitConstants(et
.maintyp
);
1375 IF et
.maintyp
.HasStaticFields() THEN
1376 et
.EmitVariables(et
.maintyp
);
1378 IF et
.maintyp
.HasStaticMethods() THEN
1379 et
.EmitStaticMethods(et
.maintyp
);
1387 PROCEDURE EmitSymbolFiles
*(asb
: MS
.Assembly
);
1392 onewordname
: BOOLEAN;
1393 samewordname
: BOOLEAN;
1394 inclwordname
: BOOLEAN;
1396 NEW(tv
); tv
.Initialize(asb
.GetNamespaces());
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();
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
;
1419 GF
.CloseFile(et
.file
);
1423 IF ~onewordname
& samewordname
THEN
1424 (* cannot be null namespace here *)
1425 et
.mnameKind
:= MultipleWord
;
1427 et
.mnameKind
:= DifferentWord
;
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
;
1438 GF
.CloseFile(et
.file
);
1440 et
.ns
:= tv
.GetNextNamespace();
1443 et
.nsname
:= et
.ns
.GetName();
1444 onewordname
:= (ST
.StrChr(et
.nsname
,'
.'
) = ST
.NotExist
);
1445 samewordname
:= (et
.asbname^
= ST
.StrSubChr(et
.nsname
,'
.'
,'_'
)^
);
1450 END EmitSymbolFiles
;