1 (* ============================================================ *)
2 (* PeUtil is the module which writes PE files using the *)
3 (* managed interface. *)
4 (* Copyright (c) John Gough 1999, 2002. *)
5 (* Copyright (c) Queensland University of Technology 2002-2006 *)
6 (* This is the PERWAPI-based prototype, March 2005 *)
7 (* previous versions used the PE-file <writer> PEAPI. *)
8 (* ============================================================ *)
29 Api
:= "[QUT.PERWAPI]QUT.PERWAPI",
33 Sys
:= "[mscorlib]System";
35 (* ============================================================ *)
39 * (* various ILASM-specific runtime name strings *)
40 * initPrefix
= "instance void ";
41 * initSuffix
= ".ctor() ";
42 * managedStr
= "il managed";
43 * specialStr
= "public specialname rtspecialname ";
44 * cctorStr
= "static void .cctor() ";
45 * objectInit
= "instance void $o::.ctor() ";
48 * catchStr
= " catch [mscorlib]System.Exception";
51 (* ============================================================ *)
52 (* ============================================================ *)
54 TYPE PeFile
* = POINTER TO RECORD (Mu
.MsilFile
)
55 (* Fields inherited from MsilFile *
56 * srcS* : LitValue.CharOpen; (* source file name *)
57 * outN
* : LitValue
.CharOpen
; (* output file name *)
60 peFl
: Api
.PEFile
; (* Includes AssemblyDef *)
61 clsS
: Api
.ClassDef
; (* Dummy static ClassDef *)
62 clsD
: Api
.ClassDef
; (* The current ClassDef *)
64 nmSp
: RTS
.NativeString
;
66 * Friendly access for system classes.
68 rts
: Api
.AssemblyRef
; (* "[RTS]" *)
69 cprts
: Api
.ClassRef
; (* "[RTS]CP_rts" *)
70 progArgs
: Api
.ClassRef
; (* "[RTS]ProgArgs" *)
73 (* ============================================================ *)
75 TYPE PProcInfo
= POINTER TO RECORD
77 code
: Api
.CILInstructions
;
81 (* ============================================================ *)
83 TYPE PeLab
= POINTER TO RECORD (Mu
.Label
)
87 TYPE TypArr
= POINTER TO ARRAY OF Api
.Type
;
89 (* ============================================================ *)
94 boxedObj
: Lv
.CharOpen
;
96 (* ============================================================ *)
98 VAR ctAtt
, (* public + special + RTspecial *)
99 psAtt
, (* public + static *)
100 rmAtt
, (* runtime managed *)
101 ilAtt
: INTEGER; (* cil managed *)
103 VAR xhrCl
: Api
.ClassRef
; (* the [RTS]XHR class reference *)
104 voidD
: Api
.Type
; (* Api.PrimitiveType.Void *)
105 objtD
: Api
.Type
; (* Api.PrimitiveType.Object *)
106 strgD
: Api
.Type
; (* Api.PrimitiveType.String *)
107 charD
: Api
.Type
; (* Api.PrimitiveType.Char *)
108 charA
: Api
.Type
; (* Api.PrimitiveType.Char[] *)
109 int4D
: Api
.Type
; (* Api.PrimitiveType.Int32 *)
110 int8D
: Api
.Type
; (* Api.PrimitiveType.Int64 *)
111 flt4D
: Api
.Type
; (* Api.PrimitiveType.Float32 *)
112 flt8D
: Api
.Type
; (* Api.PrimitiveType.Float64 *)
113 nIntD
: Api
.Type
; (* Api.PrimitiveType.NativeInt *)
115 VAR vfldS
: RTS
.NativeString
; (* "v$" *)
116 copyS
: RTS
.NativeString
; (* "copy" *)
117 ctorS
: RTS
.NativeString
; (* ".ctor" *)
118 invkS
: RTS
.NativeString
; (* Invoke *)
120 VAR defSrc
: Api
.SourceFile
;
122 VAR rHelper
: ARRAY Mu
.rtsLen
OF Api
.MethodRef
;
123 mathCls
: Api
.ClassRef
;
124 envrCls
: Api
.ClassRef
;
125 excpCls
: Api
.ClassRef
;
126 rtTpHdl
: Api
.ClassRef
;
127 loadTyp
: Api
.MethodRef
;
128 newObjt
: Api
.MethodRef
;
129 multiCD
: Api
.ClassRef
; (* System.MulticastDelegate *)
130 delegat
: Api
.ClassRef
; (* System.Delegate *)
131 combine
: Api
.MethodRef
; (* System.Delegate::Combine *)
132 remove
: Api
.MethodRef
; (* System.Delegate::Remove *)
133 corlib
: Api
.AssemblyRef
; (* [mscorlib] *)
135 (* ============================================================ *)
136 (* Data Structure for tgXtn field of BlkId descriptors *)
137 (* ============================================================ *)
139 TYPE BlkXtn
= POINTER TO RECORD
140 asmD
: Api
.AssemblyRef
; (* This AssemblyRef *)
141 dscD
: Api
.Class
; (* Dummy Static Class *)
144 (* ============================================================ *)
145 (* Data Structure for Switch Statement Encoding *)
146 (* ============================================================ *)
149 list
: POINTER TO ARRAY OF Api
.CILLabel
;
155 (* ============================================================ *)
156 (* Data Structure for tgXtn field of procedure types *)
157 (* ============================================================ *)
159 TYPE DelXtn
= POINTER TO RECORD
160 clsD
: Api
.Class
; (* Implementing class *)
161 newD
: Api
.Method
; (* Constructor method *)
162 invD
: Api
.Method
; (* The Invoke method *)
165 (* ============================================================ *)
166 (* Data Structure for tgXtn field of event variables *)
167 (* ============================================================ *)
169 TYPE EvtXtn
= POINTER TO RECORD
170 fldD
: Api
.Field
; (* Field descriptor *)
171 addD
: Api
.Method
; (* add_<field> method *)
172 remD
: Api
.Method
; (* rem_<field> method *)
175 (* ============================================================ *)
176 (* Data Structure for tgXtn field of Record types *)
177 (* ============================================================ *)
179 TYPE RecXtn
= POINTER TO RECORD
187 (* ============================================================ *)
188 (* Constructor Method *)
189 (* ============================================================ *)
191 PROCEDURE newPeFile
*(IN nam
: ARRAY OF CHAR; isDll
: BOOLEAN) : PeFile
;
194 (* ------------------------------------------------------- *)
195 PROCEDURE file(IN f
,a
: ARRAY OF CHAR; d
: BOOLEAN) : Api
.PEFile
;
196 VAR pef
: Api
.PEFile
;
198 pef
:= Api
.PEFile
.init(MKSTR(f
), MKSTR(a
));
200 IF CSt
.binDir
# "" THEN
201 pef
.SetOutputDirectory(MKSTR(CSt
.binDir
));
207 (* ------------------------------------------------------- *)
211 * f.peFl := file(nam, isDll);
214 f
.outN
:= BOX(nam
+ ".DLL");
216 f
.outN
:= BOX(nam
+ ".EXE");
218 (* -- start replacement -- *)
219 f
.peFl
:= file(f
.outN
, nam
, isDll
);
220 (* --- end replacement --- *)
222 * Initialize local variables holding common attributes.
224 ctAtt
:= Api
.MethAttr
.Public
+ Api
.MethAttr
.SpecialRTSpecialName
;
225 psAtt
:= Api
.MethAttr
.Public
+ Api
.MethAttr
.Static
;
226 ilAtt
:= Api
.ImplAttr
.IL
;
227 rmAtt
:= Api
.ImplAttr
.Runtime
;
229 * Initialize local variables holding primitive type-enums.
231 voidD
:= Api
.PrimitiveType
.Void
;
232 objtD
:= Api
.PrimitiveType
.Object
;
233 strgD
:= Api
.PrimitiveType
.String
;
234 int4D
:= Api
.PrimitiveType
.Int32
;
235 int8D
:= Api
.PrimitiveType
.Int64
;
236 flt4D
:= Api
.PrimitiveType
.Float32
;
237 flt8D
:= Api
.PrimitiveType
.Float64
;
238 charD
:= Api
.PrimitiveType
.Char
;
239 charA
:= Api
.ZeroBasedArray
.init(Api
.PrimitiveType
.Char
);
240 nIntD
:= Api
.PrimitiveType
.IntPtr
;
242 f
.peFl
.SetNetVersion(Api
.NetVersion
.Version2
);
244 (*ver := f.peFl.GetNetVersion();*)
249 (* ============================================================ *)
251 PROCEDURE (t
: PeFile
)fileOk
*() : BOOLEAN;
256 (* ============================================================ *)
258 PROCEDURE (os
: PeFile
)MkNewProcInfo
*(proc
: Sy
.Scope
);
263 Mu
.InitProcInfo(os
.proc
, proc
);
266 (* ============================================================ *)
268 PROCEDURE (os
: PeFile
)newLabel
*() : Mu
.Label
;
272 label
.labl
:= os
.pePI
.code
.NewLabel();
276 (* ============================================================ *)
277 (* Various utilities *)
278 (* ============================================================ *)
280 PROCEDURE^
(os
: PeFile
)CallCombine(typ
: Sy
.Type
; add
: BOOLEAN),NEW;
281 PROCEDURE^
(os
: PeFile
)CodeLb
*(code
: INTEGER; labl
: Mu
.Label
);
282 PROCEDURE^
(os
: PeFile
)DefLabC
*(l
: Mu
.Label
; IN c
: ARRAY OF CHAR);
283 PROCEDURE^
(os
: PeFile
)Locals(),NEW;
285 PROCEDURE^
MkMthDef(os
: PeFile
;
289 str
: RTS
.NativeString
) : Api
.MethodDef
;
291 PROCEDURE^
MkMthRef(os
: PeFile
;
294 str
: RTS
.NativeString
) : Api
.MethodRef
;
296 PROCEDURE^
(os
: PeFile
)mth(pId
: Id
.Procs
) : Api
.Method
,NEW;
297 PROCEDURE^
(os
: PeFile
)fld(fId
: Id
.AbVar
) : Api
.Field
,NEW;
298 PROCEDURE^
(os
: PeFile
)add(fId
: Id
.AbVar
) : Api
.Method
,NEW;
299 PROCEDURE^
(os
: PeFile
)rem(fId
: Id
.AbVar
) : Api
.Method
,NEW;
300 PROCEDURE^
(os
: PeFile
)asm(bId
: Id
.BlkId
) : Api
.AssemblyRef
,NEW;
301 PROCEDURE^
(os
: PeFile
)dsc(bId
: Id
.BlkId
) : Api
.Class
,NEW;
302 PROCEDURE^
(os
: PeFile
)cls(rTy
: Ty
.Record
) : Api
.Class
,NEW;
303 PROCEDURE^
(os
: PeFile
)new(rTy
: Ty
.Record
) : Api
.Method
,NEW;
304 PROCEDURE^
(os
: PeFile
)cpy(rTy
: Ty
.Record
) : Api
.Method
,NEW;
305 PROCEDURE^
(os
: PeFile
)typ(tTy
: Sy
.Type
) : Api
.Type
,NEW;
306 PROCEDURE^
(os
: PeFile
)vDl(rTy
: Ty
.Record
) : Api
.Field
,NEW;
307 PROCEDURE^
(os
: PeFile
)dxt(pTy
: Ty
.Procedure
) : DelXtn
,NEW;
308 PROCEDURE^
(os
: PeFile
)mcd() : Api
.ClassRef
,NEW;
309 PROCEDURE^
(os
: PeFile
)rmv() : Api
.MethodRef
,NEW;
310 PROCEDURE^
(os
: PeFile
)cmb() : Api
.MethodRef
,NEW;
312 * PROCEDURE^ box(os : PeFile; rTy : Ty.Record) : Api.Class;
314 (* ============================================================ *)
315 (* Private Methods *)
316 (* ============================================================ *)
318 PROCEDURE boxedName(typ
: Ty
.Record
) : RTS
.NativeString
;
320 ASSERT(typ
.xName
# NIL);
321 RETURN MKSTR(boxedObj^
+ typ
.xName^
);
324 (* ============================================================ *)
326 PROCEDURE nms(idD
: Sy
.Idnt
) : RTS
.NativeString
;
328 RETURN MKSTR(Sy
.getName
.ChPtr(idD
)^
);
331 (* ============================================================ *)
333 PROCEDURE toTypeAttr(attr
: SET) : INTEGER;
334 VAR result
: INTEGER;
336 CASE ORD(attr
* {0 .. 3}) OF
337 |
ORD(Asm
.att_public
) : result
:= Api
.TypeAttr
.Public
;
338 |
ORD(Asm
.att_empty
) : result
:= Api
.TypeAttr
.Private
;
340 IF attr
* Asm
.att_sealed
# {} THEN
341 INC(result
, Api
.TypeAttr
.Sealed
);
343 IF attr
* Asm
.att_abstract
# {} THEN
344 INC(result
, Api
.TypeAttr
.Abstract
);
346 IF attr
* Asm
.att_interface
# {} THEN
347 INC(result
, Api
.TypeAttr
.Interface
+ Api
.TypeAttr
.Abstract
);
350 * what are "Import, AutoClass, UnicodeClass, *SpecialName" ?
356 (* ------------------------------------------------ *)
357 (* New code for PERWAPI *)
358 (* ------------------------------------------------ *)
360 PROCEDURE getOrAddClass(mod
: Api
.ReferenceScope
;
361 nms
: RTS
.NativeString
;
362 nam
: RTS
.NativeString
) : Api
.ClassRef
;
365 cls
:= mod
.GetClass(nms
, nam
);
366 IF cls
= NIL THEN cls
:= mod
.AddClass(nms
, nam
) END;
367 RETURN cls(Api
.ClassRef
);
370 PROCEDURE getOrAddValueClass(mod
: Api
.ReferenceScope
;
371 nms
: RTS
.NativeString
;
372 nam
: RTS
.NativeString
) : Api
.ClassRef
;
375 cls
:= mod
.GetClass(nms
, nam
);
376 IF cls
= NIL THEN cls
:= mod
.AddValueClass(nms
, nam
) END;
377 RETURN cls(Api
.ClassRef
);
378 END getOrAddValueClass
;
380 PROCEDURE getOrAddMethod(cls
: Api
.ClassRef
;
381 nam
: RTS
.NativeString
;
383 prs
: TypArr
) : Api
.MethodRef
;
384 VAR mth
: Api
.Method
;
386 mth
:= cls
.GetMethod(nam
, prs
);
387 IF mth
= NIL THEN mth
:= cls
.AddMethod(nam
, ret
, prs
) END;
388 RETURN mth(Api
.MethodRef
);
391 PROCEDURE getOrAddField(cls
: Api
.ClassRef
;
392 nam
: RTS
.NativeString
;
393 typ
: Api
.Type
) : Api
.FieldRef
;
394 VAR fld
: Api
.FieldRef
;
396 fld
:= cls
.GetField(nam
);
397 IF fld
= NIL THEN fld
:= cls
.AddField(nam
, typ
) END;
398 RETURN fld(Api
.FieldRef
);
401 (* ------------------------------------------------ *)
403 PROCEDURE toMethAttr(attr
: SET) : INTEGER;
404 VAR result
: INTEGER;
406 CASE ORD(attr
* {0 .. 3}) OF
407 |
ORD(Asm
.att_assembly
) : result
:= Api
.MethAttr
.Assembly
;
408 |
ORD(Asm
.att_public
) : result
:= Api
.MethAttr
.Public
;
409 |
ORD(Asm
.att_private
) : result
:= Api
.MethAttr
.Private
;
410 |
ORD(Asm
.att_protected
) : result
:= Api
.MethAttr
.Family
;
412 IF 5 IN attr
THEN INC(result
, Api
.MethAttr
.Static
) END;
413 IF 6 IN attr
THEN INC(result
, Api
.MethAttr
.Final
) END;
414 IF 8 IN attr
THEN INC(result
, Api
.MethAttr
.Abstract
) END;
415 IF 9 IN attr
THEN INC(result
, Api
.MethAttr
.NewSlot
) END;
416 IF 13 IN attr
THEN INC(result
, Api
.MethAttr
.Virtual
) END;
420 (* ------------------------------------------------ *)
422 PROCEDURE toFieldAttr(attr
: SET) : INTEGER;
423 VAR result
: INTEGER;
425 CASE ORD(attr
* {0 .. 3}) OF
426 |
ORD(Asm
.att_empty
) : result
:= Api
.FieldAttr
.Default
;
427 |
ORD(Asm
.att_assembly
) : result
:= Api
.FieldAttr
.Assembly
;
428 |
ORD(Asm
.att_public
) : result
:= Api
.FieldAttr
.Public
;
429 |
ORD(Asm
.att_private
) : result
:= Api
.FieldAttr
.Private
;
430 |
ORD(Asm
.att_protected
) : result
:= Api
.FieldAttr
.Family
;
432 IF 5 IN attr
THEN INC(result
, Api
.FieldAttr
.Static
) END;
433 (* what about Initonly? *)
437 (* ------------------------------------------------ *)
439 PROCEDURE (os
: PeFile
)MkCodeBuffer(),NEW;
441 ASSERT((defSrc
# NIL) & (os
.pePI
.mthD
# NIL));
442 os
.pePI
.code
:= os
.pePI
.mthD
.CreateCodeBuffer();
443 os
.pePI
.code
.OpenScope();
444 os
.pePI
.code
.set_DefaultSourceFile(defSrc
);
447 (* ============================================================ *)
448 (* Exported Methods *)
449 (* ============================================================ *)
451 PROCEDURE (os
: PeFile
)MethodDecl
*(attr
: SET; proc
: Id
.Procs
);
452 VAR prcT
: Ty
.Procedure
; (* NOT NEEDED? *)
453 prcD
: Api
.MethodDef
;
456 * Set the various attributes
458 prcD
:= os
.mth(proc
)(Api
.MethodDef
);
459 prcD
.AddMethAttribute(toMethAttr(attr
));
460 prcD
.AddImplAttribute(ilAtt
);
461 os
.pePI
.mthD
:= prcD
;
462 IF attr
* Asm
.att_abstract
= {} THEN os
.MkCodeBuffer() END;
465 (* -------------------------------------------- *)
467 PROCEDURE (os
: PeFile
)DoExtern(blk
: Id
.BlkId
),NEW;
469 * Add references to all imported assemblies.
471 VAR asmRef
: Api
.AssemblyRef
;
473 (* ----------------------------------------- *)
474 PROCEDURE AsmName(bk
: Id
.BlkId
) : Lv
.CharOpen
;
480 IF Sy
.isFn
IN bk
.xAttr
THEN
482 FOR ix
:= LEN(bk
.scopeNm
) - 1 TO 1 BY
-1 DO
483 IF bk
.scopeNm
[ix
] = "]" THEN ln
:= ix
END;
485 IF (ln
= 0 ) OR (bk
.scopeNm
[0] # '
['
) THEN
486 RTS
.Throw("bad extern name "+bk
.scopeNm^
) END;
488 FOR ix
:= 1 TO ln
-1 DO cp
[ix
-1] := bk
.scopeNm
[ix
] END;
495 (* ----------------------------------------- *)
496 PROCEDURE MkBytes(t1
, t2
: INTEGER) : POINTER TO ARRAY OF UBYTE
;
498 tok
: POINTER TO ARRAY OF UBYTE
;
499 BEGIN [UNCHECKED_ARITHMETIC
]
501 FOR bIx
:= 3 TO 0 BY
-1 DO
502 tok
[bIx
] := USHORT(t1
MOD 256);
505 FOR bIx
:= 7 TO 4 BY
-1 DO
506 tok
[bIx
] := USHORT(t2
MOD 256);
511 (* ----------------------------------------- *)
513 IF blk
.xName
= NIL THEN Mu
.MkBlkName(blk
) END;
514 asmRef
:= os
.peFl
.MakeExternAssembly(MKSTR(AsmName(blk
)^
));
517 blkXtn
.asmD
:= asmRef
;
518 blkXtn
.dscD
:= getOrAddClass(asmRef
,
521 IF blk
.verNm
# NIL THEN
522 asmRef
.AddVersionInfo(blk
.verNm
[0], blk
.verNm
[1],
523 blk
.verNm
[2], blk
.verNm
[3]);
524 IF (blk
.verNm
[4] # 0) OR (blk
.verNm
[5] # 0) THEN
525 asmRef
.AddKeyToken(MkBytes(blk
.verNm
[4], blk
.verNm
[5]));
530 (* ============================================================ *)
532 PROCEDURE (os
: PeFile
)DoRtsMod(blk
: Id
.BlkId
),NEW;
534 * Add references to all imported assemblies.
538 IF blk
.xName
= NIL THEN Mu
.MkBlkName(blk
) END;
541 blkD
.dscD
:= os
.rts
.AddClass("", MKSTR(blk
.clsNm^
));
545 (* ============================================================ *)
547 PROCEDURE (os
: PeFile
)CheckNestedClass
*(typ
: Ty
.Record
;
558 * Find last occurrence of '$', except at index 0
560 * We seek the last occurrence because this method might
561 * be called recursively for a deeply nested class A$B$C.
563 len
:= LEN(str$
); (* LEN(x$) doen't count nul, therefore str[len] = 0X *)
564 FOR idx
:= len
TO 1 BY
-1 DO
565 IF str
[idx
] = '$'
THEN (* a nested class *)
566 str
[idx
] := 0X
; (* terminate the string early *)
567 hsh
:= NameHash
.enterStr(str
);
568 tId
:= Sy
.bind(hsh
, scp
);
570 IF (tId
= NIL) OR ~
(tId
IS Id
.TypId
) THEN
572 "Foreign Class <" + str^
+ "> not found in <" + typ
.extrnNm^
+ ">"
575 typ
.encCls
:= tId
.type
.boundRecTp();
576 jdx
:= 0; kdx
:= idx
+1;
577 WHILE kdx
<= len
DO str
[jdx
] := str
[kdx
]; INC(kdx
); INC(jdx
) END;
582 END CheckNestedClass
;
584 (* ============================================================ *)
586 PROCEDURE (os
: PeFile
)ExternList
*();
590 FOR idx
:= 0 TO CSt
.impSeq
.tide
-1 DO
591 blk
:= CSt
.impSeq
.a
[idx
](Id
.BlkId
);
592 IF (Sy
.need
IN blk
.xAttr
) &
593 (blk
.tgXtn
= NIL) THEN
594 IF ~
(Sy
.rtsMd
IN blk
.xAttr
) THEN
603 (* ============================================================ *)
605 PROCEDURE (os
: PeFile
)DefLab
*(l
: Mu
.Label
);
607 os
.pePI
.code
.CodeLabel(l(PeLab
).labl
);
610 (* -------------------------------------------- *)
612 PROCEDURE (os
: PeFile
)DefLabC
*(l
: Mu
.Label
; IN c
: ARRAY OF CHAR);
614 os
.pePI
.code
.CodeLabel(l(PeLab
).labl
);
617 (* ============================================================ *)
619 PROCEDURE (os
: PeFile
)Code
*(code
: INTEGER);
621 os
.pePI
.code
.Inst(Asm
.cd
[code
]);
622 os
.Adjust(Asm
.dl
[code
]);
625 (* -------------------------------------------- *)
627 PROCEDURE (os
: PeFile
)CodeF(code
: INTEGER;
628 fld
: Api
.Field
), NEW;
630 os
.pePI
.code
.FieldInst(Asm
.cd
[code
], fld
);
631 os
.Adjust(Asm
.dl
[code
]);
634 (* -------------------------------------------- *)
636 PROCEDURE (os
: PeFile
)CodeI
*(code
,int
: INTEGER);
638 os
.pePI
.code
.IntInst(Asm
.cd
[code
],int
);
639 os
.Adjust(Asm
.dl
[code
]);
642 (* -------------------------------------------- *)
644 PROCEDURE (os
: PeFile
)CodeT
*(code
: INTEGER; type
: Sy
.Type
);
648 os
.pePI
.code
.TypeInst(Asm
.cd
[code
], xtn
);
649 os
.Adjust(Asm
.dl
[code
]);
652 (* -------------------------------------------- *)
654 PROCEDURE (os
: PeFile
)CodeTn
*(code
: INTEGER; type
: Sy
.Type
);
658 os
.pePI
.code
.TypeInst(Asm
.cd
[code
], xtn
);
659 os
.Adjust(Asm
.dl
[code
]);
662 (* -------------------------------------------- *)
664 PROCEDURE (os
: PeFile
)CodeL
*(code
: INTEGER; long
: LONGINT);
666 ASSERT(code
= Asm
.opc_ldc_i8
);
667 os
.pePI
.code
.ldc_i8(long
);
671 (* -------------------------------------------- *)
673 PROCEDURE (os
: PeFile
)CodeR
*(code
: INTEGER; real
: REAL);
675 IF code
= Asm
.opc_ldc_r8
THEN
676 os
.pePI
.code
.ldc_r8(real
);
677 ELSIF code
= Asm
.opc_ldc_r4
THEN
678 os
.pePI
.code
.ldc_r4(SHORT(real
));
685 (* -------------------------------------------- *)
687 PROCEDURE (os
: PeFile
)CodeLb
*(code
: INTEGER; labl
: Mu
.Label
);
689 os
.pePI
.code
.Branch(Asm
.cd
[code
], labl(PeLab
).labl
);
692 (* ============================================================ *)
694 PROCEDURE (os
: PeFile
)getMethod(s
: INTEGER) : Api
.Method
,NEW;
695 VAR mth
: Api
.MethodRef
;
699 (* ----------------------------------- *)
700 PROCEDURE p1(p
: Api
.Type
) : TypArr
;
707 (* ----------------------------------- *)
708 PROCEDURE p2(p
,q
: Api
.Type
) : TypArr
;
716 (* ----------------------------------- *)
719 * Lazy evaluation of array elements
725 | Mu
.vStr2ChO
: mth
:= cpr
.AddMethod("strToChO",charA
,p1(strgD
));
726 | Mu
.vStr2ChF
: mth
:= cpr
.AddMethod("StrToChF",voidD
,p2(charA
,strgD
));
727 | Mu
.aStrLen
: mth
:= cpr
.AddMethod("chrArrLength",int4D
,p1(charA
));
728 | Mu
.aStrChk
: mth
:= cpr
.AddMethod("ChrArrCheck",voidD
,p1(charA
));
729 | Mu
.aStrLp1
: mth
:= cpr
.AddMethod("chrArrLplus1",int4D
,p1(charA
));
730 | Mu
.aaStrCmp
: mth
:= cpr
.AddMethod("strCmp",int4D
,p2(charA
,charA
));
731 | Mu
.aaStrCopy
: mth
:= cpr
.AddMethod("Stringify",voidD
,p2(charA
,charA
));
732 | Mu
.CpModI
: mth
:= cpr
.AddMethod("CpModI",int4D
,p2(int4D
,int4D
));
733 | Mu
.CpDivI
: mth
:= cpr
.AddMethod("CpDivI",int4D
,p2(int4D
,int4D
));
734 | Mu
.CpModL
: mth
:= cpr
.AddMethod("CpModL",int8D
,p2(int8D
,int8D
));
735 | Mu
.CpDivL
: mth
:= cpr
.AddMethod("CpDivL",int8D
,p2(int8D
,int8D
));
736 | Mu
.caseMesg
: mth
:= cpr
.AddMethod("caseMesg",strgD
,p1(int4D
));
737 | Mu
.withMesg
: mth
:= cpr
.AddMethod("withMesg",strgD
,p1(objtD
));
738 | Mu
.chs2Str
: mth
:= cpr
.AddMethod("mkStr",strgD
,p1(charA
));
739 | Mu
.CPJstrCatAA
: mth
:= cpr
.AddMethod("aaToStr",strgD
,p2(charA
,charA
));
740 | Mu
.CPJstrCatSA
: mth
:= cpr
.AddMethod("saToStr",strgD
,p2(strgD
,charA
));
741 | Mu
.CPJstrCatAS
: mth
:= cpr
.AddMethod("asToStr",strgD
,p2(charA
,strgD
));
742 | Mu
.CPJstrCatSS
: mth
:= cpr
.AddMethod("ssToStr",strgD
,p2(strgD
,strgD
));
744 | Mu
.toUpper
: sys
:= getOrAddClass(corlib
, "System", "Char");
745 mth
:= getOrAddMethod(sys
,"ToUpper",charD
,p1(charD
));
747 | Mu
.sysExit
: IF envrCls
= NIL THEN
749 getOrAddClass(corlib
, "System", "Environment");
751 mth
:= getOrAddMethod(envrCls
,"Exit",voidD
,p1(int4D
));
753 | Mu
.mkExcept
: IF excpCls
= NIL THEN
754 IF CSt
.ntvExc
.tgXtn
= NIL THEN
756 getOrAddClass(corlib
, "System", "Exception");
757 CSt
.ntvExc
.tgXtn
:= excpCls
;
759 excpCls
:= CSt
.ntvExc
.tgXtn(Api
.ClassRef
);
762 sys
:= CSt
.ntvExc
.tgXtn(Api
.ClassRef
);
764 * mth := sys.AddMethod(ctorS,voidD,p1(strgD));
766 mth
:= getOrAddMethod(sys
,ctorS
,voidD
,p1(strgD
));
767 mth
.AddCallConv(Api
.CallConv
.Instance
);
769 | Mu
.getTpM
: IF CSt
.ntvTyp
.tgXtn
= NIL THEN
771 getOrAddClass(corlib
, "System", "Type");
773 sys
:= CSt
.ntvTyp
.tgXtn(Api
.ClassRef
);
774 mth
:= getOrAddMethod(sys
,"GetType",sys
,NIL);
775 mth
.AddCallConv(Api
.CallConv
.Instance
);
777 | Mu
.dFloor
, Mu
.dAbs
, Mu
.fAbs
, Mu
.iAbs
, Mu
.lAbs
:
778 IF mathCls
= NIL THEN
779 mathCls
:= getOrAddClass(corlib
, "System", "Math");
781 rHelper
[Mu
.dFloor
] := getOrAddMethod(mathCls
,"Floor",flt8D
,p1(flt8D
));
782 rHelper
[Mu
.dAbs
] := getOrAddMethod(mathCls
,"Abs",flt8D
,p1(flt8D
));
783 rHelper
[Mu
.fAbs
] := getOrAddMethod(mathCls
,"Abs",flt4D
,p1(flt4D
));
784 rHelper
[Mu
.iAbs
] := getOrAddMethod(mathCls
,"Abs",int4D
,p1(int4D
));
785 rHelper
[Mu
.lAbs
] := getOrAddMethod(mathCls
,"Abs",int8D
,p1(int8D
));
793 (* -------------------------------------------- *)
795 PROCEDURE (os
: PeFile
)StaticCall
*(s
: INTEGER; d
: INTEGER);
796 VAR mth
: Api
.Method
;
798 mth
:= os
.getMethod(s
);
799 os
.pePI
.code
.MethInst(Asm
.cd
[Asm
.opc_call
], mth
);
803 (* -------------------------------------------- *)
805 PROCEDURE (os
: PeFile
)CodeS
*(code
: INTEGER; str
: INTEGER);
806 VAR mth
: Api
.Method
;
808 mth
:= os
.getMethod(str
);
809 os
.pePI
.code
.MethInst(Asm
.cd
[code
], mth
);
812 (* ============================================================ *)
814 PROCEDURE (os
: PeFile
)Try
*();
817 os
.proc
.exLb
:= os
.newLabel();
818 retT
:= os
.proc
.prId
.type
.returnType();
819 IF retT
# NIL THEN os
.proc
.rtLc
:= os
.proc
.newLocal(retT
) END;
820 os
.pePI
.code
.StartBlock();
823 (* -------------------------------------------- *)
825 PROCEDURE (os
: PeFile
)Catch
*(proc
: Id
.Procs
);
827 os
.pePI
.tryB
:= os
.pePI
.code
.EndTryBlock();
828 os
.pePI
.code
.StartBlock();
829 os
.Adjust(1); (* allow for incoming exception reference *)
830 os
.StoreLocal(proc
.except
.varOrd
);
833 (* -------------------------------------------- *)
835 PROCEDURE (os
: PeFile
)CloseCatch
*();
837 IF excpCls
= NIL THEN
838 IF CSt
.ntvExc
.tgXtn
= NIL THEN
839 excpCls
:= getOrAddClass(corlib
, "System", "Exception");
840 CSt
.ntvExc
.tgXtn
:= excpCls
;
842 excpCls
:= CSt
.ntvExc
.tgXtn(Api
.ClassRef
);
845 os
.pePI
.code
.EndCatchBlock(excpCls
, os
.pePI
.tryB
);
848 (* -------------------------------------------- *)
850 PROCEDURE (os
: PeFile
)CopyCall
*(typ
: Ty
.Record
);
852 os
.pePI
.code
.MethInst(Asm
.cd
[Asm
.opc_call
], os
.cpy(typ
));
856 (* -------------------------------------------- *)
858 PROCEDURE (os
: PeFile
)PushStr
*(IN str
: ARRAY OF CHAR);
859 (* Use target quoting conventions for the literal string *)
861 (* os.pePI.code.ldstr(MKSTR(str)); *)
862 os
.pePI
.code
.ldstr(Sys
.String
.init(BOX(str
), 0, LEN(str
) - 1));
866 (* ============================================================ *)
868 PROCEDURE (os
: PeFile
)CallIT
*(code
: INTEGER;
870 type
: Ty
.Procedure
);
871 VAR xtn
: Api
.Method
;
874 os
.pePI
.code
.MethInst(Asm
.cd
[code
], xtn
);
875 os
.Adjust(type
.retN
- type
.argN
);
878 (* ============================================================ *)
880 PROCEDURE (os
: PeFile
)CallCT
*(proc
: Id
.Procs
;
881 type
: Ty
.Procedure
);
882 VAR xtn
: Api
.Method
;
884 ASSERT(proc
.tgXtn
# NIL);
885 xtn
:= proc
.tgXtn(Api
.Method
);
886 os
.pePI
.code
.MethInst(Asm
.cd
[Asm
.opc_newobj
], xtn
);
887 os
.Adjust(-type
.argN
);
890 (* ============================================================ *)
892 PROCEDURE (os
: PeFile
)CallDelegate
*(typ
: Ty
.Procedure
);
893 VAR xtn
: Api
.Method
;
895 ASSERT(typ
.tgXtn
# NIL);
897 * xtn := typ.tgXtn(DelXtn).invD;
899 xtn
:= os
.dxt(typ
).invD
;
900 os
.pePI
.code
.MethInst(Asm
.cd
[Asm
.opc_callvirt
], xtn
);
901 os
.Adjust(-typ
.argN
+ typ
.retN
);
904 (* ============================================================ *)
906 PROCEDURE (os
: PeFile
)PutGetS
*(code
: INTEGER;
909 (* Emit putstatic and getstatic for static field *)
911 os
.pePI
.code
.FieldInst(Asm
.cd
[code
], os
.fld(fId
));
912 os
.Adjust(Asm
.dl
[code
]);
915 (* -------------------------------------------- *)
917 PROCEDURE (os
: PeFile
)GetValObj
*(code
: INTEGER; ptrT
: Ty
.Pointer
);
920 rTp
:= ptrT
.boundRecTp()(Ty
.Record
);
921 os
.pePI
.code
.FieldInst(Asm
.cd
[code
], os
.vDl(rTp
));
922 os
.Adjust(Asm
.dl
[code
]);
925 (* -------------------------------------------- *)
927 PROCEDURE (os
: PeFile
)PutGetXhr
*(code
: INTEGER;
936 recT
:= proc
.xhrType
.boundRecTp()(Ty
.Record
);
937 WHILE recT
.fields
.a
[ix
].hash
# locl
.hash
DO INC(ix
) END;;
938 os
.pePI
.code
.FieldInst(Asm
.cd
[code
], os
.fld(recT
.fields
.a
[ix
](Id
.FldId
)));
941 (* -------------------------------------------- *)
943 PROCEDURE (os
: PeFile
)PutGetF
*(code
: INTEGER;
946 os
.pePI
.code
.FieldInst(Asm
.cd
[code
], os
.fld(fId
));
947 os
.Adjust(Asm
.dl
[code
]);
950 (* ============================================================ *)
951 (* ============================================================ *)
953 PROCEDURE (os
: PeFile
)MkNewRecord
*(typ
: Ty
.Record
);
954 CONST code
= Asm
.opc_newobj
;
955 VAR name
: Lv
.CharOpen
;
958 * We need "newobj instance void <name>::.ctor()"
960 os
.pePI
.code
.MethInst(Asm
.cd
[code
], os
.new(typ
));
964 (* ============================================================ *)
965 (* ============================================================ *)
967 PROCEDURE (os
: PeFile
)MkNewProcVal
*(p
: Sy
.Idnt
; (* src Proc *)
968 t
: Sy
.Type
); (* dst Type *)
969 VAR ctor
: Api
.Method
;
975 * ctor := t.tgXtn(DelXtn).newD;
978 pTyp
:= t(Ty
.Procedure
);
979 ctor
:= os
.dxt(pTyp
).newD
;
981 * We need "ldftn [instance] <retType> <procName>
984 IF p
.bndType
.isInterfaceType() THEN
985 ldfi
:= Asm
.opc_ldvirtftn
;
986 ELSIF p
.mthAtt
* Id
.mask
= Id
.final
THEN
987 ldfi
:= Asm
.opc_ldftn
;
989 ldfi
:= Asm
.opc_ldvirtftn
;
992 ldfi
:= Asm
.opc_ldftn
;
995 * These next are needed for imported events
997 Mu
.MkProcName(proc
, os
);
998 os
.NumberParams(proc
, pTyp
);
1000 * If this will be a virtual method call, then we
1001 * must duplicate the receiver, since the call of
1002 * ldvirtftn uses up one copy.
1004 IF ldfi
= Asm
.opc_ldvirtftn
THEN os
.Code(Asm
.opc_dup
) END;
1005 os
.pePI
.code
.MethInst(Asm
.cd
[ldfi
], os
.mth(proc
));
1008 * Now we need "newobj instance void <name>::.ctor(...)"
1010 os
.pePI
.code
.MethInst(Asm
.cd
[Asm
.opc_newobj
], ctor
);
1014 (* ============================================================ *)
1016 PROCEDURE (os
: PeFile
)CallSuper
*(rTp
: Ty
.Record
;
1020 (* ---------------------------------------- *)
1021 PROCEDURE getSuperCtor(os
: PeFile
;
1023 prc
: Id
.Procs
) : Api
.Method
;
1024 VAR bas
: Ty
.Record
;
1029 bas
:= rTp
.superType();
1032 * This constructor has arguments.
1033 * The super constructor is prc.basCll.sprCtor
1035 pTp
:= prc
.type(Ty
.Procedure
);
1036 IF prc
.tgXtn
= NIL THEN
1038 WITH bcl
: Api
.ClassDef
DO
1039 mth
:= MkMthDef(os
, FALSE
, pTp
, bcl
, ctorS
);
1040 mth(Api
.MethodDef
).AddMethAttribute(ctAtt
);
1041 | bcl
: Api
.ClassRef
DO
1042 mth
:= MkMthRef(os
, pTp
, bcl
, ctorS
);
1044 mth
.AddCallConv(Api
.CallConv
.Instance
);
1048 RETURN prc
.tgXtn(Api
.Method
);
1050 ELSIF (bas
# NIL) & (rTp
.baseTp
# Bi
.anyRec
) THEN
1052 * This is the explicit noarg constructor of the supertype.
1057 * This is System.Object::.ctor()
1062 (* ---------------------------------------- *)
1065 pNm
:= prc
.type(Ty
.Procedure
).formals
.tide
;
1069 spr
:= getSuperCtor(os
, rTp
, prc
);
1070 os
.pePI
.code
.MethInst(Asm
.cd
[Asm
.opc_call
], spr
);
1071 os
.Adjust(-(pNm
+1));
1074 (* ============================================================ *)
1076 PROCEDURE (os
: PeFile
)InitHead
*(rTp
: Ty
.Record
;
1078 VAR mDf
: Api
.MethodDef
;
1081 cDf
:= os
.cls(rTp
)(Api
.ClassDef
);
1084 mDf
:= prc
.tgXtn(Api
.MethodDef
);
1085 mDf
.AddMethAttribute(ctAtt
);
1087 mDf
:= os
.new(rTp
)(Api
.MethodDef
);
1089 os
.pePI
.mthD
:= mDf
;
1091 mDf
.AddCallConv(Api
.CallConv
.Instance
);
1093 * Now we initialize the supertype;
1095 os
.Code(Asm
.opc_ldarg_0
);
1098 (* ============================================================ *)
1100 PROCEDURE (os
: PeFile
)CopyHead
*(typ
: Ty
.Record
);
1101 VAR mDf
: Api
.MethodDef
;
1104 prs
: POINTER TO ARRAY OF Id
.ParId
;
1106 cDf
:= os
.cls(typ
)(Api
.ClassDef
);
1107 mDf
:= os
.cpy(typ
)(Api
.MethodDef
);
1108 mDf
.AddMethAttribute(Api
.MethAttr
.Public
);
1109 mDf
.AddImplAttribute(ilAtt
);
1110 mDf
.AddCallConv(Api
.CallConv
.Instance
);
1111 os
.pePI
.mthD
:= mDf
;
1115 (* ============================================================ *)
1117 PROCEDURE (os
: PeFile
)MarkInterfaces
*(IN seq
: Sy
.TypeSeq
);
1118 VAR index
: INTEGER;
1122 tideX
:= seq
.tide
-1;
1124 FOR index
:= 0 TO tideX
DO
1125 implT
:= seq
.a
[index
].boundRecTp()(Ty
.Record
);
1126 os
.clsD
.AddImplementedInterface(os
.cls(implT
));
1130 (* ============================================================ *)
1132 PROCEDURE (os
: PeFile
)MainHead
*(xAtt
: SET);
1133 VAR mthD
: Api
.MethodDef
;
1135 VAR strA
: Api
.Type
;
1137 pars
: POINTER TO ARRAY OF Api
.Param
;
1140 strA
:= Api
.ZeroBasedArray
.init(strgD
);
1141 pars
[0] := Api
.Param
.init(0, "@args", strA
);
1143 IF Sy
.wMain
IN xAtt
THEN
1144 mthD
:= os
.clsS
.AddMethod(psAtt
, ilAtt
, ".WinMain", voidD
, pars
);
1145 ELSE (* Sy.cMain IN xAtt THEN *)
1146 mthD
:= os
.clsS
.AddMethod(psAtt
, ilAtt
, ".CPmain", voidD
, pars
);
1148 os
.pePI
.mthD
:= mthD
;
1150 mthD
.DeclareEntryPoint();
1151 IF CSt
.debug
THEN os
.LineSpan(Scn
.mkSpanT(CSt
.thisMod
.begTok
)) END;
1153 * Save the command-line arguments to the RTS.
1155 os
.Code(Asm
.opc_ldarg_0
);
1156 os
.CodeF(Asm
.opc_stsfld
, os
.fld(CSt
.argLst
));
1159 (* ============================================================ *)
1161 PROCEDURE (os
: PeFile
)SubSys
*(xAtt
: SET);
1163 IF Sy
.wMain
IN xAtt
THEN os
.peFl
.SetSubSystem(2) END;
1166 (* ============================================================ *)
1168 PROCEDURE (os
: PeFile
)StartBoxClass
*(rec
: Ty
.Record
;
1171 VAR mthD
: Api
.MethodDef
;
1173 boxC
: Api
.ClassDef
;
1175 boxC
:= rec
.tgXtn(RecXtn
).boxD(Api
.ClassDef
);
1176 boxC
.AddAttribute(toTypeAttr(att
));
1179 * Emit the no-arg constructor
1181 os
.MkNewProcInfo(blk
);
1182 mthD
:= os
.new(rec
)(Api
.MethodDef
);
1183 os
.pePI
.mthD
:= mthD
;
1185 mthD
.AddCallConv(Api
.CallConv
.Instance
);
1187 os
.Code(Asm
.opc_ldarg_0
);
1190 os
.pePI
.code
.MethInst(Asm
.cd
[Asm
.opc_call
], sprC
);
1191 os
.InitHead(rec
, NIL);
1192 os
.CallSuper(rec
, NIL);
1193 os
.Code(Asm
.opc_ret
);
1199 * Copies of value classes are always done inline.
1203 (* ============================================================ *)
1205 PROCEDURE (os
: PeFile
)Tail(),NEW;
1208 os
.pePI
.code
.CloseScope(); (* Needed for PERWAPI pdb files *)
1213 (* ============================================================ *)
1215 PROCEDURE (os
: PeFile
)MainTail
*();
1216 BEGIN os
.Tail() END MainTail
;
1218 (* ------------------------------------------------------------ *)
1220 PROCEDURE (os
: PeFile
)MethodTail
*(id
: Id
.Procs
);
1221 BEGIN os
.Tail() END MethodTail
;
1223 (* ------------------------------------------------------------ *)
1225 PROCEDURE (os
: PeFile
)ClinitTail
*();
1226 BEGIN os
.Tail() END ClinitTail
;
1228 (* ------------------------------------------------------------ *)
1230 PROCEDURE (os
: PeFile
)CopyTail
*();
1231 BEGIN os
.Tail() END CopyTail
;
1233 (* ------------------------------------------------------------ *)
1235 PROCEDURE (os
: PeFile
)InitTail
*(typ
: Ty
.Record
);
1236 BEGIN os
.Tail() END InitTail
;
1238 (* ============================================================ *)
1240 PROCEDURE (os
: PeFile
)ClinitHead
*();
1243 mAtt
:= ctAtt
+ Api
.MethAttr
.Static
;
1244 os
.pePI
.mthD
:= os
.clsS
.AddMethod(mAtt
, ilAtt
, ".cctor", voidD
, NIL);
1247 os
.pePI
.code
.IntLine(CSt
.thisMod
.token
.lin
,
1248 CSt
.thisMod
.token
.col
,
1249 CSt
.thisMod
.token
.lin
,
1250 CSt
.thisMod
.token
.col
+ CSt
.thisMod
.token
.len
);
1251 os
.Code(Asm
.opc_nop
);
1255 (* ============================================================ *)
1257 PROCEDURE (os
: PeFile
)EmitField
*(id
: Id
.AbVar
; att
: SET);
1258 VAR fDf
: Api
.FieldDef
;
1260 fDf
:= os
.fld(id
)(Api
.FieldDef
);
1261 fDf
.AddFieldAttr(toFieldAttr(att
));
1264 (* ============================================================ *)
1265 (* Start of Procedure Variable and Event Stuff *)
1266 (* ============================================================ *)
1268 PROCEDURE MkAddRem(os
: PeFile
; fId
: Id
.AbVar
);
1273 typA
: POINTER TO ARRAY OF Api
.Type
;
1274 parA
: POINTER TO ARRAY OF Api
.Param
;
1275 (* -------------------------------- *)
1276 PROCEDURE GetClass(os
: PeFile
;
1279 OUT nm
: Lv
.CharOpen
);
1281 WITH id
: Id
.FldId
DO
1282 cl
:= os
.cls(id
.recTyp(Ty
.Record
));
1285 IF id
.recTyp
# NIL THEN cl
:= os
.cls(id
.recTyp(Ty
.Record
));
1286 ELSE cl
:= os
.dsc(id
.dfScp(Id
.BlkId
));
1291 (* -------------------------------- *)
1294 * First, need to ensure that there is a field
1295 * descriptor created for this variable.
1297 IF fId
.tgXtn
= NIL THEN
1300 fXt
:= fId
.tgXtn(Api
.Field
);
1303 * Now allocate the Event Extension object.
1308 * Now create the MethodRef or MethodDef descriptors
1309 * for add_<fieldname>() and remove_<fieldname>()
1311 GetClass(os
, fId
, clD
, namS
);
1312 WITH clD
: Api
.ClassDef
DO
1314 parA
[0] := Api
.Param
.init(0, "ev", os
.typ(fId
.type
));
1315 xtn
.addD
:= clD
.AddMethod(MKSTR(evtAdd^
+ namS^
), voidD
, parA
);
1316 xtn
.remD
:= clD
.AddMethod(MKSTR(evtRem^
+ namS^
), voidD
, parA
);
1317 | clD
: Api
.ClassRef
DO
1319 typA
[0] := os
.typ(fId
.type
);
1320 xtn
.addD
:= clD
.AddMethod(MKSTR(evtAdd^
+ namS^
), voidD
, typA
);
1321 xtn
.remD
:= clD
.AddMethod(MKSTR(evtRem^
+ namS^
), voidD
, typA
);
1326 (* ============================================================ *)
1328 PROCEDURE (os
: PeFile
)EmitEventMethods
*(id
: Id
.AbVar
);
1329 CONST att
= Api
.MethAttr
.Public
+ Api
.MethAttr
.SpecialName
;
1332 addD
: Api
.MethodDef
;
1333 remD
: Api
.MethodDef
;
1334 (* ------------------------------------------------- *)
1335 PROCEDURE EmitEvtMth(os
: PeFile
;
1338 mth
: Api
.MethodDef
);
1339 VAR pFix
: Lv
.CharOpen
;
1340 mStr
: RTS
.NativeString
;
1341 mthD
: Api
.MethodDef
;
1342 parA
: POINTER TO ARRAY OF Api
.Param
;
1344 os
.MkNewProcInfo(NIL);
1345 WITH id
: Id
.FldId
DO
1346 mth
.AddMethAttribute(att
);
1347 mth
.AddCallConv(Api
.CallConv
.Instance
);
1348 mth
.AddImplAttribute(ilAtt
+ Api
.ImplAttr
.Synchronised
);
1349 os
.pePI
.mthD
:= mth
;
1351 os
.Code(Asm
.opc_ldarg_0
);
1352 os
.Code(Asm
.opc_ldarg_0
);
1353 os
.PutGetF(Asm
.opc_ldfld
, id
);
1354 os
.Code(Asm
.opc_ldarg_1
);
1355 os
.CallCombine(id
.type
, add
);
1356 os
.PutGetF(Asm
.opc_stfld
, id
);
1358 mth
.AddMethAttribute(att
+ Api
.MethAttr
.Static
);
1359 mth
.AddImplAttribute(ilAtt
+ Api
.ImplAttr
.Synchronised
);
1360 os
.pePI
.mthD
:= mth
;
1362 os
.PutGetS(Asm
.opc_ldsfld
, id
.dfScp(Id
.BlkId
), id
);
1363 os
.Code(Asm
.opc_ldarg_0
);
1364 os
.CallCombine(id
.type
, add
);
1365 os
.PutGetS(Asm
.opc_stsfld
, id
.dfScp(Id
.BlkId
),id
);
1367 os
.Code(Asm
.opc_ret
);
1370 (* ------------------------------------------------- *)
1373 * Emit the "add_*" method
1375 addD
:= os
.add(id
)(Api
.MethodDef
);
1376 EmitEvtMth(os
, id
, TRUE
, addD
);
1378 * Emit the "remove_*" method
1380 remD
:= os
.rem(id
)(Api
.MethodDef
);
1381 EmitEvtMth(os
, id
, FALSE
, remD
);
1383 * Emit the .event declaration"
1385 WITH id
: Id
.FldId
DO
1386 evt
:= os
.clsD
.AddEvent(MKSTR(id
.fldNm^
), os
.typ(id
.type
));
1388 evt
:= os
.clsD
.AddEvent(MKSTR(id
.varNm^
), os
.typ(id
.type
));
1390 evt
.AddMethod(addD
, Api
.MethodType
.AddOn
);
1391 evt
.AddMethod(remD
, Api
.MethodType
.RemoveOn
);
1392 END EmitEventMethods
;
1394 (* ============================================================ *)
1396 PROCEDURE (os
: PeFile
)CallCombine(typ
: Sy
.Type
;
1398 VAR xtn
: Api
.Method
;
1400 IF add
THEN xtn
:= os
.cmb() ELSE xtn
:= os
.rmv() END;
1401 os
.pePI
.code
.MethInst(Asm
.cd
[Asm
.opc_call
], xtn
);
1403 os
.CodeT(Asm
.opc_castclass
, typ
);
1406 (* ============================================================ *)
1408 PROCEDURE (os
: PeFile
)MkAndLinkDelegate
*(dl
: Sy
.Idnt
;
1412 (* --------------------------------------------------------- *)
1415 (* --------------------------------------------------------- *)
1417 WITH id
: Id
.FldId
DO
1419 * <push handle> // ... already done
1420 * <push receiver (or nil)> // ... already done
1421 * <make new proc value> // ... still to do
1422 * call instance void A.B::add_fld(class tyName)
1424 os
.MkNewProcVal(dl
, ty
);
1425 IF isA
THEN mth
:= os
.add(id
) ELSE mth
:= os
.rem(id
) END;
1426 mth
.AddCallConv(Api
.CallConv
.Instance
);
1427 os
.pePI
.code
.MethInst(Asm
.cd
[Asm
.opc_call
], mth
);
1430 * <push receiver (or nil)> // ... already done
1431 * <make new proc value> // ... still to do
1432 * call void A.B::add_fld(class tyName)
1434 os
.MkNewProcVal(dl
, ty
);
1435 IF isA
THEN mth
:= os
.add(id
) ELSE mth
:= os
.rem(id
) END;
1436 os
.pePI
.code
.MethInst(Asm
.cd
[Asm
.opc_call
], mth
);
1441 * <restore receiver>
1442 * <make new proc value> // ... still to do
1443 * call class D D::Combine(class D, class D)
1445 rcv
:= os
.proc
.newLocal(CSt
.ntvObj
);
1449 os
.MkNewProcVal(dl
, ty
);
1450 os
.CallCombine(ty
, isA
);
1453 END MkAndLinkDelegate
;
1455 (* ============================================================ *)
1456 (* ============================================================ *)
1458 PROCEDURE (os
: PeFile
)EmitPTypeBody
*(tId
: Id
.TypId
);
1460 ASSERT(tId
.tgXtn
# NIL);
1463 (* ============================================================ *)
1464 (* End of Procedure Variable and Event Stuff *)
1465 (* ============================================================ *)
1467 PROCEDURE (os
: PeFile
)Line
*(nm
: INTEGER);
1469 os
.pePI
.code
.IntLine(nm
,1,nm
,100);
1470 (*IF CSt.debug THEN os.Code(Asm.opc_nop) END;*)
1473 PROCEDURE (os
: PeFile
)LinePlus
*(lin
, col
: INTEGER);
1475 (*IF CSt.debug THEN os.Code(Asm.opc_nop) END;*)
1476 os
.pePI
.code
.IntLine(lin
,1,lin
,col
);
1479 PROCEDURE (os
: PeFile
)LineSpan
*(s
: Scn
.Span
);
1482 os
.pePI
.code
.IntLine(s
.sLin
, s
.sCol
, s
.eLin
, s
.eCol
) END;
1485 (* ============================================================ *)
1487 PROCEDURE (os
: PeFile
)Locals(),NEW;
1488 (** Declare the local of this method. *)
1489 VAR count
: INTEGER;
1493 methD
: Api
.MethodDef
;
1494 loclA
: POINTER TO ARRAY OF Api
.Local
;
1495 boolA
: POINTER TO ARRAY OF BOOLEAN;
1496 lBind
: Api
.LocalBinding
;
1498 methD
:= os
.pePI
.mthD
;
1500 * If dMax < 8, leave maxstack as default
1502 IF os
.proc
.dMax
> 8 THEN
1503 methD
.SetMaxStack(os
.proc
.dMax
);
1505 methD
.SetMaxStack(8);
1507 NEW(loclA
, os
.proc
.tLst
.tide
);
1508 NEW(boolA
, os
.proc
.tLst
.tide
);
1511 IF os
.proc
.prId
# NIL THEN
1512 prcId
:= os
.proc
.prId
;
1513 WITH prcId
: Id
.Procs
DO
1514 IF Id
.hasXHR
IN prcId
.pAttr
THEN
1515 loclA
[count
] := Api
.Local
.init("", os
.typ(prcId
.xhrType
));
1518 FOR index
:= 0 TO prcId
.locals
.tide
-1 DO
1519 locId
:= prcId
.locals
.a
[index
](Id
.LocId
);
1520 IF ~
(locId
IS Id
.ParId
) & (locId
.varOrd
# Id
.xMark
) THEN
1521 loclA
[count
] := Api
.Local
.init(nms(locId
), os
.typ(locId
.type
));
1522 IF CSt
.debug
THEN boolA
[count
] := TRUE
END;
1526 ELSE (* nothing for module blocks *)
1529 WHILE count
< os
.proc
.tLst
.tide
DO
1530 loclA
[count
] := Api
.Local
.init("", os
.typ(os
.proc
.tLst
.a
[count
]));
1533 IF count
> 0 THEN methD
.AddLocals(loclA
, TRUE
) END;
1534 FOR index
:= 0 TO count
-1 DO
1535 IF boolA
[index
] THEN lBind
:= os
.pePI
.code
.BindLocal(loclA
[index
]) END;
1539 (* ============================================================ *)
1541 PROCEDURE (os
: PeFile
)LoadType
*(id
: Sy
.Idnt
);
1542 (* ---------------------------------- *)
1543 PROCEDURE getLdTyp(os
: PeFile
) : Api
.MethodRef
;
1544 VAR typD
: Api
.ClassRef
;
1545 rthA
: POINTER TO ARRAY OF Api
.Type
;
1547 IF loadTyp
= NIL THEN
1549 * Make params for the call
1552 IF rtTpHdl
= NIL THEN
1553 rtTpHdl
:= getOrAddValueClass(corlib
, "System", "RuntimeTypeHandle");
1557 * Make receiver/result type descriptor
1559 IF CSt
.ntvTyp
.tgXtn
= NIL THEN
1560 CSt
.ntvTyp
.tgXtn
:= getOrAddClass(corlib
, "System", "Type");
1562 typD
:= CSt
.ntvTyp
.tgXtn(Api
.ClassRef
);
1563 loadTyp
:= getOrAddMethod(typD
, "GetTypeFromHandle", typD
, rthA
);
1567 (* ---------------------------------- *)
1571 * call class [mscorlib]System.Type
1572 * [mscorlib]System.Type::GetTypeFromHandle(
1573 * value class [mscorlib]System.RuntimeTypeHandle)
1575 os
.CodeT(Asm
.opc_ldtoken
, id
.type
);
1576 os
.pePI
.code
.MethInst(Asm
.cd
[Asm
.opc_call
], getLdTyp(os
));
1579 (* ============================================================ *)
1581 PROCEDURE (os
: PeFile
)Finish
*();
1582 (*(* ------------------------------------ *)
1583 PROCEDURE MakeDebuggable(pef
: Api
.PEFile
);
1584 VAR thisAssm
: Api
.Assembly
;
1585 debugRef
: Api
.ClassRef
;
1586 dbugCtor
: Api
.MethodRef
;
1587 trueCnst
: Api
.BoolConst
;
1589 dbugArgs
: POINTER TO ARRAY OF Api
.Constant
;
1591 thisAssm
:= pef
.GetThisAssembly();
1592 debugRef
:= getOrAddClass(corlib
, "System.Diagnostics", "DebuggableAttribute");
1595 twoBools
[0] := Api
.PrimitiveType
.Boolean
;
1596 twoBools
[1] := Api
.PrimitiveType
.Boolean
;
1597 dbugArgs
[0] := Api
.BoolConst
.init(TRUE
);
1598 dbugArgs
[1] := Api
.BoolConst
.init(TRUE
);
1599 dbugCtor
:= getOrAddMethod(debugRef
, ctorS
, voidD
, twoBools
)(Api
.MethodRef
);
1600 dbugCtor
.AddCallConv(Api
.CallConv
.Instance
);
1601 thisAssm
.AddCustomAttribute(dbugCtor
, dbugArgs
);
1603 (* ------------------------------------ *)*)
1605 IF CSt
.debug
THEN os
.peFl
.MakeDebuggable(TRUE
, TRUE
) END;
1606 (* bake the assembly ... *)
1607 os
.peFl
.WritePEFile(CSt
.debug
);
1610 (* ============================================================ *)
1612 PROCEDURE (os
: PeFile
)RefRTS
*();
1621 * Reset the descriptor pool.
1622 * Note that descriptors cannot persist between
1623 * compilation unit, since the token sequence
1624 * is reset in PEAPI.
1631 FOR i
:= 0 TO Mu
.rtsLen
-1 DO rHelper
[i
] := NIL END;
1633 * Now we need to create tgXtn fields
1634 * for some of the system types. All
1635 * others are only allocated on demand.
1637 corlib
:= os
.peFl
.MakeExternAssembly("mscorlib");
1639 * Must put xtn markers on both the pointer AND the record
1642 CSt
.ntvStr(Ty
.Pointer
).boundTp
.tgXtn
:= recXt
; (* the record *)
1644 * recXt.clsD := corlib.AddClass("System", "String");
1646 (* -- start replacement -- *)
1647 recXt
.clsD
:= getOrAddClass(corlib
, "System", "String");
1648 (* --- end replacement --- *)
1649 CSt
.ntvStr
.tgXtn
:= recXt
.clsD
; (* the pointer *)
1651 * Must put xtn markers on both the pointer AND the record
1654 CSt
.ntvObj(Ty
.Pointer
).boundTp
.tgXtn
:= recXt
; (* the record *)
1656 * recXt.clsD := corlib.AddClass("System", "Object");
1658 (* -- start replacement -- *)
1659 recXt
.clsD
:= getOrAddClass(corlib
, "System", "Object");
1660 (* --- end replacement --- *)
1661 CSt
.ntvObj
.tgXtn
:= recXt
.clsD
; (* the pointer *)
1663 * CSt.ntvVal IS a record descriptor, not a pointer
1666 CSt
.ntvVal
.tgXtn
:= recXt
; (* the record *)
1668 * recXt.clsD := corlib.AddClass("System", "ValueType");
1670 (* -- start replacement -- *)
1671 recXt
.clsD
:= getOrAddClass(corlib
, "System", "ValueType");
1672 (* --- end replacement --- *)
1674 newObjt
:= getOrAddMethod(CSt
.ntvObj
.tgXtn(Api
.ClassRef
),ctorS
,voidD
,NIL);
1675 newObjt
.AddCallConv(Api
.CallConv
.Instance
);
1677 * Create Api.AssemblyRef for "RTS"
1678 * Create Api.ClassRef for "[RTS]RTS"
1679 * Create Api.ClassRef for "[RTS]Cp_rts"
1681 IF CSt
.rtsBlk
.xName
= NIL THEN Mu
.MkBlkName(CSt
.rtsBlk
) END;
1682 os
.rts
:= os
.peFl
.MakeExternAssembly("RTS");
1684 rtsXt
.asmD
:= os
.rts
;
1685 rtsXt
.dscD
:= os
.rts
.AddClass("", "RTS");
1686 CSt
.rtsBlk
.tgXtn
:= rtsXt
;
1687 os
.cprts
:= os
.rts
.AddClass("", "CP_rts");
1689 * Create Api.AssemblyRef for "ProgArgs" (same as RTS)
1690 * Create Api.ClassRef for "[RTS]ProgArgs"
1692 os
.DoRtsMod(CSt
.prgArg
);
1693 os
.progArgs
:= CSt
.prgArg
.tgXtn(BlkXtn
).dscD(Api
.ClassRef
);
1695 * Create Api.ClassRef for "[RTS]XHR"
1696 * Create method "[RTS]XHR::.ctor()"
1698 xhrCl
:= os
.rts
.AddClass("", "XHR");
1699 xhrNw
:= xhrCl
.AddMethod(ctorS
, voidD
, NIL);
1700 xhrNw
.AddCallConv(Api
.CallConv
.Instance
);
1701 xhrRc
:= CSt
.rtsXHR
.boundRecTp()(Ty
.Record
);
1703 xhrRc
.tgXtn
:= xhrXt
;
1704 xhrXt
.clsD
:= xhrCl
;
1705 xhrXt
.newD
:= xhrNw
;
1708 (* ============================================================ *)
1710 PROCEDURE (os
: PeFile
)StartNamespace
*(nm
: Lv
.CharOpen
);
1712 os
.nmSp
:= MKSTR(nm^
);
1715 (* ============================================================ *)
1717 PROCEDURE (os
: PeFile
)MkBodyClass
*(mod
: Id
.BlkId
);
1719 * Instantiate a ClassDef object for the synthetic
1720 * static class, and assign to the PeFile::clsS field.
1721 * Of course, for the time being it is also the
1722 * "current class" held in the PeFile::clsD field.
1724 VAR namStr
: RTS
.NativeString
;
1728 defSrc
:= Api
.SourceFile
.GetSourceFile(
1729 MKSTR(CSt
.srcNam
), Sys
.Guid
.Empty
, Sys
.Guid
.Empty
, Sys
.Guid
.Empty
);
1730 namStr
:= MKSTR(mod
.clsNm^
);
1731 clsAtt
:= toTypeAttr(Asm
.modAttr
);
1732 os
.clsS
:= os
.peFl
.AddClass(clsAtt
, os
.nmSp
, namStr
);
1736 modXtn
.dscD
:= os
.clsS
;
1737 mod
.tgXtn
:= modXtn
;
1740 (* ============================================================ *)
1742 PROCEDURE (os
: PeFile
)ClassHead
*(attSet
: SET;
1744 superT
: Ty
.Record
);
1745 VAR clsAtt
: INTEGER;
1746 clsDef
: Api
.ClassDef
;
1748 clsAtt
:= toTypeAttr(attSet
);
1749 clsDef
:= os
.cls(thisRc
)(Api
.ClassDef
);
1750 clsDef
.AddAttribute(clsAtt
);
1754 (* ============================================================ *)
1756 PROCEDURE (os
: PeFile
)ClassTail
*();
1761 (* ============================================================ *)
1763 PROCEDURE (os
: PeFile
)MkRecX
*(t
: Ty
.Record
; s
: Sy
.Scope
);
1764 (* -------------------------------- *
1765 * Create a ClassDef or a ClassRef for this type.
1766 * The type attributes are set to a default value
1767 * and are modified later for a ClassDef.
1768 * -------------------------------- *)
1770 valR
: BOOLEAN; (* is a value record *)
1771 noNw
: BOOLEAN; (* no constructor... *)
1773 xAsm
: Api
.AssemblyRef
;
1774 xCls
: Api
.ClassRef
;
1775 cDef
: Api
.ClassDef
;
1776 cRef
: Api
.ClassRef
;
1777 nStr
: RTS
.NativeString
; (* record name string *)
1778 aStr
: RTS
.NativeString
; (* imported namespace *)
1780 (* -------------------------------- *)
1781 PROCEDURE DoBoxDef(o
: PeFile
; t
: Ty
.Record
);
1782 VAR nStr
: RTS
.NativeString
;
1783 cDef
: Api
.ClassDef
;
1784 cFld
: Api
.FieldDef
;
1785 nMth
: Api
.MethodDef
;
1788 nStr
:= boxedName(t
);
1789 tXtn
:= t
.tgXtn(RecXtn
);
1790 cDef
:= o
.peFl
.AddClass(0, o
.nmSp
, nStr
);
1791 cFld
:= cDef
.AddField(vfldS
, tXtn
.clsD
);
1792 nMth
:= cDef
.AddMethod(ctAtt
,ilAtt
,ctorS
,voidD
,NIL);
1794 nMth
.AddCallConv(Api
.CallConv
.Instance
);
1795 cFld
.AddFieldAttr(Api
.FieldAttr
.Public
);
1801 (* -------------------------------- *)
1802 PROCEDURE DoBoxRef(o
: PeFile
; t
: Ty
.Record
; c
: Api
.ClassRef
);
1803 VAR cFld
: Api
.FieldRef
;
1804 nMth
: Api
.MethodRef
;
1807 tXtn
:= t
.tgXtn(RecXtn
);
1808 cFld
:= getOrAddField(c
, vfldS
, tXtn
.clsD
);
1810 * nMth := c.AddMethod(ctorS,voidD,NIL);
1812 nMth
:= getOrAddMethod(c
, ctorS
, voidD
, NIL);
1813 nMth
.AddCallConv(Api
.CallConv
.Instance
);
1819 (* -------------------------------- *)
1821 nStr
:= MKSTR(t
.xName^
);
1822 valR
:= Mu
.isValRecord(t
);
1826 * No default no-arg constructor is defined if this
1827 * is an abstract record, an interface, or extends a
1828 * foreign record that does not export a no-arg ctor.
1830 noNw
:= t
.isInterfaceType() OR (Sy
.noNew
IN t
.xAttr
);
1832 IF s
.kind
# Id
.impId
THEN (* this is a classDEF *)
1833 base
:= t
.superType(); (* might return System.ValueType *)
1835 cDef
:= os
.peFl
.AddClass(0, os
.nmSp
, nStr
);
1837 cDef
:= os
.peFl
.AddValueClass(0, os
.nmSp
, nStr
);
1839 cDef
:= os
.peFl
.AddClass(0, os
.nmSp
, nStr
, os
.cls(base
));
1841 recX
.clsD
:= cDef
; (* this field needed for MkFldName() *)
1844 * Create the boxed version of this value record
1845 * AND create a constructor for the boxed class
1850 * Create a constructor for this reference class.
1852 recX
.newD
:= cDef
.AddMethod(ctAtt
, ilAtt
, ctorS
, voidD
, NIL);
1853 recX
.newD
.AddCallConv(Api
.CallConv
.Instance
);
1855 FOR indx
:= 0 TO t
.fields
.tide
-1 DO
1856 Mu
.MkFldName(t
.fields
.a
[indx
](Id
.FldId
), os
);
1858 ELSE (* this is a classREF *)
1859 IF t
.encCls
# NIL THEN (* ... a nested classREF *)
1860 base
:= t
.encCls(Ty
.Record
);
1861 xCls
:= os
.cls(base
)(Api
.ClassRef
);
1862 cRef
:= xCls
.AddNestedClass(nStr
);
1864 ELSE (* ... a normal classREF *)
1865 xAsm
:= os
.asm(s(Id
.BlkId
));
1866 aStr
:= MKSTR(s(Id
.BlkId
).xName^
);
1868 cRef
:= getOrAddValueClass(xAsm
, aStr
, nStr
);
1870 cRef
:= getOrAddClass(xAsm
, aStr
, nStr
);
1873 IF valR
& ~
(Sy
.isFn
IN t
.xAttr
) THEN
1874 DoBoxRef(os
, t
, xAsm
.AddClass(aStr
, boxedName(t
)));
1878 IF ~noNw
& ~valR
THEN
1879 recX
.newD
:= getOrAddMethod(cRef
, ctorS
, voidD
, NIL);
1880 recX
.newD
.AddCallConv(Api
.CallConv
.Instance
);
1885 (* ============================================================ *)
1887 PROCEDURE (os
: PeFile
)MkVecX
*(t
: Sy
.Type
; m
: Id
.BlkId
);
1888 VAR xAsm
: Api
.AssemblyRef
;
1890 nStr
: RTS
.NativeString
; (* record name string *)
1891 aStr
: RTS
.NativeString
; (* imported namespace *)
1892 cRef
: Api
.ClassRef
;
1897 IF m
.tgXtn
= NIL THEN os
.DoRtsMod(m
) END;
1898 IF t
.xName
= NIL THEN Mu
.MkTypeName(t
, os
) END;
1900 aStr
:= MKSTR(m
.xName^
);
1901 nStr
:= MKSTR(t
.xName^
);
1904 cRef
:= xAsm
.AddClass(aStr
, nStr
);
1906 recX
.newD
:= cRef
.AddMethod(ctorS
, voidD
, NIL);
1907 recX
.newD
.AddCallConv(Api
.CallConv
.Instance
);
1910 (* ============================================================ *)
1912 PROCEDURE (os
: PeFile
)MkDelX(t
: Ty
.Procedure
;
1914 (* -------------------------------- *)
1915 CONST dAtt
= Asm
.att_public
+ Asm
.att_sealed
;
1916 VAR xtn
: DelXtn
; (* The created descriptor *)
1917 str
: RTS
.NativeString
; (* The proc-type nameString *)
1918 att
: Api
.TypeAttr
; (* public,sealed (for Def) *)
1919 asN
: RTS
.NativeString
; (* Assembly name (for Ref) *)
1920 asR
: Api
.AssemblyRef
; (* Assembly ref (for Ref) *)
1921 rtT
: Sy
.Type
; (* AST return type of proc *)
1922 rtD
: Api
.Type
; (* Api return type of del. *)
1925 mtD
: Api
.MethodDef
;
1926 (* -------------------------------- *)
1927 PROCEDURE t2() : POINTER TO ARRAY OF Api
.Type
;
1928 VAR a
: POINTER TO ARRAY OF Api
.Type
;
1930 NEW(a
,2); a
[0] := objtD
; a
[1] := nIntD
; RETURN a
;
1932 (* -------------------------------- *)
1933 PROCEDURE p2() : POINTER TO ARRAY OF Api
.Param
;
1934 VAR a
: POINTER TO ARRAY OF Api
.Param
;
1937 a
[0] := Api
.Param
.init(0, "obj", objtD
);
1938 a
[1] := Api
.Param
.init(0, "mth", nIntD
);
1941 (* -------------------------------- *)
1942 PROCEDURE tArr(t
: Ty
.Procedure
; o
: PeFile
) : POINTER TO ARRAY OF Api
.Type
;
1943 VAR a
: POINTER TO ARRAY OF Api
.Type
;
1948 NEW(a
, t
.formals
.tide
);
1949 FOR i
:= 0 TO t
.formals
.tide
-1 DO
1950 p
:= t
.formals
.a
[i
];
1952 IF Mu
.takeAdrs(p
) THEN
1953 p
.boxOrd
:= p
.parMod
;
1954 d
:= Api
.ManagedPointer
.init(d
);
1960 (* -------------------------------- *)
1961 PROCEDURE pArr(t
: Ty
.Procedure
; o
: PeFile
) : POINTER TO ARRAY OF Api
.Param
;
1962 VAR a
: POINTER TO ARRAY OF Api
.Param
;
1967 NEW(a
, t
.formals
.tide
);
1968 FOR i
:= 0 TO t
.formals
.tide
-1 DO
1969 p
:= t
.formals
.a
[i
];
1971 IF Mu
.takeAdrs(p
) THEN
1972 p
.boxOrd
:= p
.parMod
;
1973 d
:= Api
.ManagedPointer
.init(d
);
1975 a
[i
] := Api
.Param
.init(0, nms(p
), d
);
1979 (* -------------------------------- *)
1981 IF t
.tgXtn
# NIL THEN RETURN END;
1983 str
:= MKSTR(Sy
.getName
.ChPtr(t
.idnt
)^
);
1985 IF rtT
= NIL THEN rtD
:= voidD
ELSE rtD
:= os
.typ(rtT
) END;
1987 IF s
.kind
# Id
.impId
THEN (* this is a classDEF *)
1988 att
:= toTypeAttr(dAtt
);
1989 clD
:= os
.peFl
.AddClass(att
, os
.nmSp
, str
, os
.mcd());
1990 mtD
:= clD
.AddMethod(ctorS
, voidD
, p2());
1991 mtD
.AddMethAttribute(ctAtt
);
1992 mtD
.AddImplAttribute(rmAtt
);
1994 mtD
:= clD
.AddMethod(invkS
, rtD
, pArr(t
, os
));
1995 mtD
.AddMethAttribute(Api
.MethAttr
.Public
);
1996 mtD
.AddImplAttribute(rmAtt
);
1999 ELSE (* this is a classREF *)
2000 asR
:= os
.asm(s(Id
.BlkId
));
2001 asN
:= MKSTR(s(Id
.BlkId
).xName^
);
2002 clR
:= getOrAddClass(asR
, asN
, str
);
2003 xtn
.newD
:= clR
.AddMethod(ctorS
, voidD
, t2());
2004 xtn
.invD
:= clR
.AddMethod(invkS
, rtD
, tArr(t
, os
));
2007 xtn
.newD
.AddCallConv(Api
.CallConv
.Instance
);
2008 xtn
.invD
.AddCallConv(Api
.CallConv
.Instance
);
2010 IF (t
.idnt
# NIL) & (t
.idnt
.tgXtn
= NIL) THEN t
.idnt
.tgXtn
:= xtn
END;
2013 (* ============================================================ *)
2015 PROCEDURE (os
: PeFile
)MkPtrX
*(t
: Ty
.Pointer
);
2020 IF bTyp
.tgXtn
= NIL THEN Mu
.MkTypeName(bTyp
, os
) END;
2021 WITH bTyp
: Ty
.Record
DO
2022 recX
:= bTyp
.tgXtn(RecXtn
);
2023 IF recX
.boxD
# NIL THEN t
.tgXtn
:= recX
.boxD
;
2024 ELSE t
.tgXtn
:= recX
.clsD
;
2026 | bTyp
: Ty
.Array
DO
2027 t
.tgXtn
:= bTyp
.tgXtn
;
2031 (* ============================================================ *)
2033 PROCEDURE (os
: PeFile
)MkArrX
*(t
: Ty
.Array
);
2035 t
.tgXtn
:= Api
.ZeroBasedArray
.init(os
.typ(t
.elemTp
));
2038 (* ============================================================ *)
2040 PROCEDURE (os
: PeFile
)MkBasX
*(t
: Ty
.Base
);
2043 | Ty
.uBytN
: t
.tgXtn
:= Api
.PrimitiveType
.UInt8
;
2044 | Ty
.byteN
: t
.tgXtn
:= Api
.PrimitiveType
.Int8
;
2045 | Ty
.sIntN
: t
.tgXtn
:= Api
.PrimitiveType
.Int16
;
2046 | Ty
.intN
,Ty
.setN
: t
.tgXtn
:= Api
.PrimitiveType
.Int32
;
2047 | Ty
.lIntN
: t
.tgXtn
:= Api
.PrimitiveType
.Int64
;
2048 | Ty
.boolN
: t
.tgXtn
:= Api
.PrimitiveType
.Boolean
;
2049 | Ty
.charN
,Ty
.sChrN
: t
.tgXtn
:= Api
.PrimitiveType
.Char
;
2050 | Ty
.realN
: t
.tgXtn
:= Api
.PrimitiveType
.Float64
;
2051 | Ty
.sReaN
: t
.tgXtn
:= Api
.PrimitiveType
.Float32
;
2052 | Ty
.anyRec
,Ty
.anyPtr
: t
.tgXtn
:= Api
.PrimitiveType
.Object
;
2056 (* ============================================================ *)
2058 PROCEDURE (os
: PeFile
)MkEnuX
*(t
: Ty
.Enum
; s
: Sy
.Scope
);
2059 VAR scNs
: RTS
.NativeString
;
2060 enNm
: RTS
.NativeString
;
2062 ASSERT(s
.kind
= Id
.impId
);
2063 scNs
:= MKSTR(s(Id
.BlkId
).xName^
);
2064 enNm
:= MKSTR(Sy
.getName
.ChPtr(t
.idnt
)^
);
2065 t
.tgXtn
:= getOrAddValueClass(os
.asm(s(Id
.BlkId
)), scNs
, enNm
);
2068 (* ============================================================ *)
2070 PROCEDURE (os : PeFile)MkTyXtn*(t : Sy.Type; s : Sy.Scope);
2072 IF t.tgXtn # NIL THEN RETURN END;
2073 WITH t : Ty.Record DO os.MkRecX(t, s);
2074 | t : Ty.Enum DO os.MkEnuX(t, s);
2075 | t : Ty.Procedure DO os.MkDelX(t, s);
2076 | t : Ty.Base DO os.MkBasX(t);
2077 | t : Ty.Pointer DO os.MkPtrX(t);
2078 | t : Ty.Array DO os.MkArrX(t);
2082 (* ============================================================ *)
2084 PROCEDURE MkMthDef(os
: PeFile
;
2088 str
: RTS
.NativeString
) : Api
.MethodDef
;
2091 prs
: POINTER TO ARRAY OF Api
.Param
;
2096 idx
: INTEGER; (* index into formal array *)
2097 prX
: INTEGER; (* index into param. array *)
2098 prO
: INTEGER; (* runtime ordinal of arg. *)
2099 num
: INTEGER; (* length of formal array *)
2100 len
: INTEGER; (* length of param array *)
2103 IF (pId
# NIL) & (pId
IS Id
.MthId
) & (Id
.covar
IN pId(Id
.MthId
).mthAtt
) THEN
2104 rtT
:= pId(Id
.MthId
).retTypBound();
2108 num
:= pTp
.formals
.tide
;
2109 IF xhr
THEN len
:= num
+ 1 ELSE len
:= num
END;
2111 IF rtT
= NIL THEN rtd
:= voidD
ELSE rtd
:= os
.typ(rtT
) END;
2113 prO
:= pTp
.argN
; (* count from 1 if xhr OR has this *)
2115 prs
[0] := Api
.Param
.init(0, "", xhrCl
); prX
:= 1;
2119 FOR idx
:= 0 TO num
-1 DO
2120 par
:= pTp
.formals
.a
[idx
];
2122 prd
:= os
.typ(par
.type
);
2123 IF Mu
.takeAdrs(par
) THEN
2124 par
.boxOrd
:= par
.parMod
;
2125 prd
:= Api
.ManagedPointer
.init(prd
);
2126 IF Id
.uplevA
IN par
.locAtt
THEN
2127 par
.boxOrd
:= Sy
.val
;
2128 ASSERT(Id
.cpVarP
IN par
.locAtt
);
2130 END; (* just mark *)
2131 prs
[prX
] := Api
.Param
.init(par
.boxOrd
, nms(par
), prd
);
2135 * Add attributes, Impl, Meth, CallConv in MethodDecl()
2137 RETURN cls
.AddMethod(str
, rtd
, prs
);
2140 (* ============================================================ *)
2142 PROCEDURE MkMthRef(os
: PeFile
;
2145 str
: RTS
.NativeString
) : Api
.MethodRef
;
2148 prs
: POINTER TO ARRAY OF Api
.Type
;
2153 idx
: INTEGER; (* index into formal array *)
2154 prO
: INTEGER; (* runtime ordinal of arg. *)
2155 num
: INTEGER; (* length of formal array *)
2158 IF (pId
# NIL) & (pId
IS Id
.MthId
) & (Id
.covar
IN pId(Id
.MthId
).mthAtt
) THEN
2159 rtT
:= pId(Id
.MthId
).retTypBound();
2163 num
:= pTp
.formals
.tide
;
2165 IF rtT
= NIL THEN rtd
:= voidD
ELSE rtd
:= os
.typ(rtT
) END;
2168 FOR idx
:= 0 TO num
-1 DO
2169 par
:= pTp
.formals
.a
[idx
];
2170 tpD
:= os
.typ(par
.type
);
2171 par
.varOrd
:= prO
; (* if hasThis, then is (idx+1) *)
2172 IF Mu
.takeAdrs(par
) THEN
2173 par
.boxOrd
:= par
.parMod
;
2174 tpD
:= Api
.ManagedPointer
.init(tpD
);
2175 END; (* just mark *)
2176 prs
[idx
] := tpD
; INC(prO
);
2178 RETURN getOrAddMethod(cls
, str
, rtd
, prs
);
2181 (* ============================================================ *)
2183 PROCEDURE (os
: PeFile
)NumberParams
*(pId
: Id
.Procs
;
2184 pTp
: Ty
.Procedure
);
2186 * (1) Generate signature information for this procedure
2187 * (2) Generate the target extension Method(Def | Ref)
2189 VAR class
: Api
.Class
;
2191 namSt
: RTS
.NativeString
;
2194 (* ----------------- *)
2195 PROCEDURE classOf(os
: PeFile
; id
: Id
.Procs
) : Api
.Class
;
2200 * Check for methods bound to explicit classes
2202 IF id
.bndType
# NIL THEN RETURN os
.cls(id
.bndType(Ty
.Record
)) END;
2204 * Or associate static methods with the dummy class
2206 WITH scp
: Id
.BlkId
DO
2208 | scp
: Id
.Procs
DO (* Nested procs take class from scope *)
2209 RETURN classOf(os
, scp
);
2212 (* ----------------- *)
2215 os
.MkDelX(pTp
, pTp
.idnt
.dfScp
); RETURN; (* PREMATURE RETURN HERE *)
2217 IF pId
.tgXtn
# NIL THEN RETURN END; (* PREMATURE RETURN HERE *)
2219 class
:= classOf(os
, pId
);
2220 namSt
:= MKSTR(pId
.prcNm^
);
2221 xhrMk
:= pId
.lxDepth
> 0;
2223 * The incoming argN counts one for a receiver,
2224 * and also counts one for nested procedures.
2226 IF pId
IS Id
.MthId
THEN pLeng
:= pTp
.argN
-1 ELSE pLeng
:= pTp
.argN
END;
2228 * Now create either a MethodDef or MethodRef
2230 WITH class
: Api
.ClassDef
DO
2231 methD
:= MkMthDef(os
, xhrMk
, pTp
, class
, namSt
);
2232 | class
: Api
.ClassRef
DO
2233 methD
:= MkMthRef(os
, pTp
, class
, namSt
);
2235 INC(pTp
.argN
, pTp
.formals
.tide
);
2236 IF pTp
.retType
# NIL THEN pTp
.retN
:= 1 END;
2237 IF (pId
.kind
= Id
.ctorP
) OR
2238 (pId
IS Id
.MthId
) THEN methD
.AddCallConv(Api
.CallConv
.Instance
) END;
2241 pTp
.xName
:= cln2
; (* an arbitrary "done" marker *)
2243 IF (pId
.kind
= Id
.fwdPrc
) OR (pId
.kind
= Id
.fwdMth
) THEN
2244 pId
.resolve
.tgXtn
:= methD
;
2248 (* ============================================================ *)
2250 PROCEDURE (os
: PeFile
)SwitchHead
*(num
: INTEGER);
2253 NEW(switch
.list
, num
);
2256 PROCEDURE (os
: PeFile
)SwitchTail
*();
2258 os
.pePI
.code
.Switch(switch
.list
);
2262 PROCEDURE (os
: PeFile
)LstLab
*(l
: Mu
.Label
);
2265 switch
.list
[switch
.next
] := l
.labl
;
2270 (* ============================================================ *)
2272 PROCEDURE (os
: PeFile
)mth(pId
: Id
.Procs
) : Api
.Method
,NEW;
2274 ASSERT(pId
.tgXtn
# NIL);
2275 RETURN pId
.tgXtn(Api
.Method
);
2278 (* -------------------------------- *)
2280 PROCEDURE (os
: PeFile
)fld(fId
: Id
.AbVar
) : Api
.Field
,NEW;
2281 VAR cDf
: Api
.Class
;
2284 (* ---------------- *)
2285 PROCEDURE AddField(os
: PeFile
;
2288 ty
: Sy
.Type
) : Api
.Field
;
2289 VAR fs
: RTS
.NativeString
;
2292 WITH cl
: Api
.ClassDef
DO
2293 RETURN cl
.AddField(fs
, os
.typ(ty
));
2294 | cl
: Api
.ClassRef
DO
2295 RETURN getOrAddField(cl
, fs
, os
.typ(ty
));
2298 (* ---------------- *)
2300 IF fId
.tgXtn
= NIL THEN
2301 WITH fId
: Id
.VarId
DO
2302 IF fId
.varNm
= NIL THEN Mu
.MkVarName(fId
,os
) END;
2303 IF fId
.recTyp
= NIL THEN (* module variable *)
2304 cDf
:= os
.dsc(fId
.dfScp(Id
.BlkId
));
2305 ELSE (* static field *)
2306 cDf
:= os
.cls(fId
.recTyp(Ty
.Record
));
2310 IF fId
.fldNm
= NIL THEN Mu
.MkFldName(fId
,os
) END;
2311 cDf
:= os
.cls(fId
.recTyp(Ty
.Record
));
2314 fId
.tgXtn
:= AddField(os
, cDf
, fNm
, fId
.type
);
2317 WITH obj
: Api
.Field
DO RETURN obj
;
2318 | obj
: EvtXtn
DO RETURN obj
.fldD
;
2322 (* -------------------------------- *)
2324 PROCEDURE (os
: PeFile
)add(fId
: Id
.AbVar
) : Api
.Method
,NEW;
2325 BEGIN (* returns the descriptor of add_<fieldname> *)
2326 IF (fId
.tgXtn
= NIL) OR ~
(fId
.tgXtn
IS EvtXtn
) THEN MkAddRem(os
, fId
) END;
2327 RETURN fId
.tgXtn(EvtXtn
).addD
;
2330 (* -------------------------------- *)
2332 PROCEDURE (os
: PeFile
)rem(fId
: Id
.AbVar
) : Api
.Method
,NEW;
2333 BEGIN (* returns the descriptor of remove_<fieldname> *)
2334 IF (fId
.tgXtn
= NIL) OR ~
(fId
.tgXtn
IS EvtXtn
) THEN MkAddRem(os
, fId
) END;
2335 RETURN fId
.tgXtn(EvtXtn
).remD
;
2338 (* -------------------------------- *)
2340 PROCEDURE (os
: PeFile
)asm(bId
: Id
.BlkId
) : Api
.AssemblyRef
,NEW;
2341 BEGIN (* returns the assembly reference of this module *)
2342 IF bId
.tgXtn
= NIL THEN os
.DoExtern(bId
) END;
2343 RETURN bId
.tgXtn(BlkXtn
).asmD
;
2346 (* -------------------------------- *)
2348 PROCEDURE (os
: PeFile
)dsc(bId
: Id
.BlkId
) : Api
.Class
,NEW;
2349 BEGIN (* returns descriptor of dummy static class of this module *)
2350 IF bId
.tgXtn
= NIL THEN os
.DoExtern(bId
) END;
2351 RETURN bId
.tgXtn(BlkXtn
).dscD
;
2354 (* -------------------------------- *)
2356 PROCEDURE (os
: PeFile
)cls(rTy
: Ty
.Record
) : Api
.Class
,NEW;
2357 BEGIN (* returns descriptor for this class *)
2358 IF rTy
.tgXtn
= NIL THEN Mu
.MkRecName(rTy
, os
) END;
2359 RETURN rTy
.tgXtn(RecXtn
).clsD
;
2362 (* -------------------------------- *)
2364 * PROCEDURE (os : PeFile)box(rTy : Ty.Record) : Api.Class,NEW;
2366 * IF rTy.tgXtn = NIL THEN Mu.MkRecName(rTy, os) END;
2367 * RETURN rTy.tgXtn(RecXtn).boxD;
2370 (* -------------------------------- *)
2372 PROCEDURE (os
: PeFile
)new(rTy
: Ty
.Record
) : Api
.Method
,NEW;
2373 BEGIN (* returns the ctor for this reference class *)
2374 IF rTy
.tgXtn
= NIL THEN Mu
.MkRecName(rTy
, os
) END;
2375 RETURN rTy
.tgXtn(RecXtn
).newD
;
2378 (* -------------------------------- *)
2380 PROCEDURE (os
: PeFile
)dxt(pTy
: Ty
.Procedure
) : DelXtn
,NEW;
2381 BEGIN (* returns the DelXtn extension for this delegate type *)
2382 IF pTy
.tgXtn
= NIL THEN os
.MkDelX(pTy
, pTy
.idnt
.dfScp
) END;
2383 RETURN pTy
.tgXtn(DelXtn
);
2386 (* -------------------------------- *)
2388 PROCEDURE mkCopyDef(cDf
: Api
.ClassDef
; val
: BOOLEAN) : Api
.Method
;
2389 VAR pra
: POINTER TO ARRAY OF Api
.Param
;
2394 IF val
THEN prd
:= Api
.ManagedPointer
.init(prd
) END;
2395 pra
[0] := Api
.Param
.init(0, "src", prd
);
2396 RETURN cDf
.AddMethod(copyS
, voidD
, pra
);
2399 (* -------------------------------- *)
2401 PROCEDURE (os
: PeFile
)cpy(rTy
: Ty
.Record
) : Api
.Method
,NEW;
2405 typA
: POINTER TO ARRAY OF Api
.Type
;
2408 tXtn
:= rTy
.tgXtn(RecXtn
);
2410 IF tXtn
.cpyD
= NIL THEN
2411 valR
:= Mu
.isValRecord(rTy
);
2412 WITH tCls
: Api
.ClassDef
DO
2413 mthX
:= mkCopyDef(tCls
, valR
);
2414 | tCls
: Api
.ClassRef
DO
2417 typA
[0] := Api
.ManagedPointer
.init(tCls
);
2421 mthX
:= tCls
.AddMethod(copyS
, voidD
, typA
);
2422 mthX
.AddCallConv(Api
.CallConv
.Instance
);
2431 (* -------------------------------- *)
2433 PROCEDURE (os
: PeFile
)vDl(rTy
: Ty
.Record
) : Api
.Field
,NEW;
2434 BEGIN (* returns descriptor of field "v$" for this boxed value type *)
2435 IF rTy
.tgXtn
= NIL THEN Mu
.MkRecName(rTy
, os
) END;
2436 RETURN rTy
.tgXtn(RecXtn
).vDlr
;
2439 (* -------------------------------- *)
2441 PROCEDURE (os
: PeFile
)RescueOpaque(tTy
: Sy
.Type
),NEW;
2445 blk
:= tTy
.idnt
.dfScp(Id
.BlkId
);
2447 ext
:= blk
.tgXtn(BlkXtn
);
2448 (* Set tgXtn to a ClassRef *)
2449 tTy
.tgXtn
:= getOrAddClass(ext
.asmD
, MKSTR(blk
.xName^
), MKSTR(Sy
.getName
.ChPtr(tTy
.idnt
)^
));
2451 (* Just leave tgXtn = NIL *)
2454 (* -------------------------------- *)
2456 PROCEDURE (os
: PeFile
)typ(tTy
: Sy
.Type
) : Api
.Type
,NEW;
2458 BEGIN (* returns Api.Type descriptor for this type *)
2459 IF tTy
.tgXtn
= NIL THEN Mu
.MkTypeName(tTy
, os
) END;
2460 IF (tTy
IS Ty
.Opaque
) & (tTy
.tgXtn
= NIL) THEN os
.RescueOpaque(tTy(Ty
.Opaque
)) END;
2463 IF tTy
.xName
# NIL THEN tTy
.TypeErrStr(236, tTy
.xName
);
2464 ELSE tTy
.TypeError(236);
2466 RTS
.Throw("Opaque Type Error");
2468 WITH xtn
: Api
.Type
DO
2477 (* ============================================================ *)
2479 PROCEDURE (os
: PeFile
)mcd() : Api
.ClassRef
,NEW;
2480 BEGIN (* returns System.MulticastDelegate *)
2481 IF multiCD
= NIL THEN
2482 multiCD
:= getOrAddClass(corlib
, "System", "MulticastDelegate");
2487 (* ============================================================ *)
2489 PROCEDURE (os
: PeFile
)del() : Api
.ClassRef
,NEW;
2490 BEGIN (* returns System.Delegate *)
2491 IF delegat
= NIL THEN
2492 delegat
:= getOrAddClass(corlib
, "System", "Delegate");
2497 (* ============================================================ *)
2499 PROCEDURE (os
: PeFile
)rmv() : Api
.MethodRef
,NEW;
2500 VAR prs
: POINTER TO ARRAY OF Api
.Type
;
2502 BEGIN (* returns System.Delegate::Remove *)
2503 IF remove
= NIL THEN
2508 remove
:= dlg
.AddMethod("Remove", dlg
, prs
);
2513 (* ============================================================ *)
2515 PROCEDURE (os
: PeFile
)cmb() : Api
.MethodRef
,NEW;
2516 VAR prs
: POINTER TO ARRAY OF Api
.Type
;
2518 BEGIN (* returns System.Delegate::Combine *)
2519 IF combine
= NIL THEN
2524 combine
:= dlg
.AddMethod("Combine", dlg
, prs
);
2529 (* ============================================================ *)
2530 (* ============================================================ *)
2532 evtAdd
:= Lv
.strToCharOpen("add_");
2533 evtRem
:= Lv
.strToCharOpen("remove_");
2534 cln2
:= Lv
.strToCharOpen("::");
2535 boxedObj
:= Lv
.strToCharOpen("Boxed_");
2537 vfldS
:= MKSTR("v$");
2538 ctorS
:= MKSTR(".ctor");
2539 invkS
:= MKSTR("Invoke");
2540 copyS
:= MKSTR("__copy__");
2542 (* ============================================================ *)
2543 (* ============================================================ *)