DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / gpcp-linux.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Remove batch
[gpcp-linux.git] / gpcp / PeUtilForNET.cp
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 (* ============================================================ *)
9
10 MODULE PeUtil;
11
12 IMPORT
13 GPCPcopyright,
14 RTS, ASCII,
15 Console,
16 GPText,
17 GPBinFiles,
18 GPTextFiles,
19 FileNames,
20 ClassMaker,
21 MsilBase,
22 NameHash,
23 Mu := MsilUtil,
24 Lv := LitValue,
25 Sy := Symbols,
26 Bi := Builtin,
27 Id := IdDesc,
28 Ty := TypeDesc,
29 Api := "[QUT.PERWAPI]QUT.PERWAPI",
30 Scn := CPascalS,
31 Asm := IlasmCodes,
32 CSt := CompState,
33 Sys := "[mscorlib]System";
34
35 (* ============================================================ *)
36
37 (*
38 * CONST
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() ";
46 *
47 * CONST
48 * catchStr = " catch [mscorlib]System.Exception";
49 *)
50
51 (* ============================================================ *)
52 (* ============================================================ *)
53
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 *)
58 * proc* : ProcInfo;
59 *)
60 peFl : Api.PEFile; (* Includes AssemblyDef *)
61 clsS : Api.ClassDef; (* Dummy static ClassDef *)
62 clsD : Api.ClassDef; (* The current ClassDef *)
63 pePI : PProcInfo;
64 nmSp : RTS.NativeString;
65 (*
66 * Friendly access for system classes.
67 *)
68 rts : Api.AssemblyRef; (* "[RTS]" *)
69 cprts : Api.ClassRef; (* "[RTS]CP_rts" *)
70 progArgs : Api.ClassRef; (* "[RTS]ProgArgs" *)
71 END;
72
73 (* ============================================================ *)
74
75 TYPE PProcInfo = POINTER TO RECORD
76 mthD : Api.MethodDef;
77 code : Api.CILInstructions;
78 tryB : Api.TryBlock;
79 END;
80
81 (* ============================================================ *)
82
83 TYPE PeLab = POINTER TO RECORD (Mu.Label)
84 labl : Api.CILLabel;
85 END;
86
87 TYPE TypArr = POINTER TO ARRAY OF Api.Type;
88
89 (* ============================================================ *)
90
91 VAR cln2, (* "::" *)
92 evtAdd,
93 evtRem,
94 boxedObj : Lv.CharOpen;
95
96 (* ============================================================ *)
97
98 VAR ctAtt, (* public + special + RTspecial *)
99 psAtt, (* public + static *)
100 rmAtt, (* runtime managed *)
101 ilAtt : INTEGER; (* cil managed *)
102
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 *)
114
115 VAR vfldS : RTS.NativeString; (* "v$" *)
116 copyS : RTS.NativeString; (* "copy" *)
117 ctorS : RTS.NativeString; (* ".ctor" *)
118 invkS : RTS.NativeString; (* Invoke *)
119
120 VAR defSrc : Api.SourceFile;
121
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] *)
134
135 (* ============================================================ *)
136 (* Data Structure for tgXtn field of BlkId descriptors *)
137 (* ============================================================ *)
138
139 TYPE BlkXtn = POINTER TO RECORD
140 asmD : Api.AssemblyRef; (* This AssemblyRef *)
141 dscD : Api.Class; (* Dummy Static Class *)
142 END;
143
144 (* ============================================================ *)
145 (* Data Structure for Switch Statement Encoding *)
146 (* ============================================================ *)
147
148 TYPE Switch = RECORD
149 list : POINTER TO ARRAY OF Api.CILLabel;
150 next : INTEGER;
151 END;
152
153 VAR switch : Switch;
154
155 (* ============================================================ *)
156 (* Data Structure for tgXtn field of procedure types *)
157 (* ============================================================ *)
158
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 *)
163 END;
164
165 (* ============================================================ *)
166 (* Data Structure for tgXtn field of event variables *)
167 (* ============================================================ *)
168
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 *)
173 END;
174
175 (* ============================================================ *)
176 (* Data Structure for tgXtn field of Record types *)
177 (* ============================================================ *)
178
179 TYPE RecXtn = POINTER TO RECORD
180 clsD : Api.Class;
181 boxD : Api.Class;
182 newD : Api.Method;
183 cpyD : Api.Method;
184 vDlr : Api.Field;
185 END;
186
187 (* ============================================================ *)
188 (* Constructor Method *)
189 (* ============================================================ *)
190
191 PROCEDURE newPeFile*(IN nam : ARRAY OF CHAR; isDll : BOOLEAN) : PeFile;
192 VAR f : PeFile;
193 ver : INTEGER;
194 (* ------------------------------------------------------- *)
195 PROCEDURE file(IN f,a : ARRAY OF CHAR; d : BOOLEAN) : Api.PEFile;
196 VAR pef : Api.PEFile;
197 BEGIN
198 pef := Api.PEFile.init(MKSTR(f), MKSTR(a));
199 pef.SetIsDLL(d);
200 IF CSt.binDir # "" THEN
201 pef.SetOutputDirectory(MKSTR(CSt.binDir));
202 END;
203 RETURN pef;
204 RESCUE (x)
205 RETURN NIL;
206 END file;
207 (* ------------------------------------------------------- *)
208 BEGIN
209 NEW(f);
210 (*
211 * f.peFl := file(nam, isDll);
212 *)
213 IF isDll THEN
214 f.outN := BOX(nam + ".DLL");
215 ELSE
216 f.outN := BOX(nam + ".EXE");
217 END;
218 (* -- start replacement -- *)
219 f.peFl := file(f.outN, nam, isDll);
220 (* --- end replacement --- *)
221 (*
222 * Initialize local variables holding common attributes.
223 *)
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;
228 (*
229 * Initialize local variables holding primitive type-enums.
230 *)
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;
241
242 f.peFl.SetNetVersion(Api.NetVersion.Version2);
243
244 (*ver := f.peFl.GetNetVersion();*)
245
246 RETURN f;
247 END newPeFile;
248
249 (* ============================================================ *)
250
251 PROCEDURE (t : PeFile)fileOk*() : BOOLEAN;
252 BEGIN
253 RETURN t.peFl # NIL;
254 END fileOk;
255
256 (* ============================================================ *)
257
258 PROCEDURE (os : PeFile)MkNewProcInfo*(proc : Sy.Scope);
259 VAR p : PProcInfo;
260 BEGIN
261 NEW(os.proc);
262 NEW(os.pePI);
263 Mu.InitProcInfo(os.proc, proc);
264 END MkNewProcInfo;
265
266 (* ============================================================ *)
267
268 PROCEDURE (os : PeFile)newLabel*() : Mu.Label;
269 VAR label : PeLab;
270 BEGIN
271 NEW(label);
272 label.labl := os.pePI.code.NewLabel();
273 RETURN label;
274 END newLabel;
275
276 (* ============================================================ *)
277 (* Various utilities *)
278 (* ============================================================ *)
279
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;
284
285 PROCEDURE^ MkMthDef(os : PeFile;
286 xhr : BOOLEAN;
287 pTp : Ty.Procedure;
288 cls : Api.ClassDef;
289 str : RTS.NativeString) : Api.MethodDef;
290
291 PROCEDURE^ MkMthRef(os : PeFile;
292 pTp : Ty.Procedure;
293 cls : Api.ClassRef;
294 str : RTS.NativeString) : Api.MethodRef;
295
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;
311 (*
312 * PROCEDURE^ box(os : PeFile; rTy : Ty.Record) : Api.Class;
313 *)
314 (* ============================================================ *)
315 (* Private Methods *)
316 (* ============================================================ *)
317
318 PROCEDURE boxedName(typ : Ty.Record) : RTS.NativeString;
319 BEGIN
320 ASSERT(typ.xName # NIL);
321 RETURN MKSTR(boxedObj^ + typ.xName^);
322 END boxedName;
323
324 (* ============================================================ *)
325
326 PROCEDURE nms(idD : Sy.Idnt) : RTS.NativeString;
327 BEGIN
328 RETURN MKSTR(Sy.getName.ChPtr(idD)^);
329 END nms;
330
331 (* ============================================================ *)
332
333 PROCEDURE toTypeAttr(attr : SET) : INTEGER;
334 VAR result : INTEGER;
335 BEGIN
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;
339 END;
340 IF attr * Asm.att_sealed # {} THEN
341 INC(result, Api.TypeAttr.Sealed);
342 END;
343 IF attr * Asm.att_abstract # {} THEN
344 INC(result, Api.TypeAttr.Abstract);
345 END;
346 IF attr * Asm.att_interface # {} THEN
347 INC(result, Api.TypeAttr.Interface + Api.TypeAttr.Abstract);
348 END;
349 (*
350 * what are "Import, AutoClass, UnicodeClass, *SpecialName" ?
351 *)
352 RETURN result;
353 END toTypeAttr;
354
355
356 (* ------------------------------------------------ *)
357 (* New code for PERWAPI *)
358 (* ------------------------------------------------ *)
359
360 PROCEDURE getOrAddClass(mod : Api.ReferenceScope;
361 nms : RTS.NativeString;
362 nam : RTS.NativeString) : Api.ClassRef;
363 VAR cls : Api.Class;
364 BEGIN
365 cls := mod.GetClass(nms, nam);
366 IF cls = NIL THEN cls := mod.AddClass(nms, nam) END;
367 RETURN cls(Api.ClassRef);
368 END getOrAddClass;
369
370 PROCEDURE getOrAddValueClass(mod : Api.ReferenceScope;
371 nms : RTS.NativeString;
372 nam : RTS.NativeString) : Api.ClassRef;
373 VAR cls : Api.Class;
374 BEGIN
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;
379
380 PROCEDURE getOrAddMethod(cls : Api.ClassRef;
381 nam : RTS.NativeString;
382 ret : Api.Type;
383 prs : TypArr) : Api.MethodRef;
384 VAR mth : Api.Method;
385 BEGIN
386 mth := cls.GetMethod(nam, prs);
387 IF mth = NIL THEN mth := cls.AddMethod(nam, ret, prs) END;
388 RETURN mth(Api.MethodRef);
389 END getOrAddMethod;
390
391 PROCEDURE getOrAddField(cls : Api.ClassRef;
392 nam : RTS.NativeString;
393 typ : Api.Type) : Api.FieldRef;
394 VAR fld : Api.FieldRef;
395 BEGIN
396 fld := cls.GetField(nam);
397 IF fld = NIL THEN fld := cls.AddField(nam, typ) END;
398 RETURN fld(Api.FieldRef);
399 END getOrAddField;
400
401 (* ------------------------------------------------ *)
402
403 PROCEDURE toMethAttr(attr : SET) : INTEGER;
404 VAR result : INTEGER;
405 BEGIN
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;
411 END;
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;
417 RETURN result;
418 END toMethAttr;
419
420 (* ------------------------------------------------ *)
421
422 PROCEDURE toFieldAttr(attr : SET) : INTEGER;
423 VAR result : INTEGER;
424 BEGIN
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;
431 END;
432 IF 5 IN attr THEN INC(result, Api.FieldAttr.Static) END;
433 (* what about Initonly? *)
434 RETURN result;
435 END toFieldAttr;
436
437 (* ------------------------------------------------ *)
438
439 PROCEDURE (os : PeFile)MkCodeBuffer(),NEW;
440 BEGIN
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);
445 END MkCodeBuffer;
446
447 (* ============================================================ *)
448 (* Exported Methods *)
449 (* ============================================================ *)
450
451 PROCEDURE (os : PeFile)MethodDecl*(attr : SET; proc : Id.Procs);
452 VAR prcT : Ty.Procedure; (* NOT NEEDED? *)
453 prcD : Api.MethodDef;
454 BEGIN
455 (*
456 * Set the various attributes
457 *)
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;
463 END MethodDecl;
464
465 (* -------------------------------------------- *)
466
467 PROCEDURE (os : PeFile)DoExtern(blk : Id.BlkId),NEW;
468 (*
469 * Add references to all imported assemblies.
470 *)
471 VAR asmRef : Api.AssemblyRef;
472 blkXtn : BlkXtn;
473 (* ----------------------------------------- *)
474 PROCEDURE AsmName(bk : Id.BlkId) : Lv.CharOpen;
475 VAR ix : INTEGER;
476 ln : INTEGER;
477 ch : CHAR;
478 cp : Lv.CharOpen;
479 BEGIN
480 IF Sy.isFn IN bk.xAttr THEN
481 ln := 0;
482 FOR ix := LEN(bk.scopeNm) - 1 TO 1 BY -1 DO
483 IF bk.scopeNm[ix] = "]" THEN ln := ix END;
484 END;
485 IF (ln = 0 ) OR (bk.scopeNm[0] # '[') THEN
486 RTS.Throw("bad extern name "+bk.scopeNm^) END;
487 NEW(cp, ln);
488 FOR ix := 1 TO ln-1 DO cp[ix-1] := bk.scopeNm[ix] END;
489 cp[ln-1] := 0X;
490 RETURN cp;
491 ELSE
492 RETURN bk.xName;
493 END;
494 END AsmName;
495 (* ----------------------------------------- *)
496 PROCEDURE MkBytes(t1, t2 : INTEGER) : POINTER TO ARRAY OF UBYTE;
497 VAR bIx : INTEGER;
498 tok : POINTER TO ARRAY OF UBYTE;
499 BEGIN [UNCHECKED_ARITHMETIC]
500 NEW(tok, 8);
501 FOR bIx := 3 TO 0 BY -1 DO
502 tok[bIx] := USHORT(t1 MOD 256);
503 t1 := t1 DIV 256;
504 END;
505 FOR bIx := 7 TO 4 BY -1 DO
506 tok[bIx] := USHORT(t2 MOD 256);
507 t2 := t2 DIV 256;
508 END;
509 RETURN tok;
510 END MkBytes;
511 (* ----------------------------------------- *)
512 BEGIN
513 IF blk.xName = NIL THEN Mu.MkBlkName(blk) END;
514 asmRef := os.peFl.MakeExternAssembly(MKSTR(AsmName(blk)^));
515 NEW(blkXtn);
516 blk.tgXtn := blkXtn;
517 blkXtn.asmD := asmRef;
518 blkXtn.dscD := getOrAddClass(asmRef,
519 MKSTR(blk.pkgNm^),
520 MKSTR(blk.clsNm^));
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]));
526 END;
527 END;
528 END DoExtern;
529
530 (* ============================================================ *)
531
532 PROCEDURE (os : PeFile)DoRtsMod(blk : Id.BlkId),NEW;
533 (*
534 * Add references to all imported assemblies.
535 *)
536 VAR blkD : BlkXtn;
537 BEGIN
538 IF blk.xName = NIL THEN Mu.MkBlkName(blk) END;
539 NEW(blkD);
540 blkD.asmD := os.rts;
541 blkD.dscD := os.rts.AddClass("", MKSTR(blk.clsNm^));
542 blk.tgXtn := blkD;
543 END DoRtsMod;
544
545 (* ============================================================ *)
546
547 PROCEDURE (os : PeFile)CheckNestedClass*(typ : Ty.Record;
548 scp : Sy.Scope;
549 str : Lv.CharOpen);
550 VAR len : INTEGER;
551 idx : INTEGER;
552 jdx : INTEGER;
553 kdx : INTEGER;
554 hsh : INTEGER;
555 tId : Sy.Idnt;
556 BEGIN
557 (*
558 * Find last occurrence of '$', except at index 0
559 *
560 * We seek the last occurrence because this method might
561 * be called recursively for a deeply nested class A$B$C.
562 *)
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);
569
570 IF (tId = NIL) OR ~(tId IS Id.TypId) THEN
571 RTS.Throw(
572 "Foreign Class <" + str^ + "> not found in <" + typ.extrnNm^ + ">"
573 );
574 ELSE
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;
578 END;
579 RETURN;
580 END;
581 END;
582 END CheckNestedClass;
583
584 (* ============================================================ *)
585
586 PROCEDURE (os : PeFile)ExternList*();
587 VAR idx : INTEGER;
588 blk : Id.BlkId;
589 BEGIN
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
595 os.DoExtern(blk);
596 ELSE
597 os.DoRtsMod(blk);
598 END;
599 END;
600 END;
601 END ExternList;
602
603 (* ============================================================ *)
604
605 PROCEDURE (os : PeFile)DefLab*(l : Mu.Label);
606 BEGIN
607 os.pePI.code.CodeLabel(l(PeLab).labl);
608 END DefLab;
609
610 (* -------------------------------------------- *)
611
612 PROCEDURE (os : PeFile)DefLabC*(l : Mu.Label; IN c : ARRAY OF CHAR);
613 BEGIN
614 os.pePI.code.CodeLabel(l(PeLab).labl);
615 END DefLabC;
616
617 (* ============================================================ *)
618
619 PROCEDURE (os : PeFile)Code*(code : INTEGER);
620 BEGIN
621 os.pePI.code.Inst(Asm.cd[code]);
622 os.Adjust(Asm.dl[code]);
623 END Code;
624
625 (* -------------------------------------------- *)
626
627 PROCEDURE (os : PeFile)CodeF(code : INTEGER;
628 fld : Api.Field), NEW;
629 BEGIN
630 os.pePI.code.FieldInst(Asm.cd[code], fld);
631 os.Adjust(Asm.dl[code]);
632 END CodeF;
633
634 (* -------------------------------------------- *)
635
636 PROCEDURE (os : PeFile)CodeI*(code,int : INTEGER);
637 BEGIN
638 os.pePI.code.IntInst(Asm.cd[code],int);
639 os.Adjust(Asm.dl[code]);
640 END CodeI;
641
642 (* -------------------------------------------- *)
643
644 PROCEDURE (os : PeFile)CodeT*(code : INTEGER; type : Sy.Type);
645 VAR xtn : Api.Type;
646 BEGIN
647 xtn := os.typ(type);
648 os.pePI.code.TypeInst(Asm.cd[code], xtn);
649 os.Adjust(Asm.dl[code]);
650 END CodeT;
651
652 (* -------------------------------------------- *)
653
654 PROCEDURE (os : PeFile)CodeTn*(code : INTEGER; type : Sy.Type);
655 VAR xtn : Api.Type;
656 BEGIN
657 xtn := os.typ(type);
658 os.pePI.code.TypeInst(Asm.cd[code], xtn);
659 os.Adjust(Asm.dl[code]);
660 END CodeTn;
661
662 (* -------------------------------------------- *)
663
664 PROCEDURE (os : PeFile)CodeL*(code : INTEGER; long : LONGINT);
665 BEGIN
666 ASSERT(code = Asm.opc_ldc_i8);
667 os.pePI.code.ldc_i8(long);
668 os.Adjust(1);
669 END CodeL;
670
671 (* -------------------------------------------- *)
672
673 PROCEDURE (os : PeFile)CodeR*(code : INTEGER; real : REAL);
674 BEGIN
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));
679 ELSE
680 ASSERT(FALSE);
681 END;
682 os.Adjust(1);
683 END CodeR;
684
685 (* -------------------------------------------- *)
686
687 PROCEDURE (os : PeFile)CodeLb*(code : INTEGER; labl : Mu.Label);
688 BEGIN
689 os.pePI.code.Branch(Asm.cd[code], labl(PeLab).labl);
690 END CodeLb;
691
692 (* ============================================================ *)
693
694 PROCEDURE (os : PeFile)getMethod(s : INTEGER) : Api.Method,NEW;
695 VAR mth : Api.MethodRef;
696 cpr : Api.ClassRef;
697 msc : Api.ClassRef;
698 sys : Api.ClassRef;
699 (* ----------------------------------- *)
700 PROCEDURE p1(p : Api.Type) : TypArr;
701 VAR a : TypArr;
702 BEGIN
703 NEW(a,1);
704 a[0] := p;
705 RETURN a;
706 END p1;
707 (* ----------------------------------- *)
708 PROCEDURE p2(p,q : Api.Type) : TypArr;
709 VAR a : TypArr;
710 BEGIN
711 NEW(a,2);
712 a[0] := p;
713 a[1] := q;
714 RETURN a;
715 END p2;
716 (* ----------------------------------- *)
717 BEGIN
718 (*
719 * Lazy evaluation of array elements
720 *)
721 mth := rHelper[s];
722 IF mth = NIL THEN
723 cpr := os.cprts;
724 CASE s OF
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));
743
744 | Mu.toUpper : sys := getOrAddClass(corlib, "System", "Char");
745 mth := getOrAddMethod(sys,"ToUpper",charD,p1(charD));
746
747 | Mu.sysExit : IF envrCls = NIL THEN
748 envrCls :=
749 getOrAddClass(corlib, "System", "Environment");
750 END;
751 mth := getOrAddMethod(envrCls,"Exit",voidD,p1(int4D));
752
753 | Mu.mkExcept : IF excpCls = NIL THEN
754 IF CSt.ntvExc.tgXtn = NIL THEN
755 excpCls :=
756 getOrAddClass(corlib, "System", "Exception");
757 CSt.ntvExc.tgXtn := excpCls;
758 ELSE
759 excpCls := CSt.ntvExc.tgXtn(Api.ClassRef);
760 END;
761 END;
762 sys := CSt.ntvExc.tgXtn(Api.ClassRef);
763 (*
764 * mth := sys.AddMethod(ctorS,voidD,p1(strgD));
765 *)
766 mth := getOrAddMethod(sys,ctorS,voidD,p1(strgD));
767 mth.AddCallConv(Api.CallConv.Instance);
768
769 | Mu.getTpM : IF CSt.ntvTyp.tgXtn = NIL THEN
770 CSt.ntvTyp.tgXtn :=
771 getOrAddClass(corlib, "System", "Type");
772 END;
773 sys := CSt.ntvTyp.tgXtn(Api.ClassRef);
774 mth := getOrAddMethod(sys,"GetType",sys,NIL);
775 mth.AddCallConv(Api.CallConv.Instance);
776
777 | Mu.dFloor, Mu.dAbs, Mu.fAbs, Mu.iAbs, Mu.lAbs :
778 IF mathCls = NIL THEN
779 mathCls := getOrAddClass(corlib, "System", "Math");
780 END;
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));
786 mth := rHelper[s];
787 END;
788 rHelper[s] := mth;
789 END;
790 RETURN mth;
791 END getMethod;
792
793 (* -------------------------------------------- *)
794
795 PROCEDURE (os : PeFile)StaticCall*(s : INTEGER; d : INTEGER);
796 VAR mth : Api.Method;
797 BEGIN
798 mth := os.getMethod(s);
799 os.pePI.code.MethInst(Asm.cd[Asm.opc_call], mth);
800 os.Adjust(d);
801 END StaticCall;
802
803 (* -------------------------------------------- *)
804
805 PROCEDURE (os : PeFile)CodeS*(code : INTEGER; str : INTEGER);
806 VAR mth : Api.Method;
807 BEGIN
808 mth := os.getMethod(str);
809 os.pePI.code.MethInst(Asm.cd[code], mth);
810 END CodeS;
811
812 (* ============================================================ *)
813
814 PROCEDURE (os : PeFile)Try*();
815 VAR retT : Sy.Type;
816 BEGIN
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();
821 END Try;
822
823 (* -------------------------------------------- *)
824
825 PROCEDURE (os : PeFile)Catch*(proc : Id.Procs);
826 BEGIN
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);
831 END Catch;
832
833 (* -------------------------------------------- *)
834
835 PROCEDURE (os : PeFile)CloseCatch*();
836 BEGIN
837 IF excpCls = NIL THEN
838 IF CSt.ntvExc.tgXtn = NIL THEN
839 excpCls := getOrAddClass(corlib, "System", "Exception");
840 CSt.ntvExc.tgXtn := excpCls;
841 ELSE
842 excpCls := CSt.ntvExc.tgXtn(Api.ClassRef);
843 END;
844 END;
845 os.pePI.code.EndCatchBlock(excpCls, os.pePI.tryB);
846 END CloseCatch;
847
848 (* -------------------------------------------- *)
849
850 PROCEDURE (os : PeFile)CopyCall*(typ : Ty.Record);
851 BEGIN
852 os.pePI.code.MethInst(Asm.cd[Asm.opc_call], os.cpy(typ));
853 os.Adjust(-2);
854 END CopyCall;
855
856 (* -------------------------------------------- *)
857
858 PROCEDURE (os : PeFile)PushStr*(IN str : ARRAY OF CHAR);
859 (* Use target quoting conventions for the literal string *)
860 BEGIN
861 (* os.pePI.code.ldstr(MKSTR(str)); *)
862 os.pePI.code.ldstr(Sys.String.init(BOX(str), 0, LEN(str) - 1));
863 os.Adjust(1);
864 END PushStr;
865
866 (* ============================================================ *)
867
868 PROCEDURE (os : PeFile)CallIT*(code : INTEGER;
869 proc : Id.Procs;
870 type : Ty.Procedure);
871 VAR xtn : Api.Method;
872 BEGIN
873 xtn := os.mth(proc);
874 os.pePI.code.MethInst(Asm.cd[code], xtn);
875 os.Adjust(type.retN - type.argN);
876 END CallIT;
877
878 (* ============================================================ *)
879
880 PROCEDURE (os : PeFile)CallCT*(proc : Id.Procs;
881 type : Ty.Procedure);
882 VAR xtn : Api.Method;
883 BEGIN
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);
888 END CallCT;
889
890 (* ============================================================ *)
891
892 PROCEDURE (os : PeFile)CallDelegate*(typ : Ty.Procedure);
893 VAR xtn : Api.Method;
894 BEGIN
895 ASSERT(typ.tgXtn # NIL);
896 (*
897 * xtn := typ.tgXtn(DelXtn).invD;
898 *)
899 xtn := os.dxt(typ).invD;
900 os.pePI.code.MethInst(Asm.cd[Asm.opc_callvirt], xtn);
901 os.Adjust(-typ.argN + typ.retN);
902 END CallDelegate;
903
904 (* ============================================================ *)
905
906 PROCEDURE (os : PeFile)PutGetS*(code : INTEGER;
907 blk : Id.BlkId;
908 fId : Id.VarId);
909 (* Emit putstatic and getstatic for static field *)
910 BEGIN
911 os.pePI.code.FieldInst(Asm.cd[code], os.fld(fId));
912 os.Adjust(Asm.dl[code]);
913 END PutGetS;
914
915 (* -------------------------------------------- *)
916
917 PROCEDURE (os : PeFile)GetValObj*(code : INTEGER; ptrT : Ty.Pointer);
918 VAR rTp : Ty.Record;
919 BEGIN
920 rTp := ptrT.boundRecTp()(Ty.Record);
921 os.pePI.code.FieldInst(Asm.cd[code], os.vDl(rTp));
922 os.Adjust(Asm.dl[code]);
923 END GetValObj;
924
925 (* -------------------------------------------- *)
926
927 PROCEDURE (os : PeFile)PutGetXhr*(code : INTEGER;
928 proc : Id.Procs;
929 locl : Id.LocId);
930 VAR ix : INTEGER;
931 name : Lv.CharOpen;
932 recT : Ty.Record;
933 fldI : Id.FldId;
934 BEGIN
935 ix := 0;
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)));
939 END PutGetXhr;
940
941 (* -------------------------------------------- *)
942
943 PROCEDURE (os : PeFile)PutGetF*(code : INTEGER;
944 fId : Id.FldId);
945 BEGIN
946 os.pePI.code.FieldInst(Asm.cd[code], os.fld(fId));
947 os.Adjust(Asm.dl[code]);
948 END PutGetF;
949
950 (* ============================================================ *)
951 (* ============================================================ *)
952
953 PROCEDURE (os : PeFile)MkNewRecord*(typ : Ty.Record);
954 CONST code = Asm.opc_newobj;
955 VAR name : Lv.CharOpen;
956 BEGIN
957 (*
958 * We need "newobj instance void <name>::.ctor()"
959 *)
960 os.pePI.code.MethInst(Asm.cd[code], os.new(typ));
961 os.Adjust(1);
962 END MkNewRecord;
963
964 (* ============================================================ *)
965 (* ============================================================ *)
966
967 PROCEDURE (os : PeFile)MkNewProcVal*(p : Sy.Idnt; (* src Proc *)
968 t : Sy.Type); (* dst Type *)
969 VAR ctor : Api.Method;
970 ldfi : INTEGER;
971 pTyp : Ty.Procedure;
972 proc : Id.Procs;
973 BEGIN
974 (*
975 * ctor := t.tgXtn(DelXtn).newD;
976 *)
977 proc := p(Id.Procs);
978 pTyp := t(Ty.Procedure);
979 ctor := os.dxt(pTyp).newD;
980 (*
981 * We need "ldftn [instance] <retType> <procName>
982 *)
983 WITH p : Id.MthId DO
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;
988 ELSE
989 ldfi := Asm.opc_ldvirtftn;
990 END;
991 ELSE
992 ldfi := Asm.opc_ldftn;
993 END;
994 (*
995 * These next are needed for imported events
996 *)
997 Mu.MkProcName(proc, os);
998 os.NumberParams(proc, pTyp);
999 (*
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.
1003 *)
1004 IF ldfi = Asm.opc_ldvirtftn THEN os.Code(Asm.opc_dup) END;
1005 os.pePI.code.MethInst(Asm.cd[ldfi], os.mth(proc));
1006 os.Adjust(1);
1007 (*
1008 * Now we need "newobj instance void <name>::.ctor(...)"
1009 *)
1010 os.pePI.code.MethInst(Asm.cd[Asm.opc_newobj], ctor);
1011 os.Adjust(-2);
1012 END MkNewProcVal;
1013
1014 (* ============================================================ *)
1015
1016 PROCEDURE (os : PeFile)CallSuper*(rTp : Ty.Record;
1017 prc : Id.PrcId);
1018 VAR pNm : INTEGER;
1019 spr : Api.Method;
1020 (* ---------------------------------------- *)
1021 PROCEDURE getSuperCtor(os : PeFile;
1022 rTp : Ty.Record;
1023 prc : Id.Procs) : Api.Method;
1024 VAR bas : Ty.Record;
1025 pTp : Ty.Procedure;
1026 bcl : Api.Class;
1027 mth : Api.Method;
1028 BEGIN
1029 bas := rTp.superType();
1030 IF prc # NIL THEN
1031 (*
1032 * This constructor has arguments.
1033 * The super constructor is prc.basCll.sprCtor
1034 *)
1035 pTp := prc.type(Ty.Procedure);
1036 IF prc.tgXtn = NIL THEN
1037 bcl := os.cls(bas);
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);
1043 END;
1044 mth.AddCallConv(Api.CallConv.Instance);
1045 prc.tgXtn := mth;
1046 RETURN mth;
1047 ELSE
1048 RETURN prc.tgXtn(Api.Method);
1049 END;
1050 ELSIF (bas # NIL) & (rTp.baseTp # Bi.anyRec) THEN
1051 (*
1052 * This is the explicit noarg constructor of the supertype.
1053 *)
1054 RETURN os.new(bas);
1055 ELSE
1056 (*
1057 * This is System.Object::.ctor()
1058 *)
1059 RETURN newObjt;
1060 END;
1061 END getSuperCtor;
1062 (* ---------------------------------------- *)
1063 BEGIN
1064 IF prc # NIL THEN
1065 pNm := prc.type(Ty.Procedure).formals.tide;
1066 ELSE
1067 pNm := 0;
1068 END;
1069 spr := getSuperCtor(os, rTp, prc);
1070 os.pePI.code.MethInst(Asm.cd[Asm.opc_call], spr);
1071 os.Adjust(-(pNm+1));
1072 END CallSuper;
1073
1074 (* ============================================================ *)
1075
1076 PROCEDURE (os : PeFile)InitHead*(rTp : Ty.Record;
1077 prc : Id.PrcId);
1078 VAR mDf : Api.MethodDef;
1079 cDf : Api.ClassDef;
1080 BEGIN
1081 cDf := os.cls(rTp)(Api.ClassDef);
1082
1083 IF prc # NIL THEN
1084 mDf := prc.tgXtn(Api.MethodDef);
1085 mDf.AddMethAttribute(ctAtt);
1086 ELSE
1087 mDf := os.new(rTp)(Api.MethodDef);
1088 END;
1089 os.pePI.mthD := mDf;
1090 os.MkCodeBuffer();
1091 mDf.AddCallConv(Api.CallConv.Instance);
1092 (*
1093 * Now we initialize the supertype;
1094 *)
1095 os.Code(Asm.opc_ldarg_0);
1096 END InitHead;
1097
1098 (* ============================================================ *)
1099
1100 PROCEDURE (os : PeFile)CopyHead*(typ : Ty.Record);
1101 VAR mDf : Api.MethodDef;
1102 cDf : Api.ClassDef;
1103 par : Id.ParId;
1104 prs : POINTER TO ARRAY OF Id.ParId;
1105 BEGIN
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;
1112 os.MkCodeBuffer();
1113 END CopyHead;
1114
1115 (* ============================================================ *)
1116
1117 PROCEDURE (os : PeFile)MarkInterfaces*(IN seq : Sy.TypeSeq);
1118 VAR index : INTEGER;
1119 tideX : INTEGER;
1120 implT : Ty.Record;
1121 BEGIN
1122 tideX := seq.tide-1;
1123 ASSERT(tideX >= 0);
1124 FOR index := 0 TO tideX DO
1125 implT := seq.a[index].boundRecTp()(Ty.Record);
1126 os.clsD.AddImplementedInterface(os.cls(implT));
1127 END;
1128 END MarkInterfaces;
1129
1130 (* ============================================================ *)
1131
1132 PROCEDURE (os : PeFile)MainHead*(xAtt : SET);
1133 VAR mthD : Api.MethodDef;
1134
1135 VAR strA : Api.Type;
1136 list : Api.Field;
1137 pars : POINTER TO ARRAY OF Api.Param;
1138 BEGIN
1139 NEW(pars, 1);
1140 strA := Api.ZeroBasedArray.init(strgD);
1141 pars[0] := Api.Param.init(0, "@args", strA);
1142
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);
1147 END;
1148 os.pePI.mthD := mthD;
1149 os.MkCodeBuffer();
1150 mthD.DeclareEntryPoint();
1151 IF CSt.debug THEN os.LineSpan(Scn.mkSpanT(CSt.thisMod.begTok)) END;
1152 (*
1153 * Save the command-line arguments to the RTS.
1154 *)
1155 os.Code(Asm.opc_ldarg_0);
1156 os.CodeF(Asm.opc_stsfld, os.fld(CSt.argLst));
1157 END MainHead;
1158
1159 (* ============================================================ *)
1160
1161 PROCEDURE (os : PeFile)SubSys*(xAtt : SET);
1162 BEGIN
1163 IF Sy.wMain IN xAtt THEN os.peFl.SetSubSystem(2) END;
1164 END SubSys;
1165
1166 (* ============================================================ *)
1167
1168 PROCEDURE (os : PeFile)StartBoxClass*(rec : Ty.Record;
1169 att : SET;
1170 blk : Id.BlkId);
1171 VAR mthD : Api.MethodDef;
1172 sprC : Api.Method;
1173 boxC : Api.ClassDef;
1174 BEGIN
1175 boxC := rec.tgXtn(RecXtn).boxD(Api.ClassDef);
1176 boxC.AddAttribute(toTypeAttr(att));
1177
1178 (*
1179 * Emit the no-arg constructor
1180 *)
1181 os.MkNewProcInfo(blk);
1182 mthD := os.new(rec)(Api.MethodDef);
1183 os.pePI.mthD := mthD;
1184 os.MkCodeBuffer();
1185 mthD.AddCallConv(Api.CallConv.Instance);
1186
1187 os.Code(Asm.opc_ldarg_0);
1188 sprC := newObjt;
1189
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);
1194 os.Locals();
1195 os.InitTail(rec);
1196 os.pePI := NIL;
1197 os.proc := NIL;
1198 (*
1199 * Copies of value classes are always done inline.
1200 *)
1201 END StartBoxClass;
1202
1203 (* ============================================================ *)
1204
1205 PROCEDURE (os : PeFile)Tail(),NEW;
1206 BEGIN
1207 os.Locals();
1208 os.pePI.code.CloseScope(); (* Needed for PERWAPI pdb files *)
1209 os.pePI := NIL;
1210 os.proc := NIL;
1211 END Tail;
1212
1213 (* ============================================================ *)
1214
1215 PROCEDURE (os : PeFile)MainTail*();
1216 BEGIN os.Tail() END MainTail;
1217
1218 (* ------------------------------------------------------------ *)
1219
1220 PROCEDURE (os : PeFile)MethodTail*(id : Id.Procs);
1221 BEGIN os.Tail() END MethodTail;
1222
1223 (* ------------------------------------------------------------ *)
1224
1225 PROCEDURE (os : PeFile)ClinitTail*();
1226 BEGIN os.Tail() END ClinitTail;
1227
1228 (* ------------------------------------------------------------ *)
1229
1230 PROCEDURE (os : PeFile)CopyTail*();
1231 BEGIN os.Tail() END CopyTail;
1232
1233 (* ------------------------------------------------------------ *)
1234
1235 PROCEDURE (os : PeFile)InitTail*(typ : Ty.Record);
1236 BEGIN os.Tail() END InitTail;
1237
1238 (* ============================================================ *)
1239
1240 PROCEDURE (os : PeFile)ClinitHead*();
1241 VAR mAtt : INTEGER;
1242 BEGIN
1243 mAtt := ctAtt + Api.MethAttr.Static;
1244 os.pePI.mthD := os.clsS.AddMethod(mAtt, ilAtt, ".cctor", voidD, NIL);
1245 os.MkCodeBuffer();
1246 IF CSt.debug THEN
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);
1252 END;
1253 END ClinitHead;
1254
1255 (* ============================================================ *)
1256
1257 PROCEDURE (os : PeFile)EmitField*(id : Id.AbVar; att : SET);
1258 VAR fDf : Api.FieldDef;
1259 BEGIN
1260 fDf := os.fld(id)(Api.FieldDef);
1261 fDf.AddFieldAttr(toFieldAttr(att));
1262 END EmitField;
1263
1264 (* ============================================================ *)
1265 (* Start of Procedure Variable and Event Stuff *)
1266 (* ============================================================ *)
1267
1268 PROCEDURE MkAddRem(os : PeFile; fId : Id.AbVar);
1269 VAR xtn : EvtXtn;
1270 fXt : Api.Field;
1271 clD : Api.Class;
1272 namS : Lv.CharOpen;
1273 typA : POINTER TO ARRAY OF Api.Type;
1274 parA : POINTER TO ARRAY OF Api.Param;
1275 (* -------------------------------- *)
1276 PROCEDURE GetClass(os : PeFile;
1277 id : Id.AbVar;
1278 OUT cl : Api.Class;
1279 OUT nm : Lv.CharOpen);
1280 BEGIN
1281 WITH id : Id.FldId DO
1282 cl := os.cls(id.recTyp(Ty.Record));
1283 nm := id.fldNm;
1284 | id : Id.VarId DO
1285 IF id.recTyp # NIL THEN cl:= os.cls(id.recTyp(Ty.Record));
1286 ELSE cl:= os.dsc(id.dfScp(Id.BlkId));
1287 END;
1288 nm := id.varNm;
1289 END;
1290 END GetClass;
1291 (* -------------------------------- *)
1292 BEGIN
1293 (*
1294 * First, need to ensure that there is a field
1295 * descriptor created for this variable.
1296 *)
1297 IF fId.tgXtn = NIL THEN
1298 fXt := os.fld(fId);
1299 ELSE
1300 fXt := fId.tgXtn(Api.Field);
1301 END;
1302 (*
1303 * Now allocate the Event Extension object.
1304 *)
1305 NEW(xtn);
1306 xtn.fldD := fXt;
1307 (*
1308 * Now create the MethodRef or MethodDef descriptors
1309 * for add_<fieldname>() and remove_<fieldname>()
1310 *)
1311 GetClass(os, fId, clD, namS);
1312 WITH clD : Api.ClassDef DO
1313 NEW(parA, 1);
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
1318 NEW(typA, 1);
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);
1322 END;
1323 fId.tgXtn := xtn;
1324 END MkAddRem;
1325
1326 (* ============================================================ *)
1327
1328 PROCEDURE (os : PeFile)EmitEventMethods*(id : Id.AbVar);
1329 CONST att = Api.MethAttr.Public + Api.MethAttr.SpecialName;
1330 VAR eTp : Ty.Event;
1331 evt : Api.Event;
1332 addD : Api.MethodDef;
1333 remD : Api.MethodDef;
1334 (* ------------------------------------------------- *)
1335 PROCEDURE EmitEvtMth(os : PeFile;
1336 id : Id.AbVar;
1337 add : BOOLEAN;
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;
1343 BEGIN
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;
1350 os.MkCodeBuffer();
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);
1357 | id : Id.VarId DO
1358 mth.AddMethAttribute(att + Api.MethAttr.Static);
1359 mth.AddImplAttribute(ilAtt + Api.ImplAttr.Synchronised);
1360 os.pePI.mthD := mth;
1361 os.MkCodeBuffer();
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);
1366 END;
1367 os.Code(Asm.opc_ret);
1368 os.Tail();
1369 END EmitEvtMth;
1370 (* ------------------------------------------------- *)
1371 BEGIN
1372 (*
1373 * Emit the "add_*" method
1374 *)
1375 addD := os.add(id)(Api.MethodDef);
1376 EmitEvtMth(os, id, TRUE, addD);
1377 (*
1378 * Emit the "remove_*" method
1379 *)
1380 remD := os.rem(id)(Api.MethodDef);
1381 EmitEvtMth(os, id, FALSE, remD);
1382 (*
1383 * Emit the .event declaration"
1384 *)
1385 WITH id : Id.FldId DO
1386 evt := os.clsD.AddEvent(MKSTR(id.fldNm^), os.typ(id.type));
1387 | id : Id.VarId DO
1388 evt := os.clsD.AddEvent(MKSTR(id.varNm^), os.typ(id.type));
1389 END;
1390 evt.AddMethod(addD, Api.MethodType.AddOn);
1391 evt.AddMethod(remD, Api.MethodType.RemoveOn);
1392 END EmitEventMethods;
1393
1394 (* ============================================================ *)
1395
1396 PROCEDURE (os : PeFile)CallCombine(typ : Sy.Type;
1397 add : BOOLEAN),NEW;
1398 VAR xtn : Api.Method;
1399 BEGIN
1400 IF add THEN xtn := os.cmb() ELSE xtn := os.rmv() END;
1401 os.pePI.code.MethInst(Asm.cd[Asm.opc_call], xtn);
1402 os.Adjust(-1);
1403 os.CodeT(Asm.opc_castclass, typ);
1404 END CallCombine;
1405
1406 (* ============================================================ *)
1407
1408 PROCEDURE (os : PeFile)MkAndLinkDelegate*(dl : Sy.Idnt;
1409 id : Sy.Idnt;
1410 ty : Sy.Type;
1411 isA : BOOLEAN);
1412 (* --------------------------------------------------------- *)
1413 VAR rcv : INTEGER;
1414 mth : Api.Method;
1415 (* --------------------------------------------------------- *)
1416 BEGIN
1417 WITH id : Id.FldId DO
1418 (*
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)
1423 *)
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);
1428 | id : Id.VarId DO
1429 (*
1430 * <push receiver (or nil)> // ... already done
1431 * <make new proc value> // ... still to do
1432 * call void A.B::add_fld(class tyName)
1433 *)
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);
1437 | id : Id.LocId DO
1438 (*
1439 * <save receiver>
1440 * ldloc 'local'
1441 * <restore receiver>
1442 * <make new proc value> // ... still to do
1443 * call class D D::Combine(class D, class D)
1444 *)
1445 rcv := os.proc.newLocal(CSt.ntvObj);
1446 os.StoreLocal(rcv);
1447 os.GetLocal(id);
1448 os.PushLocal(rcv);
1449 os.MkNewProcVal(dl, ty);
1450 os.CallCombine(ty, isA);
1451 os.PutLocal(id);
1452 END;
1453 END MkAndLinkDelegate;
1454
1455 (* ============================================================ *)
1456 (* ============================================================ *)
1457
1458 PROCEDURE (os : PeFile)EmitPTypeBody*(tId : Id.TypId);
1459 BEGIN
1460 ASSERT(tId.tgXtn # NIL);
1461 END EmitPTypeBody;
1462
1463 (* ============================================================ *)
1464 (* End of Procedure Variable and Event Stuff *)
1465 (* ============================================================ *)
1466
1467 PROCEDURE (os : PeFile)Line*(nm : INTEGER);
1468 BEGIN
1469 os.pePI.code.IntLine(nm,1,nm,100);
1470 (*IF CSt.debug THEN os.Code(Asm.opc_nop) END;*)
1471 END Line;
1472
1473 PROCEDURE (os : PeFile)LinePlus*(lin, col : INTEGER);
1474 BEGIN
1475 (*IF CSt.debug THEN os.Code(Asm.opc_nop) END;*)
1476 os.pePI.code.IntLine(lin,1,lin,col);
1477 END LinePlus;
1478
1479 PROCEDURE (os : PeFile)LineSpan*(s : Scn.Span);
1480 BEGIN
1481 IF s # NIL THEN
1482 os.pePI.code.IntLine(s.sLin, s.sCol, s.eLin, s.eCol) END;
1483 END LineSpan;
1484
1485 (* ============================================================ *)
1486
1487 PROCEDURE (os : PeFile)Locals(),NEW;
1488 (** Declare the local of this method. *)
1489 VAR count : INTEGER;
1490 index : INTEGER;
1491 prcId : Sy.Scope;
1492 locId : Id.LocId;
1493 methD : Api.MethodDef;
1494 loclA : POINTER TO ARRAY OF Api.Local;
1495 boolA : POINTER TO ARRAY OF BOOLEAN;
1496 lBind : Api.LocalBinding;
1497 BEGIN
1498 methD := os.pePI.mthD;
1499 (*
1500 * If dMax < 8, leave maxstack as default
1501 *)
1502 IF os.proc.dMax > 8 THEN
1503 methD.SetMaxStack(os.proc.dMax);
1504 ELSE
1505 methD.SetMaxStack(8);
1506 END;
1507 NEW(loclA, os.proc.tLst.tide);
1508 NEW(boolA, os.proc.tLst.tide);
1509
1510 count := 0;
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));
1516 INC(count);
1517 END;
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;
1523 INC(count);
1524 END;
1525 END;
1526 ELSE (* nothing for module blocks *)
1527 END;
1528 END;
1529 WHILE count < os.proc.tLst.tide DO
1530 loclA[count] := Api.Local.init("", os.typ(os.proc.tLst.a[count]));
1531 INC(count);
1532 END;
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;
1536 END;
1537 END Locals;
1538
1539 (* ============================================================ *)
1540
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;
1546 BEGIN
1547 IF loadTyp = NIL THEN
1548 (*
1549 * Make params for the call
1550 *)
1551 NEW(rthA, 1);
1552 IF rtTpHdl = NIL THEN
1553 rtTpHdl := getOrAddValueClass(corlib, "System", "RuntimeTypeHandle");
1554 END;
1555 rthA[0] := rtTpHdl;
1556 (*
1557 * Make receiver/result type descriptor
1558 *)
1559 IF CSt.ntvTyp.tgXtn = NIL THEN
1560 CSt.ntvTyp.tgXtn := getOrAddClass(corlib, "System", "Type");
1561 END;
1562 typD := CSt.ntvTyp.tgXtn(Api.ClassRef);
1563 loadTyp := getOrAddMethod(typD, "GetTypeFromHandle", typD, rthA);
1564 END;
1565 RETURN loadTyp;
1566 END getLdTyp;
1567 (* ---------------------------------- *)
1568 BEGIN
1569 (*
1570 * ldtoken <Type>
1571 * call class [mscorlib]System.Type
1572 * [mscorlib]System.Type::GetTypeFromHandle(
1573 * value class [mscorlib]System.RuntimeTypeHandle)
1574 *)
1575 os.CodeT(Asm.opc_ldtoken, id.type);
1576 os.pePI.code.MethInst(Asm.cd[Asm.opc_call], getLdTyp(os));
1577 END LoadType;
1578
1579 (* ============================================================ *)
1580
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;
1588 twoBools : TypArr;
1589 dbugArgs : POINTER TO ARRAY OF Api.Constant;
1590 BEGIN
1591 thisAssm := pef.GetThisAssembly();
1592 debugRef := getOrAddClass(corlib, "System.Diagnostics", "DebuggableAttribute");
1593 NEW(twoBools, 2);
1594 NEW(dbugArgs, 2);
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);
1602 END MakeDebuggable;
1603 (* ------------------------------------ *)*)
1604 BEGIN
1605 IF CSt.debug THEN os.peFl.MakeDebuggable(TRUE, TRUE) END;
1606 (* bake the assembly ... *)
1607 os.peFl.WritePEFile(CSt.debug);
1608 END Finish;
1609
1610 (* ============================================================ *)
1611
1612 PROCEDURE (os : PeFile)RefRTS*();
1613 VAR i : INTEGER;
1614 xhrRc : Ty.Record;
1615 xhrNw : Api.Method;
1616 xhrXt : RecXtn;
1617 rtsXt : BlkXtn;
1618 recXt : RecXtn;
1619 BEGIN
1620 (*
1621 * Reset the descriptor pool.
1622 * Note that descriptors cannot persist between
1623 * compilation unit, since the token sequence
1624 * is reset in PEAPI.
1625 *)
1626 mathCls := NIL;
1627 envrCls := NIL;
1628 excpCls := NIL;
1629 rtTpHdl := NIL;
1630 loadTyp := NIL;
1631 FOR i := 0 TO Mu.rtsLen-1 DO rHelper[i] := NIL END;
1632 (*
1633 * Now we need to create tgXtn fields
1634 * for some of the system types. All
1635 * others are only allocated on demand.
1636 *)
1637 corlib := os.peFl.MakeExternAssembly("mscorlib");
1638 (*
1639 * Must put xtn markers on both the pointer AND the record
1640 *)
1641 NEW(recXt);
1642 CSt.ntvStr(Ty.Pointer).boundTp.tgXtn := recXt; (* the record *)
1643 (*
1644 * recXt.clsD := corlib.AddClass("System", "String");
1645 *)
1646 (* -- start replacement -- *)
1647 recXt.clsD := getOrAddClass(corlib, "System", "String");
1648 (* --- end replacement --- *)
1649 CSt.ntvStr.tgXtn := recXt.clsD; (* the pointer *)
1650 (*
1651 * Must put xtn markers on both the pointer AND the record
1652 *)
1653 NEW(recXt);
1654 CSt.ntvObj(Ty.Pointer).boundTp.tgXtn := recXt; (* the record *)
1655 (*
1656 * recXt.clsD := corlib.AddClass("System", "Object");
1657 *)
1658 (* -- start replacement -- *)
1659 recXt.clsD := getOrAddClass(corlib, "System", "Object");
1660 (* --- end replacement --- *)
1661 CSt.ntvObj.tgXtn := recXt.clsD; (* the pointer *)
1662 (*
1663 * CSt.ntvVal IS a record descriptor, not a pointer
1664 *)
1665 NEW(recXt);
1666 CSt.ntvVal.tgXtn := recXt; (* the record *)
1667 (*
1668 * recXt.clsD := corlib.AddClass("System", "ValueType");
1669 *)
1670 (* -- start replacement -- *)
1671 recXt.clsD := getOrAddClass(corlib, "System", "ValueType");
1672 (* --- end replacement --- *)
1673
1674 newObjt := getOrAddMethod(CSt.ntvObj.tgXtn(Api.ClassRef),ctorS,voidD,NIL);
1675 newObjt.AddCallConv(Api.CallConv.Instance);
1676 (*
1677 * Create Api.AssemblyRef for "RTS"
1678 * Create Api.ClassRef for "[RTS]RTS"
1679 * Create Api.ClassRef for "[RTS]Cp_rts"
1680 *)
1681 IF CSt.rtsBlk.xName = NIL THEN Mu.MkBlkName(CSt.rtsBlk) END;
1682 os.rts := os.peFl.MakeExternAssembly("RTS");
1683 NEW(rtsXt);
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");
1688 (*
1689 * Create Api.AssemblyRef for "ProgArgs" (same as RTS)
1690 * Create Api.ClassRef for "[RTS]ProgArgs"
1691 *)
1692 os.DoRtsMod(CSt.prgArg);
1693 os.progArgs := CSt.prgArg.tgXtn(BlkXtn).dscD(Api.ClassRef);
1694 (*
1695 * Create Api.ClassRef for "[RTS]XHR"
1696 * Create method "[RTS]XHR::.ctor()"
1697 *)
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);
1702 NEW(xhrXt);
1703 xhrRc.tgXtn := xhrXt;
1704 xhrXt.clsD := xhrCl;
1705 xhrXt.newD := xhrNw;
1706 END RefRTS;
1707
1708 (* ============================================================ *)
1709
1710 PROCEDURE (os : PeFile)StartNamespace*(nm : Lv.CharOpen);
1711 BEGIN
1712 os.nmSp := MKSTR(nm^);
1713 END StartNamespace;
1714
1715 (* ============================================================ *)
1716
1717 PROCEDURE (os : PeFile)MkBodyClass*(mod : Id.BlkId);
1718 (*
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.
1723 *)
1724 VAR namStr : RTS.NativeString;
1725 clsAtt : INTEGER;
1726 modXtn : BlkXtn;
1727 BEGIN
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);
1733 os.clsD := os.clsS;
1734 NEW(modXtn);
1735 modXtn.asmD := NIL;
1736 modXtn.dscD := os.clsS;
1737 mod.tgXtn := modXtn;
1738 END MkBodyClass;
1739
1740 (* ============================================================ *)
1741
1742 PROCEDURE (os : PeFile)ClassHead*(attSet : SET;
1743 thisRc : Ty.Record;
1744 superT : Ty.Record);
1745 VAR clsAtt : INTEGER;
1746 clsDef : Api.ClassDef;
1747 BEGIN
1748 clsAtt := toTypeAttr(attSet);
1749 clsDef := os.cls(thisRc)(Api.ClassDef);
1750 clsDef.AddAttribute(clsAtt);
1751 os.clsD := clsDef;
1752 END ClassHead;
1753
1754 (* ============================================================ *)
1755
1756 PROCEDURE (os : PeFile)ClassTail*();
1757 BEGIN
1758 os.clsD := NIL;
1759 END ClassTail;
1760
1761 (* ============================================================ *)
1762
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 * -------------------------------- *)
1769 VAR indx : INTEGER;
1770 valR : BOOLEAN; (* is a value record *)
1771 noNw : BOOLEAN; (* no constructor... *)
1772 base : Ty.Record;
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 *)
1779 recX : RecXtn;
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;
1786 tXtn : RecXtn;
1787 BEGIN
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);
1793
1794 nMth.AddCallConv(Api.CallConv.Instance);
1795 cFld.AddFieldAttr(Api.FieldAttr.Public);
1796
1797 tXtn.boxD := cDef;
1798 tXtn.newD := nMth;
1799 tXtn.vDlr := cFld;
1800 END DoBoxDef;
1801 (* -------------------------------- *)
1802 PROCEDURE DoBoxRef(o : PeFile; t : Ty.Record; c : Api.ClassRef);
1803 VAR cFld : Api.FieldRef;
1804 nMth : Api.MethodRef;
1805 tXtn : RecXtn;
1806 BEGIN
1807 tXtn := t.tgXtn(RecXtn);
1808 cFld := getOrAddField(c, vfldS, tXtn.clsD);
1809 (*
1810 * nMth := c.AddMethod(ctorS,voidD,NIL);
1811 *)
1812 nMth := getOrAddMethod(c, ctorS, voidD, NIL);
1813 nMth.AddCallConv(Api.CallConv.Instance);
1814
1815 tXtn.boxD := c;
1816 tXtn.newD := nMth;
1817 tXtn.vDlr := cFld;
1818 END DoBoxRef;
1819 (* -------------------------------- *)
1820 BEGIN
1821 nStr := MKSTR(t.xName^);
1822 valR := Mu.isValRecord(t);
1823 NEW(recX);
1824 t.tgXtn := recX;
1825 (*
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.
1829 *)
1830 noNw := t.isInterfaceType() OR (Sy.noNew IN t.xAttr);
1831
1832 IF s.kind # Id.impId THEN (* this is a classDEF *)
1833 base := t.superType(); (* might return System.ValueType *)
1834 IF base = NIL THEN
1835 cDef := os.peFl.AddClass(0, os.nmSp, nStr);
1836 ELSIF valR THEN
1837 cDef := os.peFl.AddValueClass(0, os.nmSp, nStr);
1838 ELSE
1839 cDef := os.peFl.AddClass(0, os.nmSp, nStr, os.cls(base));
1840 END;
1841 recX.clsD := cDef; (* this field needed for MkFldName() *)
1842 IF valR THEN
1843 (*
1844 * Create the boxed version of this value record
1845 * AND create a constructor for the boxed class
1846 *)
1847 DoBoxDef(os, t);
1848 ELSIF ~noNw THEN
1849 (*
1850 * Create a constructor for this reference class.
1851 *)
1852 recX.newD := cDef.AddMethod(ctAtt, ilAtt, ctorS, voidD, NIL);
1853 recX.newD.AddCallConv(Api.CallConv.Instance);
1854 END;
1855 FOR indx := 0 TO t.fields.tide-1 DO
1856 Mu.MkFldName(t.fields.a[indx](Id.FldId), os);
1857 END;
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);
1863 recX.clsD := cRef;
1864 ELSE (* ... a normal classREF *)
1865 xAsm := os.asm(s(Id.BlkId));
1866 aStr := MKSTR(s(Id.BlkId).xName^);
1867 IF valR THEN
1868 cRef := getOrAddValueClass(xAsm, aStr, nStr);
1869 ELSE
1870 cRef := getOrAddClass(xAsm, aStr, nStr);
1871 END;
1872 recX.clsD := cRef;
1873 IF valR & ~(Sy.isFn IN t.xAttr) THEN
1874 DoBoxRef(os, t, xAsm.AddClass(aStr, boxedName(t)));
1875 END;
1876 END;
1877
1878 IF ~noNw & ~valR THEN
1879 recX.newD := getOrAddMethod(cRef, ctorS, voidD, NIL);
1880 recX.newD.AddCallConv(Api.CallConv.Instance);
1881 END;
1882 END;
1883 END MkRecX;
1884
1885 (* ============================================================ *)
1886
1887 PROCEDURE (os : PeFile)MkVecX*(t : Sy.Type; m : Id.BlkId);
1888 VAR xAsm : Api.AssemblyRef;
1889 recX : RecXtn;
1890 nStr : RTS.NativeString; (* record name string *)
1891 aStr : RTS.NativeString; (* imported namespace *)
1892 cRef : Api.ClassRef;
1893 BEGIN
1894 NEW(recX);
1895 t.tgXtn := recX;
1896
1897 IF m.tgXtn = NIL THEN os.DoRtsMod(m) END;
1898 IF t.xName = NIL THEN Mu.MkTypeName(t, os) END;
1899
1900 aStr := MKSTR(m.xName^);
1901 nStr := MKSTR(t.xName^);
1902
1903 xAsm := os.asm(m);
1904 cRef := xAsm.AddClass(aStr, nStr);
1905 recX.clsD := cRef;
1906 recX.newD := cRef.AddMethod(ctorS, voidD, NIL);
1907 recX.newD.AddCallConv(Api.CallConv.Instance);
1908 END MkVecX;
1909
1910 (* ============================================================ *)
1911
1912 PROCEDURE (os : PeFile)MkDelX(t : Ty.Procedure;
1913 s : Sy.Scope),NEW;
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. *)
1923 clD : Api.ClassDef;
1924 clR : Api.ClassRef;
1925 mtD : Api.MethodDef;
1926 (* -------------------------------- *)
1927 PROCEDURE t2() : POINTER TO ARRAY OF Api.Type;
1928 VAR a : POINTER TO ARRAY OF Api.Type;
1929 BEGIN
1930 NEW(a,2); a[0] := objtD; a[1] := nIntD; RETURN a;
1931 END t2;
1932 (* -------------------------------- *)
1933 PROCEDURE p2() : POINTER TO ARRAY OF Api.Param;
1934 VAR a : POINTER TO ARRAY OF Api.Param;
1935 BEGIN
1936 NEW(a,2);
1937 a[0] := Api.Param.init(0, "obj", objtD);
1938 a[1] := Api.Param.init(0, "mth", nIntD);
1939 RETURN a;
1940 END p2;
1941 (* -------------------------------- *)
1942 PROCEDURE tArr(t: Ty.Procedure; o: PeFile) : POINTER TO ARRAY OF Api.Type;
1943 VAR a : POINTER TO ARRAY OF Api.Type;
1944 i : INTEGER;
1945 p : Id.ParId;
1946 d : Api.Type;
1947 BEGIN
1948 NEW(a, t.formals.tide);
1949 FOR i := 0 TO t.formals.tide-1 DO
1950 p := t.formals.a[i];
1951 d := o.typ(p.type);
1952 IF Mu.takeAdrs(p) THEN
1953 p.boxOrd := p.parMod;
1954 d := Api.ManagedPointer.init(d);
1955 END;
1956 a[i] := d;
1957 END;
1958 RETURN a;
1959 END tArr;
1960 (* -------------------------------- *)
1961 PROCEDURE pArr(t: Ty.Procedure; o: PeFile) : POINTER TO ARRAY OF Api.Param;
1962 VAR a : POINTER TO ARRAY OF Api.Param;
1963 i : INTEGER;
1964 p : Id.ParId;
1965 d : Api.Type;
1966 BEGIN
1967 NEW(a, t.formals.tide);
1968 FOR i := 0 TO t.formals.tide-1 DO
1969 p := t.formals.a[i];
1970 d := o.typ(p.type);
1971 IF Mu.takeAdrs(p) THEN
1972 p.boxOrd := p.parMod;
1973 d := Api.ManagedPointer.init(d);
1974 END;
1975 a[i] := Api.Param.init(0, nms(p), d);
1976 END;
1977 RETURN a;
1978 END pArr;
1979 (* -------------------------------- *)
1980 BEGIN
1981 IF t.tgXtn # NIL THEN RETURN END;
1982 NEW(xtn);
1983 str := MKSTR(Sy.getName.ChPtr(t.idnt)^);
1984 rtT := t.retType;
1985 IF rtT = NIL THEN rtD := voidD ELSE rtD := os.typ(rtT) END;
1986
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);
1993 xtn.newD := mtD;
1994 mtD := clD.AddMethod(invkS, rtD, pArr(t, os));
1995 mtD.AddMethAttribute(Api.MethAttr.Public);
1996 mtD.AddImplAttribute(rmAtt);
1997 xtn.invD := mtD;
1998 xtn.clsD := clD;
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));
2005 xtn.clsD := clR;
2006 END;
2007 xtn.newD.AddCallConv(Api.CallConv.Instance);
2008 xtn.invD.AddCallConv(Api.CallConv.Instance);
2009 t.tgXtn := xtn;
2010 IF (t.idnt # NIL) & (t.idnt.tgXtn = NIL) THEN t.idnt.tgXtn := xtn END;
2011 END MkDelX;
2012
2013 (* ============================================================ *)
2014
2015 PROCEDURE (os : PeFile)MkPtrX*(t : Ty.Pointer);
2016 VAR bTyp : Sy.Type;
2017 recX : RecXtn;
2018 BEGIN
2019 bTyp := t.boundTp;
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;
2025 END;
2026 | bTyp : Ty.Array DO
2027 t.tgXtn := bTyp.tgXtn;
2028 END;
2029 END MkPtrX;
2030
2031 (* ============================================================ *)
2032
2033 PROCEDURE (os : PeFile)MkArrX*(t : Ty.Array);
2034 BEGIN
2035 t.tgXtn := Api.ZeroBasedArray.init(os.typ(t.elemTp));
2036 END MkArrX;
2037
2038 (* ============================================================ *)
2039
2040 PROCEDURE (os : PeFile)MkBasX*(t : Ty.Base);
2041 BEGIN
2042 CASE t.tpOrd OF
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;
2053 END;
2054 END MkBasX;
2055
2056 (* ============================================================ *)
2057
2058 PROCEDURE (os : PeFile)MkEnuX*(t : Ty.Enum; s : Sy.Scope);
2059 VAR scNs : RTS.NativeString;
2060 enNm : RTS.NativeString;
2061 BEGIN
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);
2066 END MkEnuX;
2067
2068 (* ============================================================ *)
2069 (*
2070 PROCEDURE (os : PeFile)MkTyXtn*(t : Sy.Type; s : Sy.Scope);
2071 BEGIN
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);
2079 END;
2080 END MkTyXtn;
2081 *)
2082 (* ============================================================ *)
2083
2084 PROCEDURE MkMthDef(os : PeFile;
2085 xhr : BOOLEAN;
2086 pTp : Ty.Procedure;
2087 cls : Api.ClassDef;
2088 str : RTS.NativeString) : Api.MethodDef;
2089 VAR par : Id.ParId;
2090 prd : Api.Type;
2091 prs : POINTER TO ARRAY OF Api.Param;
2092 rtT : Sy.Type;
2093 rtd : Api.Type;
2094 pId : Sy.Idnt;
2095
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 *)
2101 BEGIN
2102 pId := pTp.idnt;
2103 IF (pId # NIL) & (pId IS Id.MthId) & (Id.covar IN pId(Id.MthId).mthAtt) THEN
2104 rtT := pId(Id.MthId).retTypBound();
2105 ELSE
2106 rtT := pTp.retType;
2107 END;
2108 num := pTp.formals.tide;
2109 IF xhr THEN len := num + 1 ELSE len := num END;
2110 NEW(prs, len);
2111 IF rtT = NIL THEN rtd := voidD ELSE rtd := os.typ(rtT) END;
2112
2113 prO := pTp.argN; (* count from 1 if xhr OR has this *)
2114 IF xhr THEN
2115 prs[0] := Api.Param.init(0, "", xhrCl); prX := 1;
2116 ELSE
2117 prX := 0;
2118 END;
2119 FOR idx := 0 TO num-1 DO
2120 par := pTp.formals.a[idx];
2121 par.varOrd := prO;
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);
2129 END;
2130 END; (* just mark *)
2131 prs[prX] := Api.Param.init(par.boxOrd, nms(par), prd);
2132 INC(prX); INC(prO);
2133 END;
2134 (*
2135 * Add attributes, Impl, Meth, CallConv in MethodDecl()
2136 *)
2137 RETURN cls.AddMethod(str, rtd, prs);
2138 END MkMthDef;
2139
2140 (* ============================================================ *)
2141
2142 PROCEDURE MkMthRef(os : PeFile;
2143 pTp : Ty.Procedure;
2144 cls : Api.ClassRef;
2145 str : RTS.NativeString) : Api.MethodRef;
2146 VAR par : Id.ParId;
2147 tpD : Api.Type;
2148 prs : POINTER TO ARRAY OF Api.Type;
2149 rtT : Sy.Type;
2150 rtd : Api.Type;
2151 pId : Sy.Idnt;
2152
2153 idx : INTEGER; (* index into formal array *)
2154 prO : INTEGER; (* runtime ordinal of arg. *)
2155 num : INTEGER; (* length of formal array *)
2156 BEGIN
2157 pId := pTp.idnt;
2158 IF (pId # NIL) & (pId IS Id.MthId) & (Id.covar IN pId(Id.MthId).mthAtt) THEN
2159 rtT := pId(Id.MthId).retTypBound();
2160 ELSE
2161 rtT := pTp.retType;
2162 END;
2163 num := pTp.formals.tide;
2164 NEW(prs, num);
2165 IF rtT = NIL THEN rtd := voidD ELSE rtd := os.typ(rtT) END;
2166
2167 prO := pTp.argN;
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);
2177 END;
2178 RETURN getOrAddMethod(cls, str, rtd, prs);
2179 END MkMthRef;
2180
2181 (* ============================================================ *)
2182
2183 PROCEDURE (os : PeFile)NumberParams*(pId : Id.Procs;
2184 pTp : Ty.Procedure);
2185 (*
2186 * (1) Generate signature information for this procedure
2187 * (2) Generate the target extension Method(Def | Ref)
2188 *)
2189 VAR class : Api.Class;
2190 methD : Api.Method;
2191 namSt : RTS.NativeString;
2192 xhrMk : BOOLEAN;
2193 pLeng : INTEGER;
2194 (* ----------------- *)
2195 PROCEDURE classOf(os : PeFile; id : Id.Procs) : Api.Class;
2196 VAR scp : Sy.Scope;
2197 BEGIN
2198 scp := id.dfScp;
2199 (*
2200 * Check for methods bound to explicit classes
2201 *)
2202 IF id.bndType # NIL THEN RETURN os.cls(id.bndType(Ty.Record)) END;
2203 (*
2204 * Or associate static methods with the dummy class
2205 *)
2206 WITH scp : Id.BlkId DO
2207 RETURN os.dsc(scp);
2208 | scp : Id.Procs DO (* Nested procs take class from scope *)
2209 RETURN classOf(os, scp);
2210 END;
2211 END classOf;
2212 (* ----------------- *)
2213 BEGIN
2214 IF pId = NIL THEN
2215 os.MkDelX(pTp, pTp.idnt.dfScp); RETURN; (* PREMATURE RETURN HERE *)
2216 END;
2217 IF pId.tgXtn # NIL THEN RETURN END; (* PREMATURE RETURN HERE *)
2218
2219 class := classOf(os, pId);
2220 namSt := MKSTR(pId.prcNm^);
2221 xhrMk := pId.lxDepth > 0;
2222 (*
2223 * The incoming argN counts one for a receiver,
2224 * and also counts one for nested procedures.
2225 *)
2226 IF pId IS Id.MthId THEN pLeng := pTp.argN-1 ELSE pLeng := pTp.argN END;
2227 (*
2228 * Now create either a MethodDef or MethodRef
2229 *)
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);
2234 END;
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;
2239
2240 pId.tgXtn := methD;
2241 pTp.xName := cln2; (* an arbitrary "done" marker *)
2242
2243 IF (pId.kind = Id.fwdPrc) OR (pId.kind = Id.fwdMth) THEN
2244 pId.resolve.tgXtn := methD;
2245 END;
2246 END NumberParams;
2247
2248 (* ============================================================ *)
2249
2250 PROCEDURE (os : PeFile)SwitchHead*(num : INTEGER);
2251 BEGIN
2252 switch.next := 0;
2253 NEW(switch.list, num);
2254 END SwitchHead;
2255
2256 PROCEDURE (os : PeFile)SwitchTail*();
2257 BEGIN
2258 os.pePI.code.Switch(switch.list);
2259 switch.list := NIL;
2260 END SwitchTail;
2261
2262 PROCEDURE (os : PeFile)LstLab*(l : Mu.Label);
2263 BEGIN
2264 WITH l : PeLab DO
2265 switch.list[switch.next] := l.labl;
2266 INC(switch.next);
2267 END;
2268 END LstLab;
2269
2270 (* ============================================================ *)
2271
2272 PROCEDURE (os : PeFile)mth(pId : Id.Procs) : Api.Method,NEW;
2273 BEGIN
2274 ASSERT(pId.tgXtn # NIL);
2275 RETURN pId.tgXtn(Api.Method);
2276 END mth;
2277
2278 (* -------------------------------- *)
2279
2280 PROCEDURE (os : PeFile)fld(fId : Id.AbVar) : Api.Field,NEW;
2281 VAR cDf : Api.Class;
2282 fNm : Lv.CharOpen;
2283 obj : ANYPTR;
2284 (* ---------------- *)
2285 PROCEDURE AddField(os : PeFile;
2286 cl : Api.Class;
2287 fn : Lv.CharOpen;
2288 ty : Sy.Type) : Api.Field;
2289 VAR fs : RTS.NativeString;
2290 BEGIN
2291 fs := MKSTR(fn^);
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));
2296 END;
2297 END AddField;
2298 (* ---------------- *)
2299 BEGIN
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));
2307 END;
2308 fNm := fId.varNm;
2309 | fId : Id.FldId DO
2310 IF fId.fldNm = NIL THEN Mu.MkFldName(fId,os) END;
2311 cDf := os.cls(fId.recTyp(Ty.Record));
2312 fNm := fId.fldNm;
2313 END;
2314 fId.tgXtn := AddField(os, cDf, fNm, fId.type);
2315 END;
2316 obj := fId.tgXtn;
2317 WITH obj : Api.Field DO RETURN obj;
2318 | obj : EvtXtn DO RETURN obj.fldD;
2319 END;
2320 END fld;
2321
2322 (* -------------------------------- *)
2323
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;
2328 END add;
2329
2330 (* -------------------------------- *)
2331
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;
2336 END rem;
2337
2338 (* -------------------------------- *)
2339
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;
2344 END asm;
2345
2346 (* -------------------------------- *)
2347
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;
2352 END dsc;
2353
2354 (* -------------------------------- *)
2355
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;
2360 END cls;
2361
2362 (* -------------------------------- *)
2363 (*
2364 * PROCEDURE (os : PeFile)box(rTy : Ty.Record) : Api.Class,NEW;
2365 * BEGIN
2366 * IF rTy.tgXtn = NIL THEN Mu.MkRecName(rTy, os) END;
2367 * RETURN rTy.tgXtn(RecXtn).boxD;
2368 * END box;
2369 *)
2370 (* -------------------------------- *)
2371
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;
2376 END new;
2377
2378 (* -------------------------------- *)
2379
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);
2384 END dxt;
2385
2386 (* -------------------------------- *)
2387
2388 PROCEDURE mkCopyDef(cDf : Api.ClassDef; val : BOOLEAN) : Api.Method;
2389 VAR pra : POINTER TO ARRAY OF Api.Param;
2390 prd : Api.Type;
2391 BEGIN
2392 NEW(pra, 1);
2393 prd := cDf;
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);
2397 END mkCopyDef;
2398
2399 (* -------------------------------- *)
2400
2401 PROCEDURE (os : PeFile)cpy(rTy : Ty.Record) : Api.Method,NEW;
2402 VAR tXtn : RecXtn;
2403 tCls : Api.Class;
2404 mthX : Api.Method;
2405 typA : POINTER TO ARRAY OF Api.Type;
2406 valR : BOOLEAN;
2407 BEGIN
2408 tXtn := rTy.tgXtn(RecXtn);
2409 tCls := tXtn.clsD;
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
2415 NEW(typA, 1);
2416 IF valR THEN
2417 typA[0] := Api.ManagedPointer.init(tCls);
2418 ELSE
2419 typA[0] := tCls;
2420 END;
2421 mthX := tCls.AddMethod(copyS, voidD, typA);
2422 mthX.AddCallConv(Api.CallConv.Instance);
2423 END;
2424 tXtn.cpyD := mthX;
2425 ELSE
2426 mthX := tXtn.cpyD;
2427 END;
2428 RETURN mthX;
2429 END cpy;
2430
2431 (* -------------------------------- *)
2432
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;
2437 END vDl;
2438
2439 (* -------------------------------- *)
2440
2441 PROCEDURE (os : PeFile)RescueOpaque(tTy : Sy.Type),NEW;
2442 VAR blk : Id.BlkId;
2443 ext : BlkXtn;
2444 BEGIN
2445 blk := tTy.idnt.dfScp(Id.BlkId);
2446 os.DoExtern(blk);
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)^));
2450 RESCUE (any)
2451 (* Just leave tgXtn = NIL *)
2452 END RescueOpaque;
2453
2454 (* -------------------------------- *)
2455
2456 PROCEDURE (os : PeFile)typ(tTy : Sy.Type) : Api.Type,NEW;
2457 VAR xtn : ANYPTR;
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;
2461 xtn := tTy.tgXtn;
2462 IF xtn = NIL THEN
2463 IF tTy.xName # NIL THEN tTy.TypeErrStr(236, tTy.xName);
2464 ELSE tTy.TypeError(236);
2465 END;
2466 RTS.Throw("Opaque Type Error");
2467 END;
2468 WITH xtn : Api.Type DO
2469 RETURN xtn;
2470 | xtn : RecXtn DO
2471 RETURN xtn.clsD;
2472 | xtn : DelXtn DO
2473 RETURN xtn.clsD;
2474 END;
2475 END typ;
2476
2477 (* ============================================================ *)
2478
2479 PROCEDURE (os : PeFile)mcd() : Api.ClassRef,NEW;
2480 BEGIN (* returns System.MulticastDelegate *)
2481 IF multiCD = NIL THEN
2482 multiCD := getOrAddClass(corlib, "System", "MulticastDelegate");
2483 END;
2484 RETURN multiCD;
2485 END mcd;
2486
2487 (* ============================================================ *)
2488
2489 PROCEDURE (os : PeFile)del() : Api.ClassRef,NEW;
2490 BEGIN (* returns System.Delegate *)
2491 IF delegat = NIL THEN
2492 delegat := getOrAddClass(corlib, "System", "Delegate");
2493 END;
2494 RETURN delegat;
2495 END del;
2496
2497 (* ============================================================ *)
2498
2499 PROCEDURE (os : PeFile)rmv() : Api.MethodRef,NEW;
2500 VAR prs : POINTER TO ARRAY OF Api.Type;
2501 dlg : Api.ClassRef;
2502 BEGIN (* returns System.Delegate::Remove *)
2503 IF remove = NIL THEN
2504 dlg := os.del();
2505 NEW(prs, 2);
2506 prs[0] := dlg;
2507 prs[1] := dlg;
2508 remove := dlg.AddMethod("Remove", dlg, prs);
2509 END;
2510 RETURN remove;
2511 END rmv;
2512
2513 (* ============================================================ *)
2514
2515 PROCEDURE (os : PeFile)cmb() : Api.MethodRef,NEW;
2516 VAR prs : POINTER TO ARRAY OF Api.Type;
2517 dlg : Api.ClassRef;
2518 BEGIN (* returns System.Delegate::Combine *)
2519 IF combine = NIL THEN
2520 dlg := os.del();
2521 NEW(prs, 2);
2522 prs[0] := dlg;
2523 prs[1] := dlg;
2524 combine := dlg.AddMethod("Combine", dlg, prs);
2525 END;
2526 RETURN combine;
2527 END cmb;
2528
2529 (* ============================================================ *)
2530 (* ============================================================ *)
2531 BEGIN
2532 evtAdd := Lv.strToCharOpen("add_");
2533 evtRem := Lv.strToCharOpen("remove_");
2534 cln2 := Lv.strToCharOpen("::");
2535 boxedObj := Lv.strToCharOpen("Boxed_");
2536
2537 vfldS := MKSTR("v$");
2538 ctorS := MKSTR(".ctor");
2539 invkS := MKSTR("Invoke");
2540 copyS := MKSTR("__copy__");
2541 END PeUtil.
2542 (* ============================================================ *)
2543 (* ============================================================ *)
2544
[FORK] Old GPCP with patches
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024