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 / MsilUtil.cp
1 (* ============================================================ *)
2 (* MsilUtil is the module which writes ILASM file structures *)
3 (* Copyright (c) John Gough 1999, 2000. *)
4 (* ============================================================ *)
5
6 MODULE MsilUtil;
7
8 IMPORT
9 GPCPcopyright,
10 RTS,
11 Console,
12 MsilBase,
13 NameHash,
14 Scn := CPascalS,
15 CSt := CompState,
16 Lv := LitValue,
17 Sy := Symbols,
18 Bi := Builtin,
19 Id := IdDesc,
20 Ty := TypeDesc,
21 Asm := IlasmCodes;
22
23 (* ============================================================ *)
24
25 CONST
26 (* various ILASM-specific runtime name strings *)
27 initString = ".ctor";
28
29 CONST
30 (* Conversions from System.String to char[] *)
31 vStr2ChO* = 1;
32 vStr2ChF* = 2;
33 (* Runtime support for CP's MOD,DIV operations *)
34 sysExit* = 3;
35 toUpper* = 4;
36 dFloor* = 5;
37 dAbs* = 6;
38 fAbs* = 7;
39 iAbs* = 8;
40 lAbs* = 9;
41 getTpM* = 10;
42 CpModI* = 11;
43 CpDivI* = 12;
44 CpModL* = 13;
45 CpDivL* = 14;
46 (* various ILASM-specific runtime name strings *)
47 aStrLen* = 15;
48 aStrChk* = 16;
49 aStrLp1* = 17;
50 aaStrCmp* = 18;
51 aaStrCopy* = 19;
52 (* Error reporting facilities ................ *)
53 caseMesg* = 20;
54 withMesg* = 21;
55 mkExcept* = 22;
56 (* Conversions from char[] to System.String *)
57 chs2Str* = 23;
58 (* various CPJ-specific concatenation helpers *)
59 CPJstrCatAA* = 24;
60 CPJstrCatSA* = 25;
61 CPJstrCatAS* = 26;
62 CPJstrCatSS* = 27;
63 rtsLen* = 28;
64
65 (* ============================================================ *)
66 (* ============================================================ *)
67
68 TYPE Label* = POINTER TO ABSTRACT RECORD END;
69 LbArr* = POINTER TO ARRAY OF Label;
70
71 TYPE ProcInfo* = POINTER TO (* EXTENSIBLE *) RECORD
72 prId- : Sy.Scope; (* mth., prc. or mod. *)
73 rtLc* : INTEGER; (* return value local # *)
74 (* ---- depth tracking ------ *)
75 dNum- : INTEGER; (* current stack depth *)
76 dMax- : INTEGER; (* maximum stack depth *)
77 (* ---- temp-var manager ---- *)
78 lNum- : INTEGER; (* prog vars *)
79 tLst- : Sy.TypeSeq; (* type list *)
80 fLst- : Sy.TypeSeq; (* free list *)
81 (* ---- end temp manager ---- *)
82 exLb* : Label; (* exception exit label *)
83 END;
84
85 (* ============================================================ *)
86
87 TYPE MsilFile* = POINTER TO ABSTRACT RECORD
88 srcS* : Lv.CharOpen;(* source file name *)
89 outN* : Lv.CharOpen;
90 proc* : ProcInfo;
91 END;
92
93 (* ============================================================ *)
94
95 VAR nmArray : Lv.CharOpenSeq;
96
97
98 VAR lPar, rPar, lBrk, (* ( ) { *)
99 rBrk, dotS, rfMk, (* } . & *)
100 atSg, cmma, (* @ , *)
101 vFld, (* "v$" *)
102 brks, (* "[]" *)
103 rtsS, (* "RTS" *)
104 prev, (* "prev" *)
105 body, (* ".body" *)
106 ouMk : Lv.CharOpen; (* "[out]" *)
107
108 evtAdd, evtRem : Lv.CharOpen;
109 pVarSuffix : Lv.CharOpen;
110 xhrMk : Lv.CharOpen;
111 xhrDl : Lv.CharOpen;
112 vecPrefix : Lv.CharOpen;
113
114 VAR boxedObj : Lv.CharOpen;
115 corlibAsm : Lv.CharOpen;
116 xhrIx : INTEGER;
117
118 (* ============================================================ *)
119
120 VAR vecBlkId : Id.BlkId;
121 vecBase : Id.TypId;
122 vecTypes : ARRAY Ty.anyPtr+1 OF Id.TypId; (* pointers *)
123 vecTide : Id.FldId;
124 vecElms : ARRAY Ty.anyPtr+1 OF Id.FldId;
125 vecExpnd : ARRAY Ty.anyPtr+1 OF Id.MthId;
126
127 (* ============================================================ *)
128
129 VAR typeGetE : ARRAY 16 OF INTEGER;
130 typePutE : ARRAY 16 OF INTEGER;
131 typeStInd : ARRAY 16 OF INTEGER;
132 typeLdInd : ARRAY 16 OF INTEGER;
133
134 (* ============================================================ *)
135
136 PROCEDURE (t : MsilFile)fileOk*() : BOOLEAN,NEW,ABSTRACT;
137 (* Test if file was opened successfully *)
138
139 (* ============================================================ *)
140 (* EMPTY text format Procedures only overidden in IlasmUtil *)
141 (* ============================================================ *)
142
143 PROCEDURE (os : MsilFile)MkNewProcInfo*(s : Sy.Scope),NEW,ABSTRACT;
144 PROCEDURE (os : MsilFile)Comment*(IN s : ARRAY OF CHAR),NEW,EMPTY;
145 PROCEDURE (os : MsilFile)CommentT*(IN s : ARRAY OF CHAR),NEW,EMPTY;
146 PROCEDURE (os : MsilFile)OpenBrace*(i : INTEGER),NEW,EMPTY;
147 PROCEDURE (os : MsilFile)CloseBrace*(i : INTEGER),NEW,EMPTY;
148 PROCEDURE (os : MsilFile)Blank*(),NEW,EMPTY;
149
150 (* ============================================================ *)
151 (* ABSTRACT Procedures overidden in both subclasses *)
152 (* ============================================================ *)
153 (* Various code emission methods *)
154 (* ============================================================ *)
155
156 PROCEDURE (os : MsilFile)Code*(code : INTEGER),NEW,ABSTRACT;
157
158 PROCEDURE (os : MsilFile)CodeI*(code,int : INTEGER),NEW,ABSTRACT;
159
160 PROCEDURE (os : MsilFile)CodeT*(code : INTEGER; type : Sy.Type),NEW,ABSTRACT;
161
162 PROCEDURE (os : MsilFile)CodeTn*(code : INTEGER; type : Sy.Type),NEW,ABSTRACT;
163
164 PROCEDURE (os : MsilFile)CodeL*(code : INTEGER; long : LONGINT),NEW,ABSTRACT;
165
166 PROCEDURE (os : MsilFile)CodeR*(code : INTEGER; real : REAL),NEW,ABSTRACT;
167
168 PROCEDURE (os : MsilFile)CodeLb*(code : INTEGER; i2 : Label),NEW,ABSTRACT;
169
170 PROCEDURE (os : MsilFile)CodeS*(code : INTEGER;
171 str : INTEGER),NEW,ABSTRACT;
172
173 PROCEDURE (os : MsilFile)MkNewRecord*(typ : Ty.Record),NEW,ABSTRACT;
174 (* emit constructor call ... *)
175
176 PROCEDURE (os : MsilFile)LoadType*(id : Sy.Idnt),NEW,ABSTRACT;
177 (* load runtime type descriptor *)
178
179 PROCEDURE (os : MsilFile)PushStr*(IN str : ARRAY OF CHAR),NEW,ABSTRACT;
180 (* load a literal string *)
181
182 PROCEDURE (os : MsilFile)NumberParams*(pId : Id.Procs;
183 pTp : Ty.Procedure),NEW,ABSTRACT;
184
185 PROCEDURE (os : MsilFile)Finish*(),NEW,ABSTRACT;
186
187 (* ============================================================ *)
188
189 PROCEDURE (os : MsilFile)MkBodyClass*(mod : Id.BlkId),NEW,ABSTRACT;
190 PROCEDURE (os : MsilFile)ClassHead*(attSet : SET;
191 thisRc : Ty.Record;
192 superT : Ty.Record),NEW,ABSTRACT;
193 PROCEDURE (os : MsilFile)StartBoxClass*(rec : Ty.Record;
194 att : SET;
195 blk : Id.BlkId),NEW,ABSTRACT;
196 PROCEDURE (os : MsilFile)ClassTail*(),NEW,EMPTY;
197
198 (* ============================================================ *)
199
200 PROCEDURE (os : MsilFile)StartNamespace*(nm : Lv.CharOpen),NEW,ABSTRACT;
201 PROCEDURE (os : MsilFile)RefRTS*(),NEW,ABSTRACT;
202
203 PROCEDURE (os : MsilFile)MkBasX*(t : Ty.Base),NEW,EMPTY;
204 PROCEDURE (os : MsilFile)MkArrX*(t : Ty.Array),NEW,EMPTY;
205 PROCEDURE (os : MsilFile)MkPtrX*(t : Ty.Pointer),NEW,EMPTY;
206 PROCEDURE (os : MsilFile)MkVecX*(t : Sy.Type; s : Id.BlkId),NEW,EMPTY;
207 PROCEDURE (os : MsilFile)MkEnuX*(t : Ty.Enum; s : Sy.Scope),NEW,EMPTY;
208 PROCEDURE (os : MsilFile)MkRecX*(t : Ty.Record; s : Sy.Scope),NEW,EMPTY;
209 PROCEDURE (os : MsilFile)AsmDef*(IN pkNm : ARRAY OF CHAR),NEW,EMPTY;
210 PROCEDURE (os : MsilFile)SubSys*(xAtt : SET),NEW,ABSTRACT;
211
212 (* ============================================================ *)
213 (* Calling a static (usually runtime helper) method *)
214 (* ============================================================ *)
215
216 PROCEDURE (os : MsilFile)StaticCall*(s : INTEGER;
217 d : INTEGER),NEW,ABSTRACT;
218
219 PROCEDURE (os : MsilFile)CopyCall*(typ : Ty.Record),NEW,ABSTRACT;
220
221 (* ============================================================ *)
222 (* Calling a user defined method, constructor or delegate *)
223 (* ============================================================ *)
224
225 PROCEDURE (os : MsilFile)CallIT*(code : INTEGER;
226 proc : Id.Procs;
227 type : Ty.Procedure),NEW,ABSTRACT;
228
229 PROCEDURE (os : MsilFile)CallCT*(proc : Id.Procs;
230 type : Ty.Procedure),NEW,ABSTRACT;
231
232 PROCEDURE (os : MsilFile)CallDelegate*(typ : Ty.Procedure),NEW,ABSTRACT;
233
234
235 (* ============================================================ *)
236 (* Various element access abstractions *)
237 (* ============================================================ *)
238
239 PROCEDURE (os : MsilFile)PutGetS*(code : INTEGER;
240 blk : Id.BlkId;
241 fld : Id.VarId),NEW,ABSTRACT;
242
243 PROCEDURE (os : MsilFile)PutGetF*(code : INTEGER;
244 fld : Id.FldId),NEW,ABSTRACT;
245
246 PROCEDURE (os : MsilFile)GetValObj*(code : INTEGER;
247 ptrT : Ty.Pointer),NEW,ABSTRACT;
248
249 PROCEDURE (os : MsilFile)PutGetXhr*(code : INTEGER;
250 proc : Id.Procs;
251 locD : Id.LocId),NEW,ABSTRACT;
252
253 (* ============================================================ *)
254 (* Line and Label handling *)
255 (* ============================================================ *)
256
257 PROCEDURE (os : MsilFile)Line*(nm : INTEGER),NEW,ABSTRACT;
258
259 PROCEDURE (os : MsilFile)LinePlus*(l,w : INTEGER),NEW,EMPTY;
260
261 PROCEDURE (os : MsilFile)LineSpan*(span : Scn.Span),NEW,EMPTY;
262
263 PROCEDURE (os : MsilFile)LstLab*(l : Label),NEW,ABSTRACT;
264
265 PROCEDURE (os : MsilFile)DefLab*(l : Label),NEW,ABSTRACT;
266
267 PROCEDURE (os : MsilFile)DefLabC*(l : Label;
268 IN c : ARRAY OF CHAR),NEW,ABSTRACT;
269
270 (* ============================================================ *)
271 (* Declaration utilities *)
272 (* ============================================================ *)
273
274 PROCEDURE (os : MsilFile)EmitField*(id : Id.AbVar; att : SET),NEW,ABSTRACT;
275
276 PROCEDURE (os : MsilFile)ExternList*(),NEW,ABSTRACT;
277
278 PROCEDURE (os : MsilFile)MarkInterfaces*(IN seq : Sy.TypeSeq),NEW,ABSTRACT;
279
280 (* ============================================================ *)
281 (* Start and finish various structures *)
282 (* ============================================================ *)
283
284 PROCEDURE (os : MsilFile)SwitchHead*(num : INTEGER),NEW,ABSTRACT;
285
286 PROCEDURE (os : MsilFile)SwitchTail*(),NEW,ABSTRACT;
287
288 (* ------------------------------------------------------------ *)
289
290 PROCEDURE (os : MsilFile)Try*(),NEW,ABSTRACT;
291 PROCEDURE (os : MsilFile)Catch*(proc : Id.Procs),NEW,ABSTRACT;
292 PROCEDURE (os : MsilFile)CloseCatch*(),NEW,ABSTRACT;
293
294 (* ------------------------------------------------------------ *)
295
296 PROCEDURE (os : MsilFile)MkNewProcVal*(p : Sy.Idnt; t : Sy.Type),NEW,ABSTRACT;
297
298 (* ------------------------------------------------------------ *)
299
300 PROCEDURE (os : MsilFile)InitHead*(typ : Ty.Record;
301 prc : Id.PrcId),NEW,ABSTRACT;
302
303 PROCEDURE (os : MsilFile)CallSuper*(typ : Ty.Record;
304 prc : Id.PrcId),NEW,ABSTRACT;
305
306 PROCEDURE (os : MsilFile)InitTail*(typ : Ty.Record),NEW,ABSTRACT;
307
308 (* ------------------------------------------------------------ *)
309
310 PROCEDURE (os : MsilFile)CopyHead*(typ : Ty.Record),NEW,ABSTRACT;
311
312 PROCEDURE (os : MsilFile)CopyTail*(),NEW,ABSTRACT;
313
314 (* ------------------------------------------------------------ *)
315
316 PROCEDURE (os : MsilFile)MainHead*(xAtt : SET),NEW,ABSTRACT;
317
318 PROCEDURE (os : MsilFile)MainTail*(),NEW,ABSTRACT;
319
320 (* ------------------------------------------------------------ *)
321
322 PROCEDURE (os : MsilFile)ClinitHead*(),NEW,ABSTRACT;
323
324 PROCEDURE (os : MsilFile)ClinitTail*(),NEW,ABSTRACT;
325
326 (* ------------------------------------------------------------ *)
327
328 PROCEDURE (os : MsilFile)MethodDecl*(attr : SET;
329 proc : Id.Procs),NEW,ABSTRACT;
330
331 PROCEDURE (os : MsilFile)MethodTail*(id : Id.Procs),NEW,ABSTRACT;
332
333 (* ============================================================ *)
334 (* Start of Procedure Variable and Event Stuff *)
335 (* ============================================================ *)
336
337 PROCEDURE (os : MsilFile)EmitEventMethods*(id : Id.AbVar),NEW,ABSTRACT;
338
339 PROCEDURE (os : MsilFile)EmitPTypeBody*(tId : Id.TypId),NEW,ABSTRACT;
340
341 PROCEDURE (os : MsilFile)MkAndLinkDelegate*(dl : Sy.Idnt;
342 id : Sy.Idnt;
343 ty : Sy.Type;
344 add : BOOLEAN),NEW,ABSTRACT;
345
346 (* ============================================================ *)
347 (* End of Procedure Variable and Event Stuff *)
348 (* ============================================================ *)
349
350 (* ==================================================================== *
351 * A word on naming for the ILASM version. *
352 * ==================================================================== *
353 * Part one: module-level declarations, in Module Mmm. *
354 * TYPE Ttt = POINTER TO RECORD ... END; *
355 * has ilasm class name *
356 * .class <attr> Mmm.Ttt { ... } *
357 * Similarly the static procedure *
358 * PROCEDURE Ppp(); END Ppp; *
359 * has ilasm method name (inside static class Mmm) *
360 * .method <attr> void Ppp() {...} *
361 * which is referenced as *
362 * Ppp(...) within the static class, & *
363 * Mmm::Ppp(...) elswhere inside the module, & *
364 * [Mmm]Mmm::Ppp(...) from outside the module. *
365 * Likewise, methods bound to Ttt will be referenced as *
366 * Ppp(...) inside the dynamic class, & *
367 * Mmm.Ttt::Ppp(...) elsewhere inside the module, & *
368 * [Mmm]Mmm.Ttt::Ppp(...) from outside the module. *
369 * *
370 * ==================================================================== *
371 * Part two: declarations nested inside procedure Outer (say). *
372 * PROCEDURE Ppp(); END Ppp; *
373 * will have ilasm name (inside Mmm) *
374 * .method <attr> void Outer@Ppp() {...} *
375 * which is referenced as *
376 * Outer@Ppp(...) *
377 * Nested type Ttt will have name *
378 * .struct(?) <attr> Mmm.Outer@Ttt {...} *
379 * and cannot have type bound procedures, or be exported. *
380 * *
381 * ==================================================================== *
382 * Where are these names stored? *
383 * The principle is: every identifier has its class name stored in *
384 * in d.scopeNm, and its simple name is stored in d.xName. *
385 * Thus, for names defined in this module: *
386 * ==================================================================== *
387 * The name for BlkId Mmm is stored in desc.xName, as *
388 * desc.xName = "Mmm" *
389 * desc.scopeNm = "Mmm" *
390 * The names for PrcId Ppp are stored as *
391 * desc.xName = "Ppp" *
392 * desc.scopeNm = "Mmm" *
393 * or in the nested case... *
394 * desc.xName = "Outer@Ppp" *
395 * desc.scopeNm = "Mmm" *
396 * The names for (non-nested) MthId Ppp are stored as *
397 * desc.xName = "Ppp" *
398 * desc.scopeNm = "Mmm.Ttt" *
399 * *
400 * For types, the names are stored thuswise. *
401 * The name for Record descriptor Ttt will be *
402 * recT.xName = "Mmm_Ttt" *
403 * recT.scopeNm = "Mmm_Ttt" *
404 * or in the nested case ... *
405 * recT.xName = "Mmm_Ppp@Ttt" *
406 * recT.scopeNm = "Mmm_Ppp@Ttt" *
407 * *
408 * ==================================================================== *
409 * Where are these names stored? For external names: *
410 * ==================================================================== *
411 * The name for BlkId Mmm is stored in desc.xName, as *
412 * desc.xName = "Mmm" *
413 * desc.scopeNm = "[Mmm]Mmm" *
414 * The names for PrcId Ppp are stored as *
415 * desc.xName = "Ppp" *
416 * desc.scopeNm = "[Mmm]Mmm" *
417 * The names for (non-nested) MthId Ppp are stored as *
418 * desc.xName = "Ppp" *
419 * desc.scopeNm = "[Mmm]Mmm_Ttt" *
420 * *
421 * For types, the names are stored thuswise. *
422 * The name for Record descriptor Ttt will be *
423 * recT.xName = "Mmm_Ttt" *
424 * recT.scopeNm = "[Mmm]Mmm_Ttt" *
425 * ==================================================================== *
426 * ==================================================================== *)
427
428
429 (* ============================================================ *)
430 (* Some static utilities *)
431 (* ============================================================ *)
432
433 PROCEDURE cat2*(i,j : Lv.CharOpen) : Lv.CharOpen;
434 BEGIN
435 Lv.ResetCharOpenSeq(nmArray);
436 Lv.AppendCharOpen(nmArray, i);
437 Lv.AppendCharOpen(nmArray, j);
438 RETURN Lv.arrayCat(nmArray);
439 END cat2;
440
441 (* ============================================================ *)
442
443 PROCEDURE cat3*(i,j,k : Lv.CharOpen) : Lv.CharOpen;
444 BEGIN
445 Lv.ResetCharOpenSeq(nmArray);
446 Lv.AppendCharOpen(nmArray, i);
447 Lv.AppendCharOpen(nmArray, j);
448 Lv.AppendCharOpen(nmArray, k);
449 RETURN Lv.arrayCat(nmArray);
450 END cat3;
451
452 (* ============================================================ *)
453
454 PROCEDURE cat4*(i,j,k,l : Lv.CharOpen) : Lv.CharOpen;
455 BEGIN
456 Lv.ResetCharOpenSeq(nmArray);
457 Lv.AppendCharOpen(nmArray, i);
458 Lv.AppendCharOpen(nmArray, j);
459 Lv.AppendCharOpen(nmArray, k);
460 Lv.AppendCharOpen(nmArray, l);
461 RETURN Lv.arrayCat(nmArray);
462 END cat4;
463
464 (* ============================================================ *)
465
466 PROCEDURE mapVecElTp(typ : Sy.Type) : INTEGER;
467 BEGIN
468 WITH typ : Ty.Base DO
469 CASE typ.tpOrd OF
470 | Ty.sChrN : RETURN Ty.charN;
471 | Ty.boolN, Ty.byteN, Ty.sIntN, Ty.setN, Ty.uBytN : RETURN Ty.intN;
472 | Ty.charN, Ty.intN, Ty.lIntN, Ty.sReaN, Ty.realN : RETURN typ.tpOrd;
473 ELSE RETURN Ty.anyPtr;
474 END;
475 ELSE RETURN Ty.anyPtr;
476 END;
477 END mapVecElTp;
478
479
480 PROCEDURE mapOrdRepT(ord : INTEGER) : Sy.Type;
481 BEGIN
482 CASE ord OF
483 | Ty.charN : RETURN Bi.charTp;
484 | Ty.intN : RETURN Bi.intTp;
485 | Ty.lIntN : RETURN Bi.lIntTp;
486 | Ty.sReaN : RETURN Bi.sReaTp;
487 | Ty.realN : RETURN Bi.realTp;
488 | Ty.anyPtr : RETURN Bi.anyPtr;
489 END;
490 END mapOrdRepT;
491
492 (* ============================================================ *)
493
494 PROCEDURE^ MkProcName*(proc : Id.Procs; os : MsilFile);
495 PROCEDURE^ MkAliasName*(typ : Ty.Opaque; os : MsilFile);
496 PROCEDURE^ MkEnumName*(typ : Ty.Enum; os : MsilFile);
497 PROCEDURE^ MkTypeName*(typ : Sy.Type; fil : MsilFile);
498 PROCEDURE^ MkRecName*(typ : Ty.Record; os : MsilFile);
499 PROCEDURE^ MkPtrName*(typ : Ty.Pointer; os : MsilFile);
500 PROCEDURE^ MkPTypeName*(typ : Ty.Procedure; os : MsilFile);
501 PROCEDURE^ MkIdName*(id : Sy.Idnt; os : MsilFile);
502 PROCEDURE^ MkBasName(typ : Ty.Base; os : MsilFile);
503 PROCEDURE^ MkArrName(typ : Ty.Array; os : MsilFile);
504 PROCEDURE^ MkVecName(typ : Ty.Vector; os : MsilFile);
505
506 PROCEDURE^ (os : MsilFile)PutUplevel*(var : Id.LocId),NEW;
507 PROCEDURE^ (os : MsilFile)PushInt*(num : INTEGER),NEW;
508 PROCEDURE^ (os : MsilFile)GetVar*(id : Sy.Idnt),NEW;
509 PROCEDURE^ (os : MsilFile)GetVarA*(id : Sy.Idnt),NEW;
510 PROCEDURE^ (os : MsilFile)PushLocal*(ord : INTEGER),NEW;
511 PROCEDURE^ (os : MsilFile)StoreLocal*(ord : INTEGER),NEW;
512 PROCEDURE^ (os : MsilFile)FixCopies(prId : Sy.Idnt),NEW;
513 PROCEDURE^ (os : MsilFile)DecTemp(ord : INTEGER),NEW;
514 PROCEDURE^ (os : MsilFile)PutElem*(typ : Sy.Type),NEW;
515 PROCEDURE^ (os : MsilFile)GetElem*(typ : Sy.Type),NEW;
516
517 (* ------------------------------------------------------------ *)
518
519 PROCEDURE takeAdrs*(i : Id.ParId) : BOOLEAN;
520 (* A parameter needs to have its address taken iff *)
521 (* * Param Mode is VAL & FALSE *)
522 (* * Param Mode is VAR & type is value class or scalar *)
523 (* * Param Mode is OUT & type is value class or scalar *)
524 (* * Param Mode is IN & type is value class *)
525 (* (IN Scalars get treated as VAL on the caller side) *)
526 VAR type : Sy.Type;
527 BEGIN
528 IF i.parMod = Sy.val THEN RETURN FALSE END;
529
530 IF i.type IS Ty.Opaque THEN i.type := i.type(Ty.Opaque).resolved END;
531
532 type := i.type;
533 WITH type : Ty.Vector DO RETURN i.parMod # Sy.in;
534 | type : Ty.Array DO RETURN FALSE;
535 | type : Ty.Record DO RETURN ~(Sy.clsTp IN type.xAttr);
536 ELSE (* scalar type *) RETURN i.parMod # Sy.in;
537 END;
538 END takeAdrs;
539
540 (* ------------------------------------------------------------ *)
541
542 PROCEDURE needsInit*(type : Sy.Type) : BOOLEAN;
543 BEGIN
544 WITH type : Ty.Vector DO RETURN FALSE;
545 | type : Ty.Array DO RETURN type.length # 0;
546 | type : Ty.Record DO RETURN Sy.clsTp IN type.xAttr;
547 ELSE (* scalar type *) RETURN FALSE;
548 END;
549 END needsInit;
550
551 (* ------------------------------------------------------------ *)
552
553 PROCEDURE isRefSurrogate*(type : Sy.Type) : BOOLEAN;
554 BEGIN
555 WITH type : Ty.Array DO RETURN type.kind # Ty.vecTp;
556 | type : Ty.Record DO RETURN Sy.clsTp IN type.xAttr;
557 ELSE (* scalar type *) RETURN FALSE;
558 END;
559 END isRefSurrogate;
560
561 (* ------------------------------------------------------------ *)
562
563 PROCEDURE hasValueRep*(type : Sy.Type) : BOOLEAN;
564 BEGIN
565 WITH type : Ty.Array DO RETURN type.kind = Ty.vecTp;
566 | type : Ty.Record DO RETURN ~(Sy.clsTp IN type.xAttr);
567 ELSE (* scalar type *) RETURN TRUE;
568 END;
569 END hasValueRep;
570
571 (* ------------------------------------------------------------ *)
572
573 PROCEDURE isValRecord*(type : Sy.Type) : BOOLEAN;
574 BEGIN
575 WITH type : Ty.Array DO RETURN FALSE;
576 | type : Ty.Record DO RETURN ~(Sy.clsTp IN type.xAttr);
577 ELSE (* scalar type *) RETURN FALSE;
578 END;
579 END isValRecord;
580
581 (* ------------------------------------------------------------ *)
582
583 PROCEDURE vecMod() : Id.BlkId;
584 BEGIN
585 IF vecBlkId = NIL THEN
586 Bi.MkDummyImport("RTS_Vectors", "[RTS]Vectors", vecBlkId);
587 Bi.MkDummyClass("VecBase", vecBlkId, Ty.noAtt, vecBase);
588 END;
589 RETURN vecBlkId;
590 END vecMod;
591
592 PROCEDURE vecClass(ord : INTEGER) : Id.TypId;
593 VAR str : ARRAY 8 OF CHAR;
594 tId : Id.TypId;
595 rcT : Ty.Record;
596 BEGIN
597 IF vecTypes[ord] = NIL THEN
598 CASE ord OF
599 | Ty.charN : str := "VecChr";
600 | Ty.intN : str := "VecI32";
601 | Ty.lIntN : str := "VecI64";
602 | Ty.sReaN : str := "VecR32";
603 | Ty.realN : str := "VecR64";
604 | Ty.anyPtr : str := "VecRef";
605 END;
606 Bi.MkDummyClass(str, vecMod(), Ty.noAtt, tId);
607 rcT := tId.type.boundRecTp()(Ty.Record);
608 rcT.baseTp := vecBase.type.boundRecTp();
609 vecTypes[ord] := tId;
610 END;
611 RETURN vecTypes[ord];
612 END vecClass;
613
614 PROCEDURE vecRecord(ord : INTEGER) : Ty.Record;
615 BEGIN
616 RETURN vecClass(ord).type.boundRecTp()(Ty.Record);
617 END vecRecord;
618
619 PROCEDURE vecArray(ord : INTEGER) : Id.FldId;
620 VAR fld : Id.FldId;
621 BEGIN
622 IF vecElms[ord] = NIL THEN
623 fld := Id.newFldId();
624 fld.hash := NameHash.enterStr("elms");
625 fld.dfScp := vecMod();
626 fld.recTyp := vecRecord(ord);
627 fld.type := Ty.mkArrayOf(mapOrdRepT(ord));
628 vecElms[ord] := fld;
629 END;
630 RETURN vecElms[ord];
631 END vecArray;
632
633 (* ------------------------------------------------------------ *)
634
635 PROCEDURE vecArrFld*(typ : Ty.Vector; os : MsilFile) : Id.FldId;
636 VAR fld : Id.FldId;
637 BEGIN
638 fld := vecArray(mapVecElTp(typ.elemTp));
639 IF fld.recTyp.xName = NIL THEN MkRecName(fld.recTyp(Ty.Record), os) END;
640 RETURN fld;
641 END vecArrFld;
642
643 PROCEDURE vecRepTyp*(typ : Ty.Vector) : Sy.Type;
644 BEGIN
645 RETURN vecClass(mapVecElTp(typ.elemTp)).type;
646 END vecRepTyp;
647
648 PROCEDURE vecRepElTp*(typ : Ty.Vector) : Sy.Type;
649 BEGIN
650 RETURN mapOrdRepT(mapVecElTp(typ.elemTp));
651 END vecRepElTp;
652
653 PROCEDURE vecLeng*(os : MsilFile) : Id.FldId;
654 BEGIN
655 IF vecTide = NIL THEN
656 vecTide := Id.newFldId();
657 vecTide.hash := NameHash.enterStr("tide");
658 vecTide.dfScp := vecMod();
659 vecTide.recTyp := vecBase.type.boundRecTp();
660 vecTide.type := Bi.intTp;
661 MkRecName(vecTide.recTyp(Ty.Record), os);
662 END;
663 RETURN vecTide;
664 END vecLeng;
665
666 (* ------------------------------------------------------------ *)
667
668 PROCEDURE (os : MsilFile)InvokeExpand*(typ : Ty.Vector),NEW;
669 (* Assert: vector ref is on stack *)
670 VAR ord : INTEGER;
671 xpd : Id.MthId;
672 xpT : Ty.Procedure;
673 BEGIN
674 ord := mapVecElTp(typ.elemTp);
675 xpd := vecExpnd[ord];
676 IF xpd = NIL THEN
677 xpd := Id.newMthId();
678 xpd.hash := Bi.xpndBk;
679 xpd.dfScp := vecMod();
680 xpT := Ty.newPrcTp();
681 xpT.idnt := xpd;
682 xpT.receiver := vecClass(ord).type;
683 xpd.bndType := xpT.receiver.boundRecTp();
684 MkProcName(xpd, os);
685 os.NumberParams(xpd, xpT);
686 xpd.type := xpT;
687 vecExpnd[ord] := xpd;
688 END;
689 os.CallIT(Asm.opc_callvirt, xpd, xpd.type(Ty.Procedure));
690 END InvokeExpand;
691
692 (* ------------------------------------------------------------ *)
693 (* ------------------------------------------------------------ *)
694
695 PROCEDURE xhrCount(tgt, ths : Id.Procs) : INTEGER;
696 VAR count : INTEGER;
697 BEGIN
698 IF ths.lxDepth = 0 THEN RETURN 0 END;
699 (*
700 * "ths" is the calling procedure.
701 * "tgt" is the procedure with the uplevel data.
702 *)
703 count := 0;
704 REPEAT
705 ths := ths.dfScp(Id.Procs);
706 IF Id.hasXHR IN ths.pAttr THEN INC(count) END;
707 UNTIL (ths.lxDepth = 0) OR
708 ((ths.lxDepth <= tgt.lxDepth) & (Id.hasXHR IN ths.pAttr));
709 RETURN count;
710 END xhrCount;
711
712 PROCEDURE newXHR() : Lv.CharOpen;
713 BEGIN
714 INC(xhrIx);
715 RETURN cat2(xhrDl, Lv.intToCharOpen(xhrIx));
716 END newXHR;
717
718 PROCEDURE MkXHR(scp : Id.Procs);
719 VAR typId : Id.TypId;
720 recTp : Ty.Record;
721 index : INTEGER;
722 locVr : Id.LocId;
723 fldVr : Id.FldId;
724 BEGIN
725 (*
726 * Create a type descriptor for the eXplicit
727 * Heap-allocated activation Record. This is
728 * an extension of the [RTS]XHR system type.
729 *)
730 Bi.MkDummyClass(newXHR(), CSt.thisMod, Ty.noAtt, typId);
731 typId.SetMode(Sy.prvMode);
732 scp.xhrType := typId.type;
733 recTp := typId.type.boundRecTp()(Ty.Record);
734 recTp.baseTp := CSt.rtsXHR.boundRecTp();
735 INCL(recTp.xAttr, Sy.noCpy);
736
737 FOR index := 0 TO scp.locals.tide-1 DO
738 locVr := scp.locals.a[index](Id.LocId);
739 IF Id.uplevA IN locVr.locAtt THEN
740 fldVr := Id.newFldId();
741 fldVr.hash := locVr.hash;
742 fldVr.type := locVr.type;
743 fldVr.recTyp := recTp;
744 Sy.AppendIdnt(recTp.fields, fldVr);
745 END;
746 END;
747 END MkXHR;
748
749 (* ============================================================ *)
750 (* ProcInfo Methods *)
751 (* ============================================================ *)
752
753 PROCEDURE InitProcInfo*(info : ProcInfo; proc : Sy.Scope);
754 VAR i : INTEGER;
755 BEGIN
756 (*
757 * Assert: the locals have already been numbered
758 * by a call to NumberLocals(), and
759 * rtsFram has been set accordingly.
760 *)
761 info.prId := proc;
762 WITH proc : Id.Procs DO
763 info.lNum := proc.rtsFram;
764 IF info.lNum > 0 THEN
765 Sy.InitTypeSeq(info.tLst, info.lNum * 2); (* the (t)ypeList *)
766 Sy.InitTypeSeq(info.fLst, info.lNum * 2); (* the (f)reeList *)
767 FOR i := 0 TO info.lNum-1 DO
768 Sy.AppendType(info.tLst, NIL);
769 Sy.AppendType(info.fLst, NIL);
770 END;
771 END;
772 ELSE (* Id.BlkId *)
773 info.lNum := 0;
774 END;
775 info.dNum := 0;
776 info.dMax := 0;
777 info.rtLc := -1; (* maybe different for IlasmUtil and PeUtil? *)
778 END InitProcInfo;
779
780 (* ------------------------------------------------------------ *)
781
782 PROCEDURE (info : ProcInfo)newLocal*(typ : Sy.Type) : INTEGER,NEW;
783 VAR ord : INTEGER;
784 BEGIN
785 (*
786 * We try to find a previously allocated, but
787 * currently free slot of the identical type.
788 *)
789 FOR ord := info.lNum TO info.tLst.tide-1 DO
790 IF typ.equalType(info.fLst.a[ord]) THEN
791 info.fLst.a[ord] := NIL; (* mark ord as used *)
792 RETURN ord;
793 END;
794 END;
795 (* Free slot of correct type not found *)
796 ord := info.tLst.tide;
797 Sy.AppendType(info.tLst, typ);
798 Sy.AppendType(info.fLst, NIL);
799 RETURN ord;
800 END newLocal;
801
802 (* ------------------------------------------------------------ *)
803
804 PROCEDURE (info : ProcInfo)ReleaseLocal*(ord : INTEGER),NEW;
805 BEGIN
806 info.fLst.a[ord] := info.tLst.a[ord];
807 END ReleaseLocal;
808
809 (* ------------------------------------------------------------ *)
810
811 PROCEDURE (info : ProcInfo)numLocals*() : INTEGER,NEW;
812 BEGIN
813 RETURN info.tLst.tide;
814 END numLocals;
815
816 (* ------------------------------------------------------------ *)
817
818 PROCEDURE (info : ProcInfo)SetDepth*(d : INTEGER),NEW;
819 BEGIN
820 info.dNum := d;
821 END SetDepth;
822
823 (* ------------------------------------------------------------ *)
824
825 PROCEDURE (info : ProcInfo)getDepth*() : INTEGER,NEW;
826 BEGIN
827 RETURN info.dNum;
828 END getDepth;
829
830 (* ============================================================ *)
831 (* Private Methods *)
832 (* ============================================================ *)
833
834
835 PROCEDURE typeName*(typ : Sy.Type; os : MsilFile) : Lv.CharOpen;
836 BEGIN
837 IF typ.xName = NIL THEN MkTypeName(typ, os) END;
838 WITH typ : Ty.Base DO
839 RETURN typ.xName;
840 | typ : Ty.Array DO
841 RETURN typ.xName;
842 | typ : Ty.Record DO
843 RETURN typ.scopeNm;
844 | typ : Ty.Pointer DO
845 RETURN typ.xName;
846 | typ : Ty.Opaque DO
847 RETURN typ.xName;
848 | typ : Ty.Enum DO
849 RETURN typ.xName;
850 | typ : Ty.Procedure DO
851 RETURN typ.tName;
852 END;
853 END typeName;
854
855 (* ============================================================ *)
856
857 PROCEDURE boxedName*(typ : Ty.Record; os : MsilFile) : Lv.CharOpen;
858 BEGIN
859 IF typ.xName = NIL THEN MkRecName(typ, os) END;
860 RETURN cat3(typ.idnt.dfScp.scopeNm, boxedObj, typ.xName);
861 END boxedName;
862
863 (* ============================================================ *)
864
865 PROCEDURE MkTypeName*(typ : Sy.Type; fil : MsilFile);
866 BEGIN
867 WITH typ : Ty.Vector DO MkVecName(typ, fil);
868 | typ : Ty.Array DO MkArrName(typ, fil);
869 | typ : Ty.Base DO MkBasName(typ, fil);
870 | typ : Ty.Record DO MkRecName(typ, fil);
871 | typ : Ty.Pointer DO MkPtrName(typ, fil);
872 | typ : Ty.Opaque DO MkAliasName(typ, fil);
873 | typ : Ty.Enum DO MkEnumName(typ, fil);
874 | typ : Ty.Procedure DO MkPTypeName(typ, fil);
875 END;
876 END MkTypeName;
877
878 (* ============================================================ *)
879 (* Exported Methods *)
880 (* ============================================================ *)
881
882 PROCEDURE (os : MsilFile)Adjust*(delta : INTEGER),NEW;
883 BEGIN
884 INC(os.proc.dNum, delta);
885 IF os.proc.dNum > os.proc.dMax THEN os.proc.dMax := os.proc.dNum END;
886 END Adjust;
887
888 (* ============================================================ *)
889
890 PROCEDURE (os : MsilFile)newLabel*() : Label,NEW,ABSTRACT;
891
892 (* ============================================================ *)
893
894 PROCEDURE (os : MsilFile)getLabelRange*(num : INTEGER) : LbArr,NEW;
895 VAR arr : LbArr;
896 idx : INTEGER;
897 BEGIN
898 NEW(arr, num);
899 FOR idx := 0 TO num-1 DO arr[idx] := os.newLabel() END;
900 RETURN arr;
901 END getLabelRange;
902
903 (* ============================================================ *)
904
905 PROCEDURE (os : MsilFile)EndCatch*(),NEW,EXTENSIBLE;
906 BEGIN
907 os.CloseCatch();
908 os.DefLab(os.proc.exLb);
909 IF os.proc.rtLc # -1 THEN os.PushLocal(os.proc.rtLc) END;
910 os.FixCopies(os.proc.prId);
911 os.Code(Asm.opc_ret);
912 END EndCatch;
913
914 (* ============================================================ *)
915
916 PROCEDURE (os : MsilFile)DoReturn*(),NEW;
917 VAR pTyp : Sy.Type;
918 BEGIN
919 IF os.proc.exLb = NIL THEN
920 os.FixCopies(os.proc.prId);
921 os.Code(Asm.opc_ret);
922 pTyp := os.proc.prId.type;
923 IF (pTyp # NIL) & (pTyp.returnType() # NIL) THEN DEC(os.proc.dNum) END;
924 ELSE
925 IF os.proc.rtLc # -1 THEN os.StoreLocal(os.proc.rtLc) END;
926 os.CodeLb(Asm.opc_leave, os.proc.exLb);
927 END;
928 END DoReturn;
929
930
931 (* ============================================================ *)
932
933 PROCEDURE (os : MsilFile)MkFixedArray*(arTp : Ty.Array),NEW;
934 VAR cTmp : INTEGER; (* card'ty of this dim. *)
935 aTmp : INTEGER; (* array reference temp *)
936 labl : Label;
937 elTp : Sy.Type;
938 aLen : INTEGER;
939 BEGIN
940 ASSERT(arTp.length # 0);
941 elTp := arTp.elemTp;
942 aLen := arTp.length;
943 os.PushInt(aLen);
944 (* os.CodeTn(Asm.opc_newarr, elTp); *)
945 os.CodeT(Asm.opc_newarr, elTp);
946 (*
947 * Do we need an initialization loop?
948 *)
949 IF ~hasValueRep(elTp) THEN
950 labl := os.newLabel();
951 cTmp := os.proc.newLocal(Bi.intTp);
952 aTmp := os.proc.newLocal(arTp);
953 os.StoreLocal(aTmp); (* (top)... *)
954 os.PushInt(aLen);
955 os.StoreLocal(cTmp);
956 (*
957 * Now the allocation loop
958 *)
959 os.DefLab(labl);
960 os.DecTemp(cTmp);
961 os.PushLocal(aTmp);
962 os.PushLocal(cTmp);
963 WITH elTp : Ty.Array DO
964 os.MkFixedArray(elTp);
965 | elTp : Ty.Record DO
966 os.MkNewRecord(elTp);
967 END; (* (top)elem,ix,ref,... *)
968 os.PutElem(elTp);
969 (*
970 * Now the termination test
971 *)
972 os.PushLocal(cTmp);
973 os.CodeLb(Asm.opc_brtrue, labl);
974 os.PushLocal(aTmp);
975 os.proc.ReleaseLocal(cTmp);
976 os.proc.ReleaseLocal(aTmp);
977 END;
978 END MkFixedArray;
979
980 (* ============================================================ *)
981
982 PROCEDURE (os : MsilFile)MkVecRec*(eTp : Sy.Type),NEW;
983 VAR ord : INTEGER;
984 BEGIN
985 ord := mapVecElTp(eTp);
986 os.MkNewRecord(vecRecord(ord));
987 END MkVecRec;
988
989 PROCEDURE (os : MsilFile)MkVecArr*(eTp : Sy.Type),NEW;
990 VAR ord : INTEGER;
991 vTp : Sy.Type;
992 BEGIN
993 ord := mapVecElTp(eTp);
994 (*os.CodeTn(Asm.opc_newarr, mapOrdRepT(ord)); *)
995 os.CodeT(Asm.opc_newarr, mapOrdRepT(ord));
996 os.PutGetF(Asm.opc_stfld, vecArray(ord));
997 END MkVecArr;
998
999 (* ============================================================ *)
1000
1001 PROCEDURE (os : MsilFile)MkOpenArray*(arTp : Ty.Array),NEW;
1002 VAR lens : ARRAY 32 OF INTEGER;
1003 elTp : Sy.Type;
1004 (* ----------------------------------------- *)
1005 PROCEDURE GetLengths(os : MsilFile;
1006 dim : INTEGER;
1007 typ : Sy.Type;
1008 VAR lAr : ARRAY OF INTEGER);
1009 VAR tmp : INTEGER;
1010 BEGIN
1011 ASSERT(dim < 31);
1012 WITH typ : Ty.Array DO
1013 IF typ.length = 0 THEN (* another open dimension *)
1014 tmp := os.proc.newLocal(Bi.intTp);
1015 lAr[dim] := tmp;
1016 os.StoreLocal(tmp);
1017 GetLengths(os, dim+1, typ.elemTp, lAr);
1018 END;
1019 ELSE
1020 END;
1021 END GetLengths;
1022 (* ----------------------------------------- *)
1023 PROCEDURE InitLoop(os : MsilFile;
1024 dim : INTEGER;
1025 typ : Ty.Array;
1026 IN lAr : ARRAY OF INTEGER);
1027 VAR aEl : INTEGER;
1028 lab : Label;
1029 elT : Sy.Type;
1030 BEGIN
1031 (*
1032 * Pre : the uninitialized array is on the stack
1033 *)
1034 elT := typ.elemTp;
1035 IF ~hasValueRep(elT) THEN
1036 aEl := os.proc.newLocal(typ);
1037 os.StoreLocal(aEl);
1038 lab := os.newLabel();
1039 (*
1040 * Start of initialization loop
1041 *)
1042 os.DefLab(lab);
1043 (*
1044 * Decrement the loop counter
1045 *)
1046 os.DecTemp(lAr[dim]);
1047 (*
1048 * Assign the array element
1049 *)
1050 os.PushLocal(aEl);
1051 os.PushLocal(lAr[dim]);
1052 WITH elT : Ty.Record DO
1053 os.MkNewRecord(elT);
1054 | elT : Ty.Array DO
1055 IF elT.length > 0 THEN
1056 os.MkFixedArray(elT);
1057 ELSE
1058 os.PushLocal(lAr[dim+1]);
1059 (*os.CodeTn(Asm.opc_newarr, elT.elemTp); *)
1060 os.CodeT(Asm.opc_newarr, elT.elemTp);
1061 InitLoop(os, dim+1, elT, lAr);
1062 END;
1063 END;
1064 os.PutElem(elT);
1065 (*
1066 * Test and branch to loop header
1067 *)
1068 os.PushLocal(lAr[dim]);
1069 os.CodeLb(Asm.opc_brtrue, lab);
1070 (*
1071 * Reload the original array
1072 *)
1073 os.PushLocal(aEl);
1074 os.proc.ReleaseLocal(aEl);
1075 os.proc.ReleaseLocal(lAr[dim]);
1076 END;
1077 (*
1078 * Post : the initialized array is on the stack
1079 *)
1080 END InitLoop;
1081 (* ----------------------------------------- *)
1082 BEGIN
1083 elTp := arTp.elemTp;
1084 IF (elTp IS Ty.Array) OR (elTp IS Ty.Record) THEN
1085 GetLengths(os, 0, arTp, lens);
1086 os.PushLocal(lens[0]);
1087 (*os.CodeTn(Asm.opc_newarr, elTp); *)
1088 os.CodeT(Asm.opc_newarr, elTp);
1089 InitLoop(os, 0, arTp, lens);
1090 ELSE
1091 (*os.CodeTn(Asm.opc_newarr, elTp); *)
1092 os.CodeT(Asm.opc_newarr, elTp);
1093 END;
1094 END MkOpenArray;
1095
1096 (* ============================================================ *)
1097
1098 PROCEDURE (os : MsilFile)MkArrayCopy*(arrT : Ty.Array),NEW;
1099 VAR dims : INTEGER;
1100 elTp : Sy.Type;
1101 (* ----------------------------------- *)
1102 PROCEDURE PushLengths(os : MsilFile; aT : Ty.Array);
1103 BEGIN
1104 IF aT.elemTp IS Ty.Array THEN
1105 os.Code(Asm.opc_dup);
1106 os.Code(Asm.opc_ldc_i4_0);
1107 os.GetElem(aT.elemTp);
1108 PushLengths(os, aT.elemTp(Ty.Array));
1109 END;
1110 os.Code(Asm.opc_ldlen);
1111 END PushLengths;
1112 (* ----------------------------------- *)
1113 BEGIN
1114 (*
1115 * Assert: we must find the lengths from the runtime
1116 * descriptors. The array to copy is on the top of
1117 * stack, which reads - (top) aRef, ...
1118 *)
1119 PushLengths(os, arrT);
1120 os.MkOpenArray(arrT);
1121 END MkArrayCopy;
1122
1123 (* ============================================================ *)
1124
1125 PROCEDURE (os : MsilFile)StructInit*(var : Sy.Idnt),NEW;
1126 VAR typ : Sy.Type;
1127 fld : Sy.Idnt;
1128 idx : INTEGER;
1129 lnk : BOOLEAN;
1130 (* ------------------------------------------------- *)
1131 PROCEDURE Assign(os : MsilFile; id : Sy.Idnt);
1132 VAR md : Id.BlkId;
1133 BEGIN
1134 WITH id : Id.LocId DO
1135 IF id.varOrd # Id.xMark THEN
1136 os.StoreLocal(id.varOrd);
1137 ELSE
1138 os.PutUplevel(id);
1139 END;
1140 | id : Id.FldId DO
1141 os.PutGetF(Asm.opc_stfld, id);
1142 | id : Id.VarId DO
1143 md := id.dfScp(Id.BlkId);
1144 os.PutGetS(Asm.opc_stsfld, md, id);
1145 END;
1146 END Assign;
1147 (* ------------------------------------------------- *)
1148 BEGIN
1149 os.Comment("initialize " + Sy.getName.ChPtr(var)^);
1150 (*
1151 * Precondition: var is of a type that needs initialization,
1152 *)
1153 typ := var.type;
1154 lnk := (var IS Id.LocId) & (var(Id.LocId).varOrd = Id.xMark);
1155 WITH typ : Ty.Array DO
1156 IF lnk THEN os.Code(Asm.opc_ldloc_0) END;
1157 os.MkFixedArray(typ);
1158 Assign(os, var);
1159 | typ : Ty.Record DO
1160 IF Sy.clsTp IN typ.xAttr THEN
1161 (*
1162 * Reference record type
1163 *)
1164 IF lnk THEN os.Code(Asm.opc_ldloc_0) END;
1165 os.MkNewRecord(typ);
1166 Assign(os, var);
1167 ELSE
1168 (*
1169 * Value record type
1170 *)
1171 os.GetVarA(var);
1172 os.CodeTn(Asm.opc_initobj, typ);
1173 END;
1174 ELSE
1175 IF lnk THEN os.Code(Asm.opc_ldloc_0) END;
1176 os.Code(Asm.opc_ldnull);
1177 Assign(os, var);
1178 END;
1179 END StructInit;
1180
1181 (* ============================================================ *)
1182
1183 PROCEDURE (os : MsilFile)PushZero(typ : Sy.Type),NEW;
1184 VAR cde : INTEGER;
1185 BEGIN
1186 WITH typ : Ty.Base DO
1187 CASE typ.tpOrd OF
1188 | Ty.sReaN : os.CodeR(Asm.opc_ldc_r4, 0.0);
1189 | Ty.realN : os.CodeR(Asm.opc_ldc_r8, 0.0);
1190 | Ty.lIntN : os.CodeL(Asm.opc_ldc_i8, 0);
1191 | Ty.charN,
1192 Ty.sChrN : os.Code(Asm.opc_ldc_i4_0);
1193 ELSE os.Code(Asm.opc_ldc_i4_0);
1194 END;
1195 ELSE
1196 os.Code(Asm.opc_ldnull);
1197 END;
1198 END PushZero;
1199
1200 (* ----------------------------------- *)
1201
1202 PROCEDURE (os : MsilFile)ScalarInit*(var : Sy.Idnt),NEW;
1203 VAR typ : Sy.Type;
1204 cde : INTEGER;
1205 BEGIN
1206 os.Comment("initialize " + Sy.getName.ChPtr(var)^);
1207 typ := var.type;
1208 (*
1209 * Precondition: var is of a scalar type that is referenced
1210 *)
1211 os.PushZero(typ);
1212 END ScalarInit;
1213
1214 (* ============================================================ *)
1215
1216 PROCEDURE (os : MsilFile)Throw*(),NEW;
1217 BEGIN
1218 os.CodeS(Asm.opc_newobj, mkExcept);
1219 os.Code(Asm.opc_throw);
1220 END Throw;
1221
1222 (* ============================================================ *)
1223
1224 PROCEDURE (os : MsilFile)Trap*(IN str : ARRAY OF CHAR),NEW;
1225 BEGIN
1226 os.PushStr('"' + str + '"');
1227 os.Throw();
1228 END Trap;
1229
1230 (* ============================================================ *)
1231
1232 PROCEDURE (os : MsilFile)IndexTrap*(),NEW;
1233 BEGIN
1234 os.Comment("IndexTrap");
1235 os.Trap("Vector index out of bounds");
1236 END IndexTrap;
1237
1238 (* ============================================================ *)
1239
1240 PROCEDURE (os : MsilFile)CaseTrap*(i : INTEGER),NEW;
1241 BEGIN
1242 os.Comment("CaseTrap");
1243 os.PushLocal(i);
1244 os.CodeS(Asm.opc_call, caseMesg);
1245 os.CodeS(Asm.opc_newobj, mkExcept);
1246 os.Code(Asm.opc_throw);
1247 END CaseTrap;
1248
1249 (* ============================================================ *)
1250
1251 PROCEDURE (os : MsilFile)WithTrap*(id : Sy.Idnt),NEW;
1252 BEGIN
1253 os.Comment("WithTrap " + Sy.getName.ChPtr(id)^);
1254 os.GetVar(id);
1255 os.CodeS(Asm.opc_call, withMesg);
1256 os.CodeS(Asm.opc_newobj, mkExcept);
1257 os.Code(Asm.opc_throw);
1258 END WithTrap;
1259
1260 (* ============================================================ *)
1261
1262 PROCEDURE EliminatePathFromSrcName(str : Lv.CharOpen): Lv.CharOpen;
1263 VAR
1264 i, idx, len: INTEGER;
1265 rslt: Lv.CharOpen;
1266 BEGIN
1267 FOR idx := LEN(str)-1 TO 0 BY - 1 DO
1268 IF str[idx] = '\' THEN
1269 len := LEN(str) - idx - 1;
1270 NEW (rslt, len);
1271 FOR i := 0 TO len - 2 DO rslt[i] := str[idx+i+1]; END;
1272 rslt[len-1] := 0X;
1273 RETURN rslt;
1274 END;
1275 END; (* FOR *)
1276 RETURN str;
1277 END EliminatePathFromSrcName;
1278
1279 PROCEDURE (os : MsilFile)Header*(IN str : ARRAY OF CHAR),NEW;
1280 VAR date : ARRAY 64 OF CHAR;
1281 BEGIN
1282 os.srcS := Lv.strToCharOpen(
1283 "'" + EliminatePathFromSrcName(Lv.strToCharOpen(str))^ + "'");
1284 RTS.GetDateString(date);
1285 os.Comment("ILASM output produced by GPCP compiler (" +
1286 RTS.defaultTarget + " version)");
1287 os.Comment("at date: " + date);
1288 os.Comment("from source file <" + str + '>');
1289 END Header;
1290
1291
1292 (* ============================================================ *)
1293 (* Namehandling Methods *)
1294 (* ============================================================ *)
1295
1296 PROCEDURE MkBlkName*(mod : Id.BlkId);
1297 VAR mNm : Lv.CharOpen;
1298 (* -------------------------------------------------- *)
1299 PROCEDURE scpMangle(mod : Id.BlkId) : Lv.CharOpen;
1300 VAR outS : Lv.CharOpen;
1301 BEGIN
1302 IF mod.kind = Id.impId THEN
1303 outS := cat4(lBrk,mod.pkgNm,rBrk,mod.xName);
1304 ELSE
1305 outS := mod.xName;
1306 END;
1307 IF LEN(mod.xName$) > 0 THEN outS := cat2(outS, dotS) END;
1308 RETURN outS;
1309 END scpMangle;
1310 (* -------------------------------------------------- *)
1311 PROCEDURE nmSpaceOf(mod : Id.BlkId) : Lv.CharOpen;
1312 VAR ix : INTEGER;
1313 ln : INTEGER;
1314 ch : CHAR;
1315 inS : Lv.CharOpen;
1316 BEGIN
1317 inS := mod.scopeNm;
1318 IF inS[0] # '[' THEN
1319 RETURN inS;
1320 ELSE
1321 ln := LEN(inS);
1322 ix := 0;
1323 REPEAT
1324 ch := inS[ix];
1325 INC(ix);
1326 UNTIL (ix = LEN(inS)) OR (ch = ']');
1327 RETURN Lv.subChOToChO(inS, ix, ln-ix);
1328 END;
1329 END nmSpaceOf;
1330 (* -------------------------------------------------- *)
1331 PROCEDURE pkgNameOf(mod : Id.BlkId) : Lv.CharOpen;
1332 VAR ix : INTEGER;
1333 ln : INTEGER;
1334 ch : CHAR;
1335 inS : Lv.CharOpen;
1336 BEGIN
1337 inS := mod.scopeNm;
1338 IF inS[0] # '[' THEN
1339 RETURN mod.clsNm;
1340 ELSE
1341 INCL(mod.xAttr, Sy.isFn); (* make sure this is marked foreign *)
1342 ln := LEN(inS);
1343 ix := 0;
1344 REPEAT
1345 ch := inS[ix];
1346 INC(ix);
1347 UNTIL (ix = LEN(inS)) OR (ch = ']');
1348 RETURN Lv.subChOToChO(inS, 1, ix-2);
1349 END;
1350 END pkgNameOf;
1351 (* -------------------------------------------------- *)
1352 BEGIN
1353 IF mod.xName # NIL THEN RETURN END;
1354 mNm := Sy.getName.ChPtr(mod);
1355 IF mod.scopeNm # NIL THEN
1356 IF mod.clsNm = NIL THEN
1357 mod.clsNm := mNm; (* dummy class name *)
1358 END;
1359 mod.pkgNm := pkgNameOf(mod); (* assembly filename *)
1360 mod.xName := nmSpaceOf(mod); (* namespace name *)
1361 mod.scopeNm := scpMangle(mod); (* class prefix name *)
1362 ELSE
1363 mod.clsNm := mNm; (* dummy class name *)
1364 mod.pkgNm := mNm; (* assembly filename *)
1365 mod.xName := mNm; (* namespace name *)
1366 (*
1367 * In the normal case, the assembly name is the
1368 * same as the module name. However, system
1369 * modules always have the assembly name "RTS".
1370 *)
1371 IF Sy.rtsMd IN mod.xAttr THEN
1372 mod.scopeNm := cat3(lBrk, rtsS, rBrk);
1373 ELSE
1374 mod.scopeNm := scpMangle(mod); (* class prefix name *)
1375 END;
1376 END;
1377 END MkBlkName;
1378
1379 (* ------------------------------------------------------------ *)
1380
1381 PROCEDURE (os : MsilFile)CheckNestedClass*(typ : Ty.Record;
1382 scp : Sy.Scope;
1383 rNm : Lv.CharOpen),NEW,ABSTRACT;
1384
1385 (* ------------------------------------------------------------ *
1386 *
1387 *PROCEDURE StrSubChr(str: Lv.CharOpen;
1388 * ch1, ch2: CHAR): Lv.CharOpen;
1389 * VAR i, len: INTEGER;
1390 * rslt: Lv.CharOpen;
1391 *BEGIN
1392 * (*
1393 * * copy str to rslt with all occurences of
1394 * * ch1 replaced by ch2, except at index 0
1395 * *)
1396 * len := LEN(str); NEW(rslt, len);
1397 * rslt[0] := str[0];
1398 * FOR i := 1 TO len-1 DO
1399 * IF str[i] # ch1 THEN rslt[i] := str[i] ELSE rslt[i] := ch2 END;
1400 * END; (* FOR *)
1401 * RETURN rslt;
1402 *END StrSubChr;
1403 *
1404 * ------------------------------------------------------------ *)
1405
1406 PROCEDURE MkRecName*(typ : Ty.Record; os : MsilFile);
1407 VAR mNm : Lv.CharOpen; (* prefix scope name *)
1408 rNm : Lv.CharOpen; (* simple name of type *)
1409 tId : Sy.Idnt;
1410 scp : Sy.Scope;
1411 (* ---------------------------------- *
1412 * The choice below may need revision *
1413 * depending on any decison about the *
1414 * format of foreign type-names *
1415 * extracted from the metadata. *
1416 * ---------------------------------- *)
1417 PROCEDURE unmangle(arr : Lv.CharOpen) : Lv.CharOpen;
1418 BEGIN
1419 RETURN arr;
1420 END unmangle;
1421 (* ---------------------------------------------------------- *)
1422 BEGIN
1423 IF typ.xName # NIL THEN RETURN END;
1424
1425 IF (typ.baseTp IS Ty.Record) &
1426 (typ.baseTp.xName = NIL) THEN MkRecName(typ.baseTp(Ty.Record), os) END;
1427
1428 IF typ.bindTp # NIL THEN (* Synthetically named rec'd *)
1429 tId := typ.bindTp.idnt;
1430 rNm := Sy.getName.ChPtr(tId);
1431 ELSE (* Normal, named record type *)
1432 IF typ.idnt = NIL THEN (* Anonymous record type *)
1433 typ.idnt := Id.newAnonId(typ.serial);
1434 typ.idnt.type := typ;
1435 END;
1436 tId := typ.idnt;
1437 rNm := Sy.getName.ChPtr(tId);
1438 END;
1439
1440 IF tId.dfScp = NIL THEN tId.dfScp := CSt.thisMod END;
1441 scp := tId.dfScp;
1442
1443 IF typ.extrnNm # NIL THEN
1444 typ.scopeNm := unmangle(typ.extrnNm);
1445 (*
1446 * This is an external class, so it might be a nested class!
1447 *)
1448 os.CheckNestedClass(typ, scp, rNm);
1449 (*
1450 * Console.WriteString(typ.name());
1451 * Console.WriteLn;
1452 *
1453 * rNm := StrSubChr(rNm,'$','/');
1454 *)
1455 END;
1456
1457 (*
1458 * At this program point the situation is as follows:
1459 * rNm holds the simple name of the record. The scope
1460 * in which the record is defined is scp.
1461 *)
1462 WITH scp : Id.Procs DO
1463 IF scp.prcNm = NIL THEN MkProcName(scp, os) END;
1464 rNm := cat3(scp.prcNm, atSg, rNm);
1465 typ.xName := rNm;
1466 typ.scopeNm := cat2(scp.scopeNm, rNm);
1467 | scp : Id.BlkId DO
1468 IF scp.xName = NIL THEN MkBlkName(scp) END;
1469 typ.xName := rNm;
1470 typ.scopeNm := cat2(scp.scopeNm, rNm);
1471 END;
1472 (*
1473 * It is at this point that we link records into the
1474 * class-emission worklist.
1475 *)
1476 IF typ.tgXtn = NIL THEN os.MkRecX(typ, scp) END;
1477 IF tId.dfScp.kind # Id.impId THEN
1478 MsilBase.emitter.AddNewRecEmitter(typ);
1479 END;
1480 END MkRecName;
1481
1482 (* ------------------------------------------------------------ *)
1483
1484 PROCEDURE MkEnumName*(typ : Ty.Enum; os : MsilFile);
1485 VAR mNm : Lv.CharOpen; (* prefix scope name *)
1486 rNm : Lv.CharOpen; (* simple name of type *)
1487 tId : Sy.Idnt;
1488 scp : Sy.Scope;
1489 (* ---------------------------------------------------------- *)
1490 BEGIN
1491 (* Assert: Enums are always imported ... *)
1492 IF typ.xName # NIL THEN RETURN END;
1493
1494 tId := typ.idnt;
1495 rNm := Sy.getName.ChPtr(tId);
1496 scp := tId.dfScp;
1497 (*
1498 * At this program point the situation is at follows:
1499 * rNm holds the simple name of the type. The scope
1500 * in which the record is defined is scp.
1501 *)
1502 WITH scp : Id.BlkId DO
1503 IF scp.xName = NIL THEN MkBlkName(scp) END;
1504 typ.xName := cat2(scp.scopeNm, rNm);
1505 END;
1506 os.MkEnuX(typ, scp);
1507 END MkEnumName;
1508
1509 (* ------------------------------------------------------------ *)
1510
1511 PROCEDURE MkBasName(typ : Ty.Base; os : MsilFile);
1512 BEGIN
1513 ASSERT(typ.xName # NIL);
1514 os.MkBasX(typ);
1515 END MkBasName;
1516
1517 (* ------------------------------------------------------------ *)
1518
1519 PROCEDURE MkArrName(typ : Ty.Array; os : MsilFile);
1520 BEGIN
1521 typ.xName := cat2(typeName(typ.elemTp, os), brks);
1522 os.MkArrX(typ);
1523 END MkArrName;
1524
1525 (* ------------------------------------------------------------ *)
1526
1527 PROCEDURE MkVecName(typ : Ty.Vector; os : MsilFile);
1528 VAR ord : INTEGER;
1529 cls : Id.TypId;
1530 BEGIN
1531 ord := mapVecElTp(typ.elemTp);
1532 CASE ord OF
1533 | Ty.charN : typ.xName := cat2(vecPrefix, BOX("VecChr"));
1534 | Ty.intN : typ.xName := cat2(vecPrefix, BOX("VecI32"));
1535 | Ty.lIntN : typ.xName := cat2(vecPrefix, BOX("VecI64"));
1536 | Ty.sReaN : typ.xName := cat2(vecPrefix, BOX("VecR32"));
1537 | Ty.realN : typ.xName := cat2(vecPrefix, BOX("VecR64"));
1538 | Ty.anyPtr : typ.xName := cat2(vecPrefix, BOX("VecRef"));
1539 END;
1540 cls := vecClass(ord);
1541 IF cls.type.tgXtn = NIL THEN os.MkVecX(cls.type, vecMod()) END;
1542 typ.tgXtn := cls.type.tgXtn;
1543 END MkVecName;
1544
1545 (* ------------------------------------------------------------ *)
1546
1547 PROCEDURE MkPtrName*(typ : Ty.Pointer; os : MsilFile);
1548 VAR bndTp : Sy.Type;
1549 bndNm : Lv.CharOpen;
1550 BEGIN
1551 bndTp := typ.boundTp;
1552 bndNm := typeName(bndTp, os); (* recurse with MkTypeName *)
1553 IF isValRecord(bndTp) THEN
1554 typ.xName := boxedName(bndTp(Ty.Record), os);
1555 ELSE
1556 typ.xName := bndNm;
1557 END;
1558 os.MkPtrX(typ);
1559 END MkPtrName;
1560
1561 (* ------------------------------------------------------------ *)
1562
1563 PROCEDURE MkPTypeName*(typ : Ty.Procedure; os : MsilFile);
1564 VAR tNm : Lv.CharOpen;
1565 sNm : Lv.CharOpen;
1566 BEGIN
1567 IF typ.xName # NIL THEN RETURN END;
1568 (*
1569 * Set the eName field
1570 *)
1571 IF typ.idnt = NIL THEN (* Anonymous procedure type *)
1572 typ.idnt := Id.newAnonId(typ.serial);
1573 typ.idnt.type := typ;
1574 END;
1575 IF typ.idnt.dfScp = NIL THEN typ.idnt.dfScp := CSt.thisMod END;
1576
1577 MkIdName(typ.idnt.dfScp, os);
1578 os.NumberParams(NIL, typ);
1579
1580 sNm := typ.idnt.dfScp.scopeNm;
1581 tNm := Sy.getName.ChPtr(typ.idnt);
1582 typ.tName := cat2(sNm, tNm);
1583
1584 WITH typ : Ty.Event DO
1585 typ.bndRec.xName := tNm;
1586 typ.bndRec.scopeNm := typ.tName
1587 ELSE (* skip *)
1588 END;
1589 (*
1590 * os.MkTyXtn(...); // called from inside NumberParams().
1591 *
1592 * It is at this point that we link events into the
1593 * class-emission worklist.
1594 *)
1595 IF typ.idnt.dfScp.kind # Id.impId THEN
1596 MsilBase.emitter.AddNewRecEmitter(typ);
1597 END;
1598 END MkPTypeName;
1599
1600 (* ------------------------------------------------------------ *)
1601
1602 PROCEDURE MkProcName*(proc : Id.Procs; os : MsilFile);
1603 VAR pNm : Lv.CharOpen;
1604 res : Id.Procs;
1605 scp : Id.BlkId;
1606 bTp : Ty.Record;
1607 (* -------------------------------------------------- *)
1608 PROCEDURE MkMthNm(mth : Id.MthId; os : MsilFile);
1609 VAR res : Id.MthId;
1610 scp : Id.BlkId;
1611 typ : Sy.Type;
1612 BEGIN
1613 IF mth.scopeNm # NIL THEN RETURN;
1614 ELSIF mth.kind = Id.fwdMth THEN
1615 res := mth.resolve(Id.MthId); MkMthNm(res, os);
1616 mth.prcNm := res.prcNm; mth.scopeNm := res.scopeNm;
1617 ELSE
1618 scp := mth.dfScp(Id.BlkId);
1619 typ := mth.bndType;
1620 IF typ.xName = NIL THEN MkRecName(typ(Ty.Record), os) END;
1621 IF scp.xName = NIL THEN MkBlkName(scp) END;
1622 mth.scopeNm := scp.scopeNm;
1623 IF mth.prcNm = NIL THEN mth.prcNm := Sy.getName.ChPtr(mth) END;
1624 IF ~(Sy.clsTp IN typ(Ty.Record).xAttr) &
1625 (mth.rcvFrm.type IS Ty.Pointer) THEN INCL(mth.mthAtt, Id.boxRcv) END;
1626 END;
1627 END MkMthNm;
1628 (* -------------------------------------------------- *)
1629 PROCEDURE className(p : Id.Procs) : Lv.CharOpen;
1630 BEGIN
1631 WITH p : Id.PrcId DO RETURN p.clsNm;
1632 | p : Id.MthId DO RETURN p.bndType.xName;
1633 END;
1634 END className;
1635 (* -------------------------------------------------- *)
1636 PROCEDURE GetClassName(pr : Id.PrcId; bl : Id.BlkId; os : MsilFile);
1637 VAR nm : Lv.CharOpen;
1638 BEGIN
1639 nm := Sy.getName.ChPtr(pr);
1640 IF pr.bndType = NIL THEN (* normal procedure *)
1641 pr.clsNm := bl.clsNm;
1642 IF pr.prcNm = NIL THEN pr.prcNm := nm END;
1643 ELSE (* static method *)
1644 IF pr.bndType.xName = NIL THEN MkRecName(pr.bndType(Ty.Record), os) END;
1645 pr.clsNm := pr.bndType.xName;
1646 IF pr.prcNm = NIL THEN
1647 pr.prcNm := nm;
1648 ELSIF pr.prcNm^ = initString THEN
1649 pr.SetKind(Id.ctorP);
1650 END;
1651 END;
1652 END GetClassName;
1653 (* -------------------------------------------------- *)
1654 PROCEDURE MkPrcNm(prc : Id.PrcId; os : MsilFile);
1655 VAR scp : Sy.Scope;
1656 res : Id.PrcId;
1657 blk : Id.BlkId;
1658 rTp : Sy.Type;
1659 BEGIN
1660 IF prc.scopeNm # NIL THEN RETURN;
1661 ELSIF prc.kind = Id.fwdPrc THEN
1662 res := prc.resolve(Id.PrcId); MkPrcNm(res, os);
1663 prc.prcNm := res.prcNm;
1664 prc.clsNm := res.clsNm;
1665 prc.scopeNm := res.scopeNm;
1666 ELSIF prc.kind = Id.conPrc THEN
1667 scp := prc.dfScp;
1668 WITH scp : Id.BlkId DO
1669 IF scp.xName = NIL THEN MkBlkName(scp) END;
1670 IF Sy.isFn IN scp.xAttr THEN
1671 GetClassName(prc, scp, os);
1672 ELSE
1673 prc.clsNm := scp.clsNm;
1674 IF prc.prcNm = NIL THEN prc.prcNm := Sy.getName.ChPtr(prc) END;
1675 END;
1676 | scp : Id.Procs DO
1677 MkProcName(scp, os);
1678 prc.clsNm := className(scp);
1679 prc.prcNm := cat3(Sy.getName.ChPtr(prc), atSg, scp.prcNm);
1680 END;
1681 prc.scopeNm := scp.scopeNm;
1682 ELSE (* prc.kind = Id.ctorP *)
1683 blk := prc.dfScp(Id.BlkId);
1684 rTp := prc.type.returnType();
1685 IF blk.xName = NIL THEN MkBlkName(blk) END;
1686 IF rTp.xName = NIL THEN MkTypeName(rTp, os) END;
1687 prc.clsNm := rTp.boundRecTp().xName;
1688 prc.prcNm := Lv.strToCharOpen(initString);
1689 prc.scopeNm := blk.scopeNm;
1690
1691 prc.bndType := rTp.boundRecTp();
1692 prc.type(Ty.Procedure).retType := NIL;
1693
1694 END;
1695 END MkPrcNm;
1696 (* -------------------------------------------------- *)
1697 BEGIN
1698 WITH proc : Id.MthId DO MkMthNm(proc, os);
1699 | proc : Id.PrcId DO MkPrcNm(proc, os);
1700 END;
1701 (*
1702 * In this case proc.tgXtn is set in NumberParams
1703 *)
1704 END MkProcName;
1705
1706 (* ------------------------------------------------------------ *)
1707
1708 PROCEDURE MkAliasName*(typ : Ty.Opaque; os : MsilFile);
1709 VAR tNm : Lv.CharOpen;
1710 sNm : Lv.CharOpen;
1711 BEGIN
1712 IF typ.xName # NIL THEN RETURN END;
1713 MkBlkName(typ.idnt.dfScp(Id.BlkId));
1714 tNm := Sy.getName.ChPtr(typ.idnt);
1715 sNm := typ.idnt.dfScp.scopeNm;
1716 typ.xName := cat2(sNm, tNm);
1717 typ.scopeNm := sNm;
1718 END MkAliasName;
1719
1720 (* ------------------------------------------------------------ *)
1721
1722 PROCEDURE MkVarName*(var : Id.VarId; os : MsilFile);
1723 BEGIN
1724 var.varNm := Sy.getName.ChPtr(var);
1725 IF var.recTyp = NIL THEN (* normal case *)
1726 var.clsNm := var.dfScp(Id.BlkId).clsNm;
1727 ELSE (* static field *)
1728 IF var.recTyp.xName = NIL THEN MkTypeName(var.recTyp, os) END;
1729 var.clsNm := var.recTyp.xName;
1730 END;
1731 END MkVarName;
1732
1733 (* ------------------------------------------------------------ *)
1734
1735 PROCEDURE MkFldName*(id : Id.FldId; os : MsilFile);
1736 BEGIN
1737 id.fldNm := Sy.getName.ChPtr(id);
1738 END MkFldName;
1739
1740 (* ------------------------------------------------------------ *)
1741
1742 PROCEDURE MkIdName*(id : Sy.Idnt; os : MsilFile);
1743 BEGIN
1744 WITH id : Id.Procs DO IF id.scopeNm = NIL THEN MkProcName(id, os) END;
1745 | id : Id.BlkId DO IF id.scopeNm = NIL THEN MkBlkName(id) END;
1746 | id : Id.VarId DO IF id.varNm = NIL THEN MkVarName(id, os) END;
1747 | id : Id.FldId DO IF id.fldNm = NIL THEN MkFldName(id, os) END;
1748 | id : Id.LocId DO (* skip *)
1749 END;
1750 END MkIdName;
1751
1752 (* ------------------------------------------------------------ *)
1753
1754 PROCEDURE NumberLocals(pIdn : Id.Procs; IN locs : Sy.IdSeq);
1755 VAR ident : Sy.Idnt;
1756 index : INTEGER;
1757 count : INTEGER;
1758 BEGIN
1759 count := 0;
1760 (* ------------------ *)
1761 IF Id.hasXHR IN pIdn.pAttr THEN MkXHR(pIdn); INC(count) END;
1762 (* ------------------ *)
1763 FOR index := 0 TO locs.tide-1 DO
1764 ident := locs.a[index];
1765 WITH ident : Id.ParId DO (* skip *)
1766 | ident : Id.LocId DO
1767 IF Id.uplevA IN ident.locAtt THEN
1768 ident.varOrd := Id.xMark;
1769 ELSE
1770 ident.varOrd := count;
1771 INC(count);
1772 END;
1773 END;
1774 END;
1775 pIdn.rtsFram := count;
1776 END NumberLocals;
1777
1778 (* ------------------------------------------------------------ *)
1779
1780 PROCEDURE MkCallAttr*(pIdn : Sy.Idnt; os : MsilFile);
1781 VAR pTyp : Ty.Procedure;
1782 rcvP : Id.ParId;
1783 BEGIN
1784 (*
1785 * This is only called for imported methods.
1786 * All local methods have been already fixed
1787 * by the call from RenumberLocals()
1788 *)
1789 pTyp := pIdn.type(Ty.Procedure);
1790 WITH pIdn : Id.MthId DO
1791 pTyp.argN := 1; (* count one for "this" *)
1792 rcvP := pIdn.rcvFrm;
1793 MkProcName(pIdn, os);
1794 IF takeAdrs(rcvP) THEN rcvP.boxOrd := rcvP.parMod END;
1795 os.NumberParams(pIdn, pTyp);
1796 | pIdn : Id.PrcId DO
1797 pTyp.argN := 0;
1798 MkProcName(pIdn, os);
1799 os.NumberParams(pIdn, pTyp);
1800 END;
1801 END MkCallAttr;
1802
1803 (* ------------------------------------------------------------ *)
1804
1805 PROCEDURE RenumberLocals*(prcId : Id.Procs; os : MsilFile);
1806 VAR parId : Id.ParId;
1807 frmTp : Ty.Procedure;
1808 funcT : BOOLEAN;
1809 BEGIN
1810 (*
1811 * This is only called for local methods.
1812 * Imported methods do not have visible locals,
1813 * and get their signatures computed by the
1814 * call of NumberParams() in MkCallAttr()
1815 *
1816 * Numbering Rules:
1817 * (i) The receiver (if any) must be #0
1818 * (ii) Params are #0 .. #N for statics,
1819 * or #1 .. #N for methods.
1820 * (iii) Incoming static link is #0 if this is
1821 * a nested procedure (methods are not nested)
1822 * (iv) Locals separately number from zero.
1823 *)
1824 frmTp := prcId.type(Ty.Procedure);
1825 funcT := (frmTp.retType # NIL);
1826 WITH prcId : Id.MthId DO
1827 parId := prcId.rcvFrm;
1828 parId.varOrd := 0;
1829 IF takeAdrs(parId) THEN parId.boxOrd := parId.parMod END;
1830 frmTp.argN := 1; (* count one for "this" *)
1831 ELSE (* static procedures *)
1832 IF (prcId.kind = Id.ctorP) OR
1833 (prcId.lxDepth > 0) THEN frmTp.argN := 1 ELSE frmTp.argN := 0 END;
1834 END;
1835 (*
1836 * Assert: params do not appear in the local array.
1837 * Count params.
1838 *)
1839 os.NumberParams(prcId, frmTp); (* Make signature method defined here *)
1840 (*
1841 * If NumberLocals is NOT called on a procedure that
1842 * has locals but no body, then PeUtil pulls an index
1843 * exception. Such a program may be silly, but is legal. (kjg)
1844 *
1845 * IF prcId.body # NIL THEN
1846 * NumberLocals(prcId, prcId.locals);
1847 * END;
1848 *)
1849 NumberLocals(prcId, prcId.locals);
1850 END RenumberLocals;
1851
1852 (* ------------------------------------------------------------ *)
1853 (* ------------------------------------------------------------ *)
1854
1855 PROCEDURE (os : MsilFile)LoadIndirect*(typ : Sy.Type),NEW;
1856 VAR code : INTEGER;
1857 BEGIN
1858 IF (typ # NIL) & (typ IS Ty.Base) THEN
1859 os.Code(typeLdInd[typ(Ty.Base).tpOrd]);
1860 ELSIF isValRecord(typ) THEN
1861 os.CodeT(Asm.opc_ldobj, typ);
1862 ELSE
1863 os.Code(Asm.opc_ldind_ref);
1864 END;
1865 END LoadIndirect;
1866
1867 (* ------------------------------------------------------------ *)
1868
1869 PROCEDURE (os : MsilFile)StoreIndirect*(typ : Sy.Type),NEW;
1870 VAR code : INTEGER;
1871 BEGIN
1872 IF (typ # NIL) & (typ IS Ty.Base) THEN
1873 os.Code(typeStInd[typ(Ty.Base).tpOrd]);
1874 ELSIF isValRecord(typ) THEN
1875 os.CodeT(Asm.opc_stobj, typ);
1876 ELSE
1877 os.Code(Asm.opc_stind_ref);
1878 END;
1879 END StoreIndirect;
1880
1881 (* ------------------------------------------------------------ *)
1882 (* ------------------------------------------------------------ *)
1883
1884 PROCEDURE (os : MsilFile)PushArg*(ord : INTEGER),NEW;
1885 BEGIN
1886 IF ord < 256 THEN
1887 CASE ord OF
1888 | 0 : os.Code(Asm.opc_ldarg_0);
1889 | 1 : os.Code(Asm.opc_ldarg_1);
1890 | 2 : os.Code(Asm.opc_ldarg_2);
1891 | 3 : os.Code(Asm.opc_ldarg_3);
1892 ELSE
1893 os.CodeI(Asm.opc_ldarg_s, ord);
1894 END;
1895 ELSE
1896 os.CodeI(Asm.opc_ldarg, ord);
1897 END;
1898 END PushArg;
1899
1900 (* ------------------------------------------------------------ *)
1901
1902 PROCEDURE (os : MsilFile)PushStaticLink*(tgt : Id.Procs),NEW;
1903 VAR lxDel : INTEGER;
1904 clr : Id.Procs;
1905 BEGIN
1906 clr := os.proc.prId(Id.Procs);
1907 lxDel := tgt.lxDepth - clr.lxDepth;
1908
1909 CASE lxDel OF
1910 | 0 : os.Code(Asm.opc_ldarg_0);
1911 | 1 : IF Id.hasXHR IN clr.pAttr THEN
1912 os.Code(Asm.opc_ldloc_0);
1913 ELSIF clr.lxDepth = 0 THEN
1914 os.Code(Asm.opc_ldnull);
1915 ELSE
1916 os.Code(Asm.opc_ldarg_0);
1917 END;
1918 ELSE
1919 os.Code(Asm.opc_ldarg_0);
1920 REPEAT
1921 clr := clr.dfScp(Id.Procs);
1922 IF Id.hasXHR IN clr.pAttr THEN
1923 os.PutGetF(Asm.opc_ldfld, CSt.xhrId);
1924 END;
1925 UNTIL clr.lxDepth = tgt.lxDepth;
1926 END;
1927 END PushStaticLink;
1928
1929 (* ---------------------------------------------------- *)
1930
1931 PROCEDURE (os : MsilFile)GetXHR(var : Id.LocId),NEW;
1932 VAR scp : Id.Procs; (* the scope holding the datum *)
1933 clr : Id.Procs; (* the scope making the call *)
1934 del : INTEGER;
1935 BEGIN
1936 scp := var.dfScp(Id.Procs);
1937 clr := os.proc.prId(Id.Procs);
1938 (*
1939 * Check if this is an own local
1940 *)
1941 IF scp = clr THEN
1942 os.Code(Asm.opc_ldloc_0);
1943 ELSE
1944 del := xhrCount(scp, clr);
1945 (*
1946 * First, load the static link
1947 *)
1948 os.Code(Asm.opc_ldarg_0);
1949 (*
1950 * Next, load the XHR pointer.
1951 *)
1952 WHILE del > 1 DO
1953 os.PutGetF(Asm.opc_ldfld, CSt.xhrId);
1954 DEC(del);
1955 END;
1956 (*
1957 * Finally, cast to concrete type
1958 *)
1959 os.CodeT(Asm.opc_castclass, scp.xhrType);
1960 END;
1961 END GetXHR;
1962
1963 (* ------------------------------------------------------------ *)
1964
1965 PROCEDURE (os : MsilFile)PushLocal*(ord : INTEGER),NEW;
1966 BEGIN
1967 IF ord < 256 THEN
1968 CASE ord OF
1969 | 0 : os.Code(Asm.opc_ldloc_0);
1970 | 1 : os.Code(Asm.opc_ldloc_1);
1971 | 2 : os.Code(Asm.opc_ldloc_2);
1972 | 3 : os.Code(Asm.opc_ldloc_3);
1973 ELSE
1974 os.CodeI(Asm.opc_ldloc_s, ord);
1975 END;
1976 ELSE
1977 os.CodeI(Asm.opc_ldloc, ord);
1978 END;
1979 END PushLocal;
1980
1981 (* ---------------------------------------------------- *)
1982
1983 PROCEDURE (os : MsilFile)PushLocalA*(ord : INTEGER),NEW;
1984 BEGIN
1985 IF ord < 256 THEN
1986 os.CodeI(Asm.opc_ldloca_s, ord);
1987 ELSE
1988 os.CodeI(Asm.opc_ldloca, ord);
1989 END;
1990 END PushLocalA;
1991
1992 (* ---------------------------------------------------- *)
1993
1994 PROCEDURE (os : MsilFile)PushArgA*(ord : INTEGER),NEW;
1995 BEGIN
1996 IF ord < 256 THEN
1997 os.CodeI(Asm.opc_ldarga_s, ord);
1998 ELSE
1999 os.CodeI(Asm.opc_ldarga, ord);
2000 END;
2001 END PushArgA;
2002
2003 (* ---------------------------------------------------- *)
2004
2005 PROCEDURE (os : MsilFile)GetXhrField(cde : INTEGER; var : Id.LocId),NEW;
2006 VAR proc : Id.Procs;
2007 BEGIN
2008 proc := var.dfScp(Id.Procs);
2009 os.PutGetXhr(cde, proc, var);
2010 END GetXhrField;
2011
2012 (* ---------------------------------------------------- *)
2013
2014 PROCEDURE (os : MsilFile)XhrHandle*(var : Id.LocId),NEW;
2015 BEGIN
2016 os.GetXHR(var);
2017 IF var.boxOrd # Sy.val THEN os.GetXhrField(Asm.opc_ldfld, var) END;
2018 END XhrHandle;
2019
2020 (* ---------------------------------------------------- *)
2021
2022 PROCEDURE (os : MsilFile)GetUplevel(var : Id.LocId),NEW;
2023 BEGIN
2024 os.GetXHR(var);
2025 (*
2026 * If var is a LocId do "ldfld FT XT::'vname'"
2027 * If var is a ParId then
2028 * if not a byref then "ldfld FT XT::'vname'"
2029 * elsif is a byref then "ldfld FT& XT::'vname'; ldind.TT"
2030 *)
2031 os.GetXhrField(Asm.opc_ldfld, var);
2032 IF var.boxOrd # Sy.val THEN os.LoadIndirect(var.type) END;
2033 END GetUplevel;
2034
2035 (* ---------------------------------------------------- *)
2036
2037 PROCEDURE (os : MsilFile)GetUplevelA(var : Id.LocId),NEW;
2038 BEGIN
2039 os.GetXHR(var);
2040 (*
2041 * If var is a LocId do "ldflda FT XT::'vname'"
2042 * If var is a ParId then
2043 * if not a byref then "ldflda FT XT::'vname'"
2044 * elsif is a byref then "ldfld FT& XT::'vname'"
2045 *)
2046 IF var.boxOrd # Sy.val THEN (* byref case ... *)
2047 os.GetXhrField(Asm.opc_ldfld, var);
2048 ELSE (* value case ... *)
2049 os.GetXhrField(Asm.opc_ldflda, var);
2050 END;
2051 END GetUplevelA;
2052
2053 (* ---------------------------------------------------- *)
2054
2055 PROCEDURE (os : MsilFile)PutUplevel*(var : Id.LocId),NEW;
2056 BEGIN
2057 (*
2058 * If var is a LocId do "stfld FT XT::'vname'"
2059 * If var is a ParId then
2060 * if not a byref then "stfld FT XT::'vname'"
2061 * elsif is a byref then "ldfld FT& XT::'vname'; stind.TT"
2062 *)
2063 IF var.boxOrd # Sy.val THEN (* byref case ... *)
2064 os.StoreIndirect(var.type);
2065 ELSE (* value case ... *)
2066 os.GetXhrField(Asm.opc_stfld, var);
2067 END;
2068 END PutUplevel;
2069
2070 (* ---------------------------------------------------- *)
2071
2072 PROCEDURE (os : MsilFile)GetLocal*(var : Id.LocId),NEW;
2073 BEGIN
2074 IF Id.uplevA IN var.locAtt THEN os.GetUplevel(var); RETURN END;
2075 WITH var : Id.ParId DO
2076 os.PushArg(var.varOrd);
2077 IF var.boxOrd # Sy.val THEN os.LoadIndirect(var.type) END;
2078 ELSE
2079 os.PushLocal(var.varOrd);
2080 END;
2081 END GetLocal;
2082
2083 (* ---------------------------------------------------- *)
2084
2085 PROCEDURE (os : MsilFile)DecTemp*(ord : INTEGER),NEW;
2086 BEGIN
2087 os.PushLocal(ord);
2088 os.Code(Asm.opc_ldc_i4_1);
2089 os.Code(Asm.opc_sub);
2090 os.StoreLocal(ord);
2091 END DecTemp;
2092
2093 (* ---------------------------------------------------- *)
2094
2095 PROCEDURE (os : MsilFile)GetVar*(id : Sy.Idnt),NEW;
2096 VAR scp : Sy.Scope;
2097 BEGIN
2098 WITH id : Id.AbVar DO
2099 IF id.kind = Id.conId THEN
2100 os.GetLocal(id(Id.LocId));
2101 ELSE
2102 scp := id.dfScp;
2103 WITH scp : Id.BlkId DO
2104 os.PutGetS(Asm.opc_ldsfld, scp, id(Id.VarId));
2105 ELSE
2106 os.GetLocal(id(Id.LocId));
2107 END;
2108 END;
2109 END;
2110 END GetVar;
2111
2112 (* ------------------------------------------------------------ *)
2113 (* ------------------------------------------------------------ *)
2114
2115 PROCEDURE (os : MsilFile)GetLocalA(var : Id.LocId),NEW;
2116 VAR ord : INTEGER;
2117 BEGIN
2118 ord := var.varOrd;
2119 IF Id.uplevA IN var.locAtt THEN os.GetUplevelA(var); RETURN END;
2120 IF ~(var IS Id.ParId) THEN (* local var *)
2121 os.PushLocalA(ord);
2122 ELSIF var.boxOrd # Sy.val THEN (* ref param *)
2123 os.PushArg(ord);
2124 ELSE (* val param *)
2125 os.PushArgA(ord);
2126 END;
2127 END GetLocalA;
2128
2129 (* ---------------------------------------------------- *)
2130
2131 PROCEDURE (os : MsilFile)GetVarA*(id : Sy.Idnt),NEW;
2132 VAR var : Id.AbVar;
2133 scp : Sy.Scope;
2134 BEGIN
2135 (*
2136 * Assert: the handle is NOT pushed on the tos yet.
2137 *)
2138 var := id(Id.AbVar);
2139 scp := var.dfScp;
2140 WITH scp : Id.BlkId DO
2141 os.PutGetS(Asm.opc_ldsflda, scp, var(Id.VarId));
2142 ELSE
2143 os.GetLocalA(var(Id.LocId));
2144 END;
2145 END GetVarA;
2146
2147 (* ------------------------------------------------------------ *)
2148 (* ------------------------------------------------------------ *)
2149
2150 PROCEDURE (os : MsilFile)StoreArg*(ord : INTEGER),NEW;
2151 BEGIN
2152 IF ord < 256 THEN
2153 os.CodeI(Asm.opc_starg_s, ord);
2154 ELSE
2155 os.CodeI(Asm.opc_starg, ord);
2156 END;
2157 END StoreArg;
2158
2159 (* ---------------------------------------------------- *)
2160
2161 PROCEDURE (os : MsilFile)StoreLocal*(ord : INTEGER),NEW;
2162 BEGIN
2163 IF ord < 256 THEN
2164 CASE ord OF
2165 | 0 : os.Code(Asm.opc_stloc_0);
2166 | 1 : os.Code(Asm.opc_stloc_1);
2167 | 2 : os.Code(Asm.opc_stloc_2);
2168 | 3 : os.Code(Asm.opc_stloc_3);
2169 ELSE
2170 os.CodeI(Asm.opc_stloc_s, ord);
2171 END;
2172 ELSE
2173 os.CodeI(Asm.opc_stloc, ord);
2174 END;
2175 END StoreLocal;
2176
2177 (* ---------------------------------------------------- *)
2178
2179 PROCEDURE (os : MsilFile)PutLocal*(var : Id.LocId),NEW;
2180 BEGIN
2181 IF Id.uplevA IN var.locAtt THEN os.PutUplevel(var); RETURN END;
2182 WITH var : Id.ParId DO
2183 IF var.boxOrd = Sy.val THEN
2184 os.StoreArg(var.varOrd);
2185 ELSE
2186 (*
2187 * stack goes (top) value, reference, ... so
2188 * os.PushArg(var.varOrd);
2189 *)
2190 os.StoreIndirect(var.type);
2191 END;
2192 ELSE
2193 os.StoreLocal(var.varOrd);
2194 END;
2195 END PutLocal;
2196
2197 (* ---------------------------------------------------- *)
2198
2199 PROCEDURE (os : MsilFile)PutVar*(id : Sy.Idnt),NEW;
2200 VAR var : Id.AbVar;
2201 scp : Sy.Scope;
2202 BEGIN
2203 var := id(Id.AbVar);
2204 scp := var.dfScp;
2205 WITH scp : Id.BlkId DO
2206 os.PutGetS(Asm.opc_stsfld, scp, var(Id.VarId));
2207 ELSE (* must be local *)
2208 os.PutLocal(var(Id.LocId));
2209 END;
2210 END PutVar;
2211
2212 (* ------------------------------------------------------------ *)
2213
2214 PROCEDURE (os : MsilFile)PutElem*(typ : Sy.Type),NEW;
2215 (* typ is element type *)
2216 BEGIN
2217 IF (typ # NIL) & (typ IS Ty.Base) THEN
2218 os.Code(typePutE[typ(Ty.Base).tpOrd]);
2219 ELSIF isValRecord(typ) THEN
2220 os.CodeT(Asm.opc_stobj, typ);
2221 ELSIF typ IS Ty.Enum THEN
2222 os.Code(typePutE[Ty.intN]); (* assume enum <==> int32 *)
2223 ELSE
2224 os.Code(Asm.opc_stelem_ref);
2225 END;
2226 END PutElem;
2227
2228 (* ------------------------------------------------------------ *)
2229
2230 PROCEDURE (os : MsilFile)GetElem*(typ : Sy.Type),NEW;
2231 BEGIN
2232 IF (typ # NIL) & (typ IS Ty.Base) THEN
2233 os.Code(typeGetE[typ(Ty.Base).tpOrd]);
2234 ELSIF isValRecord(typ) THEN
2235 os.CodeT(Asm.opc_ldobj, typ);
2236 ELSIF typ IS Ty.Enum THEN
2237 os.Code(typeGetE[Ty.intN]); (* assume enum <==> int32 *)
2238 ELSE
2239 os.Code(Asm.opc_ldelem_ref);
2240 END;
2241 END GetElem;
2242
2243 (* ------------------------------------------------------------ *)
2244
2245 PROCEDURE (os : MsilFile)GetField*(fld : Id.FldId),NEW;
2246 BEGIN
2247 os.PutGetF(Asm.opc_ldfld, fld);
2248 END GetField;
2249
2250 (* ------------------------------------------------------------ *)
2251
2252 PROCEDURE (os : MsilFile)GetFieldAdr*(fld : Id.FldId),NEW;
2253 BEGIN
2254 os.PutGetF(Asm.opc_ldflda, fld);
2255 END GetFieldAdr;
2256
2257 (* ------------------------------------------------------------ *)
2258
2259 PROCEDURE (os : MsilFile)PutField*(fld : Id.FldId),NEW;
2260 BEGIN
2261 os.PutGetF(Asm.opc_stfld, fld);
2262 END PutField;
2263
2264 (* ------------------------------------------------------------ *)
2265
2266 PROCEDURE (os : MsilFile)GetElemA*(typ : Sy.Type),NEW;
2267 BEGIN
2268 os.CodeTn(Asm.opc_ldelema, typ);
2269 END GetElemA;
2270
2271 (* ------------------------------------------------------------ *)
2272
2273 PROCEDURE (os : MsilFile)GetVal*(typ : Ty.Pointer),NEW;
2274 BEGIN
2275 os.GetValObj(Asm.opc_ldfld, typ);
2276 END GetVal;
2277
2278 (* ------------------------------------------------------------ *)
2279
2280 PROCEDURE (os : MsilFile)GetValA*(typ : Ty.Pointer),NEW;
2281 BEGIN
2282 os.GetValObj(Asm.opc_ldflda, typ);
2283 END GetValA;
2284
2285 (* ------------------------------------------------------------ *)
2286
2287 PROCEDURE (os : MsilFile)PushInt*(num : INTEGER),NEW;
2288 BEGIN
2289 IF (-128 <= num) & (num <= 127) THEN
2290 CASE num OF
2291 | -1 : os.Code(Asm.opc_ldc_i4_M1);
2292 | 0 : os.Code(Asm.opc_ldc_i4_0);
2293 | 1 : os.Code(Asm.opc_ldc_i4_1);
2294 | 2 : os.Code(Asm.opc_ldc_i4_2);
2295 | 3 : os.Code(Asm.opc_ldc_i4_3);
2296 | 4 : os.Code(Asm.opc_ldc_i4_4);
2297 | 5 : os.Code(Asm.opc_ldc_i4_5);
2298 | 6 : os.Code(Asm.opc_ldc_i4_6);
2299 | 7 : os.Code(Asm.opc_ldc_i4_7);
2300 | 8 : os.Code(Asm.opc_ldc_i4_8);
2301 ELSE
2302 os.CodeI(Asm.opc_ldc_i4_s, num);
2303 END;
2304 ELSE
2305 os.CodeI(Asm.opc_ldc_i4, num);
2306 END;
2307 END PushInt;
2308
2309 (* ------------------------------------------------------------ *)
2310
2311 PROCEDURE (os : MsilFile)PushLong*(num : LONGINT),NEW;
2312 BEGIN
2313 (*
2314 * IF num is short we could do PushInt, then i2l!
2315 *)
2316 os.CodeL(Asm.opc_ldc_i8, num);
2317 END PushLong;
2318
2319 (* ------------------------------------------------------------ *)
2320
2321 PROCEDURE (os : MsilFile)PushReal*(num : REAL),NEW;
2322 BEGIN
2323 os.CodeR(Asm.opc_ldc_r8, num);
2324 END PushReal;
2325
2326 (* ------------------------------------------------------------ *)
2327
2328 PROCEDURE (os : MsilFile)PushSReal*(num : REAL),NEW;
2329 BEGIN
2330 os.CodeR(Asm.opc_ldc_r4, num);
2331 END PushSReal;
2332
2333 (* ------------------------------------------------------------ *)
2334
2335 PROCEDURE (os : MsilFile)PushJunkAndQuit*(prc : Sy.Scope),NEW;
2336 VAR pTyp : Ty.Procedure;
2337 BEGIN
2338 IF (prc # NIL) & (prc.type # NIL) THEN
2339 pTyp := prc.type(Ty.Procedure);
2340 IF pTyp.retType # NIL THEN os.PushZero(pTyp.retType) END;
2341 END;
2342 os.DoReturn();
2343 END PushJunkAndQuit;
2344
2345 (* ------------------------------------------------------------ *)
2346
2347 PROCEDURE (os : MsilFile)ConvertUp*(inT, outT : Sy.Type),NEW;
2348 (* Conversion "up" is always safe at runtime. Many are nop. *)
2349 VAR inB, outB, code : INTEGER;
2350 BEGIN
2351 inB := inT(Ty.Base).tpOrd;
2352 outB := outT(Ty.Base).tpOrd;
2353 IF inB = outB THEN RETURN END; (* PREMATURE RETURN! *)
2354 CASE outB OF
2355 | Ty.realN : code := Asm.opc_conv_r8;
2356 | Ty.sReaN : code := Asm.opc_conv_r4;
2357 | Ty.lIntN : code := Asm.opc_conv_i8;
2358 ELSE RETURN; (* PREMATURE RETURN! *)
2359 END;
2360 os.Code(code);
2361 END ConvertUp;
2362
2363 (* ------------------------------------------------------------ *)
2364
2365 PROCEDURE (os : MsilFile)ConvertDn*(inT, outT : Sy.Type; check : BOOLEAN),NEW;
2366 (* Conversion "down" often needs a runtime check. *)
2367 VAR inB, outB, code : INTEGER;
2368 BEGIN
2369 inB := inT(Ty.Base).tpOrd;
2370 outB := outT(Ty.Base).tpOrd;
2371 IF inB = Ty.setN THEN inB := Ty.intN END;
2372 IF inB = outB THEN RETURN END; (* PREMATURE RETURN! *)
2373 (* IF os.proc.prId.ovfChk THEN *)
2374 IF check THEN
2375 CASE outB OF
2376 | Ty.realN : RETURN; (* PREMATURE RETURN! *)
2377 | Ty.sReaN : code := Asm.opc_conv_r4; (* No check possible *)
2378 | Ty.lIntN : code := Asm.opc_conv_ovf_i8;
2379 | Ty.intN : code := Asm.opc_conv_ovf_i4;
2380 | Ty.sIntN : code := Asm.opc_conv_ovf_i2;
2381 | Ty.uBytN : code := Asm.opc_conv_ovf_u1;
2382 | Ty.byteN : code := Asm.opc_conv_ovf_i1;
2383 | Ty.setN : code := Asm.opc_conv_u4; (* no check here! *)
2384 | Ty.charN : code := Asm.opc_conv_ovf_u2;
2385 | Ty.sChrN : code := Asm.opc_conv_ovf_u1;
2386 END;
2387 ELSE
2388 CASE outB OF
2389 | Ty.realN : RETURN; (* PREMATURE RETURN! *)
2390 | Ty.sReaN : code := Asm.opc_conv_r4; (* No check possible *)
2391 | Ty.lIntN : code := Asm.opc_conv_i8;
2392 | Ty.intN : code := Asm.opc_conv_i4;
2393 | Ty.sIntN : code := Asm.opc_conv_i2;
2394 | Ty.byteN : code := Asm.opc_conv_i1;
2395 | Ty.uBytN : code := Asm.opc_conv_u1;
2396 | Ty.setN : code := Asm.opc_conv_u4; (* no check here! *)
2397 | Ty.charN : code := Asm.opc_conv_u2;
2398 | Ty.sChrN : code := Asm.opc_conv_u1;
2399 END;
2400 END;
2401 os.Code(code);
2402 END ConvertDn;
2403
2404 (* ------------------------------------------------------------ *)
2405
2406 PROCEDURE (os : MsilFile)EmitOneRange*
2407 (var : INTEGER; (* local variable index *)
2408 loC : INTEGER; (* low-value of range *)
2409 hiC : INTEGER; (* high-value of range *)
2410 ord : INTEGER; (* case-index of range *)
2411 min : INTEGER; (* minimun selector val *)
2412 max : INTEGER; (* maximum selector val *)
2413 def : LbArr),NEW; (* default code label *)
2414 (* ---------------------------------------------------------- *
2415 * The selector value is known to be in the range min .. max *
2416 * and we wish to send values between loC and hiC to the *
2417 * code label associated with ord. All otherwise go to def. *
2418 * A range is "compact" if it is hard against min/max limits *
2419 * ---------------------------------------------------------- *)
2420 VAR target : INTEGER;
2421 BEGIN
2422 (*
2423 * Deal with several special cases...
2424 *)
2425 target := ord + 1;
2426 IF (min = loC) & (max = hiC) THEN (* fully compact: just GOTO *)
2427 os.CodeLb(Asm.opc_br, def[target]);
2428 ELSE
2429 os.PushLocal(var);
2430 IF loC = hiC THEN (* a singleton *)
2431 os.PushInt(loC);
2432 os.CodeLb(Asm.opc_beq, def[target]);
2433 ELSIF min = loC THEN (* compact at low end only *)
2434 os.PushInt(hiC);
2435 os.CodeLb(Asm.opc_ble, def[target]);
2436 ELSIF max = hiC THEN (* compact at high end only *)
2437 os.PushInt(loC);
2438 os.CodeLb(Asm.opc_bge, def[target]);
2439 ELSE (* Shucks! The general case *)
2440 IF loC # 0 THEN
2441 os.PushInt(loC);
2442 os.Code(Asm.opc_sub);
2443 END;
2444 os.PushInt(hiC-loC);
2445 os.CodeLb(Asm.opc_ble_un, def[target]);
2446 END;
2447 os.CodeLb(Asm.opc_br, def[0]);
2448 END;
2449 END EmitOneRange;
2450
2451 (* ------------------------------------------------------------ *)
2452 (* ------------------------------------------------------------ *)
2453
2454 PROCEDURE (os : MsilFile)InitVars*(scp : Sy.Scope),NEW;
2455 VAR index : INTEGER;
2456 ident : Sy.Idnt;
2457 BEGIN
2458 (*
2459 * Create the explicit activation record, if needed.
2460 *)
2461 WITH scp : Id.Procs DO
2462 IF Id.hasXHR IN scp.pAttr THEN
2463 os.Comment("create XHR record");
2464 os.MkNewRecord(scp.xhrType.boundRecTp()(Ty.Record));
2465 IF scp.lxDepth > 0 THEN
2466 os.Code(Asm.opc_dup);
2467 os.Code(Asm.opc_ldarg_0);
2468 os.PutGetF(Asm.opc_stfld, CSt.xhrId);
2469 END;
2470 os.Code(Asm.opc_stloc_0);
2471 END;
2472 ELSE (* skip *)
2473 END;
2474 (*
2475 * Initialize local fields, if needed
2476 *)
2477 FOR index := 0 TO scp.locals.tide-1 DO
2478 ident := scp.locals.a[index];
2479 WITH ident : Id.ParId DO
2480 IF Id.uplevA IN ident.locAtt THEN (* copy to XHR *)
2481 os.GetXHR(ident);
2482 os.PushArg(ident.varOrd);
2483 IF Id.cpVarP IN ident.locAtt THEN os.LoadIndirect(ident.type) END;
2484 os.GetXhrField(Asm.opc_stfld, ident);
2485 END; (* else skip *)
2486 ELSE
2487 IF ~ident.type.isScalarType() THEN
2488 os.StructInit(ident);
2489 ELSE
2490 WITH ident : Id.LocId DO
2491 (*
2492 * Special code to step around deficiency in the the
2493 * verifier. Verifier does not understand OUT semantics.
2494 *
2495 * IF Id.addrsd IN ident.locAtt THEN
2496 *)
2497 IF (Id.addrsd IN ident.locAtt) & ~(Id.uplevA IN ident.locAtt) THEN
2498 ASSERT(~(scp IS Id.BlkId));
2499 os.ScalarInit(ident);
2500 os.StoreLocal(ident.varOrd);
2501 END;
2502 ELSE
2503 END;
2504 END;
2505 END;
2506 END;
2507 END InitVars;
2508
2509 (* ============================================================ *)
2510
2511 PROCEDURE (os : MsilFile)FixCopies(prId : Sy.Idnt),NEW;
2512 VAR index : INTEGER;
2513 pType : Ty.Procedure;
2514 formP : Id.ParId;
2515 BEGIN
2516 IF prId # NIL THEN
2517 WITH prId : Id.Procs DO
2518 pType := prId.type(Ty.Procedure);
2519 FOR index := 0 TO pType.formals.tide - 1 DO
2520 formP := pType.formals.a[index];
2521 IF Id.cpVarP IN formP.locAtt THEN
2522 os.PushArg(formP.varOrd);
2523 os.GetXHR(formP);
2524 os.GetXhrField(Asm.opc_ldfld, formP);
2525 os.StoreIndirect(formP.type);
2526 END;
2527 END;
2528 ELSE (* skip *)
2529 END; (* with *)
2530 END;
2531 END FixCopies;
2532
2533 (* ============================================================ *)
2534
2535 PROCEDURE InitVectorDescriptors();
2536 VAR idx : INTEGER;
2537 BEGIN
2538 vecBlkId := NIL;
2539 vecBase := NIL;
2540 vecTide := NIL;
2541 FOR idx := 0 TO Ty.anyPtr DO
2542 vecElms[idx] := NIL;
2543 vecTypes[idx] := NIL;
2544 vecExpnd[idx] := NIL;
2545 END;
2546 END InitVectorDescriptors;
2547
2548 (* ============================================================ *)
2549
2550 PROCEDURE SetNativeNames*();
2551 VAR sRec, oRec : Ty.Record;
2552 BEGIN
2553 xhrIx := 0;
2554 oRec := CSt.ntvObj.boundRecTp()(Ty.Record);
2555 sRec := CSt.ntvStr.boundRecTp()(Ty.Record);
2556
2557 InitVectorDescriptors();
2558 (*
2559 * From release 1.2, only the RTM version is supported
2560 *)
2561 INCL(oRec.xAttr, Sy.spshl);
2562 INCL(sRec.xAttr, Sy.spshl);
2563 oRec.xName := Lv.strToCharOpen("object");
2564 sRec.xName := Lv.strToCharOpen("string");
2565 oRec.scopeNm := oRec.xName;
2566 sRec.scopeNm := sRec.xName;
2567 pVarSuffix := Lv.strToCharOpen(".ctor($O, native int) ");
2568
2569 CSt.ntvObj.xName := oRec.scopeNm;
2570 CSt.ntvStr.xName := sRec.scopeNm;
2571
2572 END SetNativeNames;
2573
2574 (* ============================================================ *)
2575 (* ============================================================ *)
2576 BEGIN
2577 Lv.InitCharOpenSeq(nmArray, 8);
2578
2579 rtsS := Lv.strToCharOpen("RTS");
2580 brks := Lv.strToCharOpen("[]");
2581 dotS := Lv.strToCharOpen(".");
2582 cmma := Lv.strToCharOpen(",");
2583 lPar := Lv.strToCharOpen("(");
2584 rPar := Lv.strToCharOpen(")");
2585 lBrk := Lv.strToCharOpen("[");
2586 rBrk := Lv.strToCharOpen("]");
2587 atSg := Lv.strToCharOpen("@");
2588 rfMk := Lv.strToCharOpen("&");
2589 vFld := Lv.strToCharOpen("v$");
2590 ouMk := Lv.strToCharOpen("[out] ");
2591 prev := Lv.strToCharOpen("prev");
2592 body := Lv.strToCharOpen("$static");
2593 xhrDl := Lv.strToCharOpen("XHR@");
2594 xhrMk := Lv.strToCharOpen("class [RTS]XHR");
2595 boxedObj := Lv.strToCharOpen("Boxed_");
2596 corlibAsm := Lv.strToCharOpen("[mscorlib]System.");
2597
2598 vecPrefix := Lv.strToCharOpen("[RTS]Vectors.");
2599 evtAdd := Lv.strToCharOpen("add_");
2600 evtRem := Lv.strToCharOpen("remove_");
2601
2602 Bi.setTp.xName := Lv.strToCharOpen("int32");
2603 Bi.boolTp.xName := Lv.strToCharOpen("bool");
2604 Bi.byteTp.xName := Lv.strToCharOpen("int8");
2605 Bi.uBytTp.xName := Lv.strToCharOpen("unsigned int8");
2606 Bi.charTp.xName := Lv.strToCharOpen("wchar");
2607 Bi.sChrTp.xName := Lv.strToCharOpen("char");
2608 Bi.sIntTp.xName := Lv.strToCharOpen("int16");
2609 Bi.lIntTp.xName := Lv.strToCharOpen("int64");
2610 Bi.realTp.xName := Lv.strToCharOpen("float64");
2611 Bi.sReaTp.xName := Lv.strToCharOpen("float32");
2612 Bi.intTp.xName := Bi.setTp.xName;
2613 Bi.anyRec.xName := Lv.strToCharOpen("class System.Object");
2614 Bi.anyPtr.xName := Bi.anyRec.xName;
2615
2616 typeGetE[ Ty.boolN] := Asm.opc_ldelem_i1;
2617 (*
2618 * typeGetE[ Ty.sChrN] := Asm.opc_ldelem_u1;
2619 *)
2620 typeGetE[ Ty.sChrN] := Asm.opc_ldelem_u2;
2621 typeGetE[ Ty.charN] := Asm.opc_ldelem_u2;
2622 typeGetE[ Ty.byteN] := Asm.opc_ldelem_i1;
2623 typeGetE[ Ty.uBytN] := Asm.opc_ldelem_u1;
2624 typeGetE[ Ty.sIntN] := Asm.opc_ldelem_i2;
2625 typeGetE[ Ty.intN] := Asm.opc_ldelem_i4;
2626 typeGetE[ Ty.lIntN] := Asm.opc_ldelem_i8;
2627 typeGetE[ Ty.sReaN] := Asm.opc_ldelem_r4;
2628 typeGetE[ Ty.realN] := Asm.opc_ldelem_r8;
2629 typeGetE[ Ty.setN] := Asm.opc_ldelem_i4;
2630 typeGetE[Ty.anyPtr] := Asm.opc_ldelem_ref;
2631 typeGetE[Ty.anyRec] := Asm.opc_ldelem_ref;
2632
2633 typePutE[ Ty.boolN] := Asm.opc_stelem_i1;
2634 (*
2635 * typePutE[ Ty.sChrN] := Asm.opc_stelem_i1;
2636 *)
2637 typePutE[ Ty.sChrN] := Asm.opc_stelem_i2;
2638 typePutE[ Ty.charN] := Asm.opc_stelem_i2;
2639 typePutE[ Ty.byteN] := Asm.opc_stelem_i1;
2640 typePutE[ Ty.uBytN] := Asm.opc_stelem_i1;
2641 typePutE[ Ty.sIntN] := Asm.opc_stelem_i2;
2642 typePutE[ Ty.intN] := Asm.opc_stelem_i4;
2643 typePutE[ Ty.lIntN] := Asm.opc_stelem_i8;
2644 typePutE[ Ty.sReaN] := Asm.opc_stelem_r4;
2645 typePutE[ Ty.realN] := Asm.opc_stelem_r8;
2646 typePutE[ Ty.setN] := Asm.opc_stelem_i4;
2647 typePutE[Ty.anyPtr] := Asm.opc_stelem_ref;
2648 typePutE[Ty.anyRec] := Asm.opc_stelem_ref;
2649
2650 typeLdInd[ Ty.boolN] := Asm.opc_ldind_u1;
2651 typeLdInd[ Ty.sChrN] := Asm.opc_ldind_u2;
2652 typeLdInd[ Ty.charN] := Asm.opc_ldind_u2;
2653 typeLdInd[ Ty.byteN] := Asm.opc_ldind_i1;
2654 typeLdInd[ Ty.uBytN] := Asm.opc_ldind_u1;
2655 typeLdInd[ Ty.sIntN] := Asm.opc_ldind_i2;
2656 typeLdInd[ Ty.intN] := Asm.opc_ldind_i4;
2657 typeLdInd[ Ty.lIntN] := Asm.opc_ldind_i8;
2658 typeLdInd[ Ty.sReaN] := Asm.opc_ldind_r4;
2659 typeLdInd[ Ty.realN] := Asm.opc_ldind_r8;
2660 typeLdInd[ Ty.setN] := Asm.opc_ldind_i4;
2661 typeLdInd[Ty.anyPtr] := Asm.opc_ldind_ref;
2662 typeLdInd[Ty.anyRec] := Asm.opc_ldind_ref;
2663
2664 typeStInd[ Ty.boolN] := Asm.opc_stind_i1;
2665 typeStInd[ Ty.sChrN] := Asm.opc_stind_i2;
2666 typeStInd[ Ty.charN] := Asm.opc_stind_i2;
2667 typeStInd[ Ty.byteN] := Asm.opc_stind_i1;
2668 typeStInd[ Ty.uBytN] := Asm.opc_stind_i1;
2669 typeStInd[ Ty.sIntN] := Asm.opc_stind_i2;
2670 typeStInd[ Ty.intN] := Asm.opc_stind_i4;
2671 typeStInd[ Ty.lIntN] := Asm.opc_stind_i8;
2672 typeStInd[ Ty.sReaN] := Asm.opc_stind_r4;
2673 typeStInd[ Ty.realN] := Asm.opc_stind_r8;
2674 typeStInd[ Ty.setN] := Asm.opc_stind_i4;
2675 typeStInd[Ty.anyPtr] := Asm.opc_stind_ref;
2676 typeStInd[Ty.anyRec] := Asm.opc_stind_ref;
2677
2678 (* ============================================================ *)
2679 END MsilUtil.
2680 (* ============================================================ *)
[FORK] Old GPCP with patches
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024