2 (* ================================================================ *)
4 (* Module of the V1.4+ gpcp tool to create symbol files from *)
5 (* the metadata of .NET assemblies, using the PERWAPI interface. *)
7 (* Copyright QUT 2004 - 2005. *)
9 (* This code released under the terms of the GPCP licence. *)
11 (* This Module: <ClsToType> *)
12 (* Transforms PERWAPI classes to GPCP TypeDesc structures. *)
13 (* Original module, kjg December 2004 *)
15 (* ================================================================ *)
20 * Rfl := mscorlib_System_Reflection, (* temporary *)
21 * Sio
:= mscorlib_System_IO
, (* temporary *)
25 Per
:= "[QUT.PERWAPI]QUT.PERWAPI",
39 (* ------------------------------------------------------------ *)
41 CONST anon
* = 0; (* The anonymous hash index *)
43 CONST (* class kind enumeration *)
44 default
* = 0; refCls
* = 1; valCls
* = 2;
45 enuCls
* = 3; evtCls
* = 4; dlgCls
* = 5;
46 primTyp
* = 6; arrTyp
* = 7; voidTyp
* = 8;
47 strTyp
* = 9; objTyp
* = 10; sysValT
* = 11;
48 sysEnuT
* = 12; sysDelT
* = 13; sysExcT
* = 14; voidStar
* = 15;
50 CONST (* type attribute enumeration bits *)
51 absTp
= 7; intTp
= 5; sldTp
= 8;
53 (* field attribute enumeration bits *)
56 (* method attribute enumeration bits *)
57 stMth
= 4; fnMth
= 5; vrMth
= 6; nwMth
= 8; abMth
= 10;
59 (* ------------------------------------------------------------ *)
61 TYPE Namespace
* = POINTER TO ABSTRACT
RECORD
64 tIds
: VECTOR
OF Id
.TypId
;
67 DefNamespace
* = POINTER TO RECORD (Namespace
)
68 clss
: VECTOR
OF Per
.ClassDef
;
71 RefNamespace
* = POINTER TO RECORD (Namespace
)
72 clss
: VECTOR
OF Per
.ClassRef
;
75 (* ------------------------------------------------------------ *)
95 baseArrs
: ARRAY 18 OF Sy
.Type
;
97 (* ------------------------------------------------------------ *)
98 (* Utilities and Predicates *)
99 (* ------------------------------------------------------------ *)
101 PROCEDURE^
cpTypeFromCTS(peT
: Per
.Type
; spc
: DefNamespace
) : Sy
.Type
;
103 (* ------------------------------------------------ *)
105 PROCEDURE isExportedType(attr
: Per
.TypeAttr
) : BOOLEAN;
108 bits
:= BITS(attr
) * {0..2};
110 |
1, 2, 4, 7 : RETURN TRUE
;
115 (* ------------------------------------------------ *)
117 PROCEDURE isProtectedType(attr
: Per
.TypeAttr
) : BOOLEAN;
120 bits
:= BITS(attr
) * {0..2};
122 |
4, 7 : RETURN TRUE
;
127 (* ------------------------------------------------ *)
129 PROCEDURE isGenericClass(cls
: Per
.ClassDesc
) : BOOLEAN;
131 RETURN LEN(cls
.GetGenericParams()) > 0;
134 (* ------------------------------------------------ *)
136 PROCEDURE isGenericType(typ
: Per
.Type
) : BOOLEAN;
138 WITH typ
: Per
.ClassSpec
DO RETURN TRUE
;
139 | typ
: Per
.ClassDesc
DO RETURN isGenericClass(typ
);
140 | typ
: Per
.Array
DO RETURN isGenericType(typ
.ElemType());
145 (* ------------------------------------------------ *)
147 PROCEDURE isPublicClass(cls
: Per
.Class
) : BOOLEAN;
149 WITH cls
: Per
.NestedClassDef
DO
150 RETURN isExportedType(cls
.GetAttributes()) &
151 ~
isGenericType(cls
) &
152 isPublicClass(cls
.GetParentClass());
153 | cls
: Per
.ClassDef
DO
154 RETURN isExportedType(cls
.GetAttributes()) &
156 ELSE (* cls : Per.ClassRef ==> exported *)
161 (* ------------------------------------------------ *)
163 PROCEDURE hasGenericArg(mth
: Per
.Method
) : BOOLEAN;
166 prs
: POINTER TO ARRAY OF Per
.Type
;
168 prs
:= mth
.GetParTypes();
169 FOR idx
:= 0 TO LEN(prs
) - 1 DO
171 IF isGenericType(par
) THEN RETURN TRUE
END;
176 (* ------------------------------------------------ *)
178 PROCEDURE isGenericMethod(mth
: Per
.Method
) : BOOLEAN;
180 RETURN (mth
.GetGenericParam(0) # NIL) OR hasGenericArg(mth
);
183 (* ------------------------------------------------ *)
185 PROCEDURE isVarargMethod(mth
: Per
.Method
) : BOOLEAN;
187 RETURN mth
.GetCallConv() = Per
.CallConv
.Vararg
;
190 (* ------------------------------------------------ *)
192 PROCEDURE isNestedType(attr : Per.TypeAttr) : BOOLEAN;
195 bits := ORD(BITS(attr) * {0..2});
196 RETURN (bits >= 2) & (bits <= 7);
199 (* ------------------------------------------------ *)
201 PROCEDURE gpName(typ
: Per
.Class
) : RTS
.NativeString
;
203 WITH typ
: Per
.NestedClassDef
DO
204 RETURN gpName(typ
.GetParentClass()) + "$" + typ
.Name();
205 | typ
: Per
.NestedClassRef
DO
206 RETURN gpName(typ
.GetParentClass()) + "$" + typ
.Name();
212 (* ------------------------------------------------ *)
214 PROCEDURE gpSpce(typ
: Per
.Class
) : RTS
.NativeString
;
216 WITH typ
: Per
.NestedClassDef
DO
217 RETURN gpSpce(typ
.GetParentClass());
218 | typ
: Per
.NestedClassRef
DO
219 RETURN gpSpce(typ
.GetParentClass());
221 RETURN typ
.NameSpace();
225 (* ------------------------------------------------ *)
227 PROCEDURE ilName(mth
: Per
.Method
) : RTS
.NativeString
;
230 cls
:= mth
.GetParent()(Per
.Class
);
231 RETURN gpSpce(cls
) + "." + gpName(cls
) + "::'" + mth
.Name() + "'";
234 (* ------------------------------------------------ *)
236 PROCEDURE isCorLibRef(res
: Per
.ResolutionScope
) : BOOLEAN;
237 VAR str
: RTS
.NativeString
;
240 RETURN FALSE
; (* ==> this is corlib DEFINITION! *)
245 RETURN ((str
= "mscorlib") OR (str
= "CommonLanguageRuntimeLibrary"));
249 (* ------------------------------------------------ *)
251 PROCEDURE SayWhy(cls
: Per
.Class
);
252 VAR str
: Glb
.CharOpen
;
254 WITH cls
: Per
.ClassSpec
DO
255 str
:= BOX(" Hiding generic class -- ");
256 | cls
: Per
.NestedClassDef
DO
257 IF ~
isExportedType(cls
.GetAttributes()) THEN RETURN; (* just private! *)
258 ELSIF isGenericType(cls
) THEN
259 str
:= BOX(" Hiding generic class -- ");
260 ELSE (* ~isPublicClass(cls.GetParentClass()); *)
261 str
:= BOX(" Hiding public child of private class -- ");
263 | cls
: Per
.ClassDef
DO
264 IF ~
isExportedType(cls
.GetAttributes()) THEN RETURN; (* just private! *)
265 ELSE (* isGenericType(cls) *)
266 str
:= BOX(" Hiding generic class -- ");
269 Glb
.Message(str^
+ gpSpce(cls
) + "." + gpName(cls
));
272 (* ------------------------------------------------ *)
274 PROCEDURE getKind(typ
: Per
.Type
) : INTEGER;
277 name
: RTS
.NativeString
;
278 rScp
: Per
.ResolutionScope
;
280 WITH typ
: Per
.Array
DO (* --------------- *) RETURN arrTyp
;
281 | typ
: Per
.UnmanagedPointer
DO (* ------- *) RETURN voidStar
;
282 | typ
: Per
.PrimitiveType
DO
283 IF typ
= Per
.PrimitiveType
.Object
THEN RETURN objTyp
;
284 ELSIF typ
= Per
.PrimitiveType
.String
THEN RETURN strTyp
;
285 ELSIF typ
= Per
.PrimitiveType
.Void
THEN RETURN voidTyp
;
288 | typ
: Per
.ClassDef
DO
289 rScp
:= typ
.GetScope();
290 pTyp
:= typ
.get_SuperType();
292 * If this is *not* mscorlib, then check the kind of the parent.
294 IF ~Glb
.isCorLib
THEN
295 pEnu
:= getKind(pTyp
);
298 * If it has no parent, then it must be Object, or some ref class.
300 ELSIF pTyp
= NIL THEN RETURN refCls
;
302 * Since "ntvObj" and the others have not been initialized
303 * for the special case of processing mscorlib, we must look
304 * at the names of the parents.
307 name
:= gpName(pTyp
);
308 IF name
= "ValueType" THEN RETURN valCls
;
309 ELSIF name
= "Enum" THEN RETURN enuCls
;
310 ELSIF name
= "MulticastDelegate" THEN RETURN dlgCls
;
311 ELSE (* -------------------------------- *) RETURN refCls
;
314 | typ
: Per
.ClassRef
DO
315 rScp
:= typ
.GetScope();
318 ELSE (* ---------------------------------- *) RETURN default
;
321 IF isCorLibRef(rScp
) THEN
322 IF name
= "Object" THEN RETURN objTyp
;
323 ELSIF name
= "ValueType" THEN RETURN sysValT
;
324 ELSIF name
= "Enum" THEN RETURN sysEnuT
;
325 ELSIF name
= "MulticastDelegate" THEN RETURN sysDelT
;
326 ELSIF name
= "Exception" THEN RETURN sysExcT
;
330 IF pEnu
= sysValT
THEN RETURN valCls
;
331 ELSIF pEnu
= sysDelT
THEN RETURN dlgCls
;
332 ELSIF pEnu
= sysEnuT
THEN RETURN enuCls
;
333 ELSE (* ---------------------------------- *) RETURN refCls
;
337 (* ------------------------------------------------ *)
339 PROCEDURE kindStr(kind
: INTEGER) : Glb
.CharOpen
;
342 | default
: RETURN BOX("opaque ");
343 | refCls
: RETURN BOX("reference class ");
344 | valCls
: RETURN BOX("value class ");
345 | enuCls
: RETURN BOX("enumeration class ");
346 | evtCls
: RETURN BOX("event class ");
347 | dlgCls
: RETURN BOX("delegate ");
348 | primTyp
: RETURN BOX("primitive ");
349 | arrTyp
: RETURN BOX("array type ");
350 | voidTyp
: RETURN BOX("void type ");
351 | strTyp
: RETURN BOX("Sys.String ");
352 | objTyp
: RETURN BOX("Sys.Object ");
353 | sysValT
: RETURN BOX("Sys.ValueType ");
354 | sysEnuT
: RETURN BOX("Sys.Enum Type ");
355 | sysDelT
: RETURN BOX("Sys.MulticastDelegate");
356 | sysExcT
: RETURN BOX("Sys.Exception ");
357 | voidStar
: RETURN BOX("Sys.Void* ");
358 ELSE RETURN BOX("unknown ");
362 (* ------------------------------------------------ *)
364 PROCEDURE mapPrimitive(peT
: Per
.Type
) : Sy
.Type
;
366 IF peT
= Per
.PrimitiveType
.Int32
THEN RETURN Bi
.intTp
;
367 ELSIF peT
= Per
.PrimitiveType
.Char
THEN RETURN Bi
.charTp
;
368 ELSIF peT
= Per
.PrimitiveType
.Boolean
THEN RETURN Bi
.boolTp
;
369 ELSIF peT
= Per
.PrimitiveType
.Int16
THEN RETURN Bi
.sIntTp
;
370 ELSIF peT
= Per
.PrimitiveType
.Float64
THEN RETURN Bi
.realTp
;
371 ELSIF peT
= Per
.PrimitiveType
.Int64
THEN RETURN Bi
.lIntTp
;
372 ELSIF peT
= Per
.PrimitiveType
.Float32
THEN RETURN Bi
.sReaTp
;
373 ELSIF peT
= Per
.PrimitiveType
.Int8
THEN RETURN Bi
.byteTp
;
374 ELSIF peT
= Per
.PrimitiveType
.UInt8
THEN RETURN Bi
.uBytTp
;
375 ELSIF peT
= Per
.PrimitiveType
.UInt16
THEN RETURN sysU16
;
376 ELSIF peT
= Per
.PrimitiveType
.UInt32
THEN RETURN sysU32
;
377 ELSIF peT
= Per
.PrimitiveType
.UInt64
THEN RETURN sysU64
;
378 ELSIF peT
= Per
.PrimitiveType
.IntPtr
THEN RETURN intPtr
;
379 ELSIF peT
= Per
.PrimitiveType
.UIntPtr
THEN RETURN uIntPt
;
380 ELSIF peT
= Per
.PrimitiveType
.TypedRef
THEN RETURN tpdRef
;
381 ELSE (* ------------------------------- *) RETURN NIL;
385 (* ------------------------------------------------ *)
387 PROCEDURE makeNameType(blk
: Id
.BlkId
; hsh
: INTEGER) : Id
.TypId
;
390 tId
:= Id
.newTypId(Ty
.newNamTp());
393 tId
.type
.idnt
:= tId
;
394 tId
.SetMode(Sy
.pubMode
);
395 Glb
.ListTy(tId
.type
);
396 IF Sy
.refused(tId
, blk
) THEN Glb
.AbortMsg("bad TypId insert") END;
400 (* ------------------------------------------------ *)
402 PROCEDURE lookup(peT
: Per
.Class
; nSp
: DefNamespace
) : Sy
.Type
;
403 VAR asm
: Glb
.CharOpen
; (* assembly file name *)
404 spc
: Glb
.CharOpen
; (* namespace name str *)
405 mNm
: Glb
.CharOpen
; (* CP module name *)
406 cNm
: Glb
.CharOpen
; (* PE file class name *)
407 blk
: Sy
.Idnt
; (* The Blk descriptor *)
408 bId
: Id
.BlkId
; (* The Blk descriptor *)
409 tId
: Sy
.Idnt
; (* TypId descriptor *)
410 hsh
: INTEGER; (* Class name hash *)
411 (* -------------------------------------------- *)
412 PROCEDURE NoteImport(spc
: DefNamespace
; imp
: Id
.BlkId
);
414 IF (spc
# NIL) & (spc
.bloc
# imp
) THEN
415 IF ~Sy
.refused(imp
, spc
.bloc
) THEN
417 Console
.WriteString("Inserting import <");
418 Console
.WriteString(Nh
.charOpenOfHash(imp
.hash
));
419 Console
.WriteString("> in Namespace ");
420 Console
.WriteString(Nh
.charOpenOfHash(spc
.bloc
.hash
));
426 (* -------------------------------------------- *)
430 * First we establish the (mangled) name of the defining scope.
432 WITH peT
: Per
.ClassDef
DO
433 asm
:= BOX(Glb
.basNam^
); (* Must do a value copy *)
434 | peT
: Per
.ClassRef
DO
435 asm
:= BOX(peT
.GetScope().Name());
440 * FNm.StripExt(asm, asm);
441 * spc := BOX(peT.NameSpace());
443 spc
:= BOX(gpSpce(peT
));
444 mNm
:= Mng
.MangledName(asm
, spc
);
446 * Check if this name is already known to PeToCps
448 blk
:= Glb
.thisMod
.symTb
.lookup(Nh
.enterStr(mNm
));
449 cNm
:= BOX(gpName(peT
));
450 hsh
:= Nh
.enterStr(cNm
);
451 WITH blk
: Id
.BlkId
DO
453 * The module name is known to PeToCps.
454 * However, it may not have been listed as an import
455 * into the current namespace, in the case of multiple
456 * namespaces defined in the same source PEFile.
458 NoteImport(nSp
, blk
);
460 tId
:= blk
.symTb
.lookup(hsh
);
461 IF (tId
# NIL) & (tId
IS Id
.TypId
) THEN
469 * Could not find the type identifier descriptor.
473 * Create a BlkId for the namespace.
476 INCL(bId
.xAttr
, Sy
.need
);
477 Glb
.BlkIdInit(bId
, asm
, spc
);
479 * ... and in any case, this new BlkId is an
480 * import into the current namespace scope.
482 NoteImport(nSp
, bId
);
485 * Now create a TypId, and insert in block symTab.
487 tId
:= makeNameType(bId
, hsh
);
491 (* ------------------------------------------------ *)
493 PROCEDURE ptrToArrayOf(elTp
: Sy
.Type
) : Sy
.Type
;
495 (* -------------------------------------------- *)
496 PROCEDURE getPtr(elT
: Sy
.Type
) : Sy
.Type
;
497 VAR arT
, ptT
: Sy
.Type
;
499 arT
:= Ty
.mkArrayOf(elT
); Glb
.ListTy(arT
);
500 ptT
:= Ty
.mkPtrTo(arT
); Glb
.ListTy(ptT
); RETURN ptT
;
502 (* -------------------------------------------- *)
504 WITH elTp
: Ty
.Base
DO
505 ptrT
:= baseArrs
[elTp
.tpOrd
];
507 ptrT
:= getPtr(elTp
);
508 baseArrs
[elTp
.tpOrd
] := ptrT
;
511 ptrT
:= getPtr(elTp
);
516 (* ------------------------------------------------ *)
518 PROCEDURE cpTypeFromCTS(peT
: Per
.Type
; spc
: DefNamespace
) : Sy
.Type
;
521 kind
:= getKind(peT
);
523 | voidTyp
: RETURN NIL;
524 | arrTyp
: RETURN ptrToArrayOf(
525 cpTypeFromCTS(peT(Per
.Array
).ElemType(), spc
));
526 | primTyp
: RETURN mapPrimitive(peT
);
527 | strTyp
: RETURN ntvStr
;
528 | objTyp
: RETURN ntvObj
;
529 | sysValT
: RETURN ntvVal
;
530 | sysEnuT
: RETURN ntvEnu
;
531 | sysDelT
: RETURN ntvEvt
;
532 | voidStar
: RETURN voidSt
;
534 ELSE (* default, refCls, valCls, enuCls, evtCls, dlgCls *)
535 WITH peT
: Per
.Class
DO
536 RETURN lookup(peT
, spc
);
539 Console
.WriteString("Not a class -- ");
547 (* ------------------------------------------------ *)
549 PROCEDURE modeFromMbrAtt(att
: SET) : INTEGER;
551 CASE ORD(att
* {0,1,2}) OF
552 |
4, 5 : RETURN Sy
.protect
;
553 |
6 : RETURN Sy
.pubMode
;
554 ELSE RETURN Sy
.prvMode
;
558 (* ------------------------------------------------ *)
560 PROCEDURE mkParam(IN nam
: ARRAY OF CHAR;
563 rcv
: BOOLEAN) : Id
.ParId
;
566 par
:= Id
.newParId();
569 par
.hash
:= Nh
.enterStr(nam
);
574 (* ------------------------------------------------------------ *)
576 PROCEDURE isValClass(cls
: Per
.Type
) : BOOLEAN;
578 RETURN getKind(cls
) = valCls
;
581 (* ------------------------------------------------------------ *)
582 (* Main processing code *)
583 (* ------------------------------------------------------------ *)
585 PROCEDURE (spc
: DefNamespace
)AddRecFld(rec
: Ty
.Record
;
586 fld
: Per
.FieldDef
), NEW;
594 (* ------------------------------------ *)
595 PROCEDURE conExp(val
: Per
.Constant
) : Sy
.Expr
;
596 VAR byts
: POINTER TO ARRAY OF UBYTE
;
597 chrs
: POINTER TO ARRAY OF CHAR;
600 WITH val
: Per
.DoubleConst
DO
601 RETURN Xp
.mkRealLt(val
.GetDouble());
602 | val
: Per
.FloatConst
DO
603 RETURN Xp
.mkRealLt(val
.GetDouble());
604 | val
: Per
.CharConst
DO
605 RETURN Xp
.mkCharLt(val
.GetChar());
606 | val
: Per
.IntConst
DO
607 RETURN Xp
.mkNumLt(val
.GetLong());
608 | val
: Per
.UIntConst
DO
609 RETURN Xp
.mkNumLt(val
.GetULongAsLong());
610 | val
: Per
.StringConst
DO
611 byts
:= val
.GetStringBytes();
612 NEW(chrs
, LEN(byts
) DIV 2 + 1);
613 FOR indx
:= 0 TO (LEN(byts
) DIV 2)-1 DO
614 chrs
[indx
] := CHR(byts
[indx
*2] + byts
[indx
*2 + 1] * 256);
616 (* RETURN Xp.mkStrLt(chrs); *)
617 RETURN Xp
.mkStrLenLt(chrs
, LEN(chrs
) - 1); (* CHECK THIS! *)
620 (* ------------------------------------ *)
622 bts
:= BITS(fld
.GetFieldAttr());
623 mod
:= modeFromMbrAtt(bts
);
624 IF mod
> Sy
.prvMode
THEN
625 hsh
:= Nh
.enterStr(fld
.Name());
626 IF ltFld
IN bts
THEN (* literal field *)
627 cId
:= Id
.newConId();
631 cId
.type
:= cpTypeFromCTS(fld
.GetFieldType(), spc
);
632 cId
.conExp
:= conExp(fld
.GetValue());
633 res
:= rec
.symTb
.enter(hsh
, cId
);
634 Sy
.AppendIdnt(rec
.statics
, cId
);
635 ELSIF stFld
IN bts
THEN (* static field *)
636 vId
:= Id
.newVarId();
640 vId
.type
:= cpTypeFromCTS(fld
.GetFieldType(), spc
);
641 res
:= rec
.symTb
.enter(hsh
, vId
);
642 Sy
.AppendIdnt(rec
.statics
, vId
);
643 ELSE (* instance field *)
644 fId
:= Id
.newFldId();
648 fId
.type
:= cpTypeFromCTS(fld
.GetFieldType(), spc
);
649 res
:= rec
.symTb
.enter(hsh
, fId
);
650 Sy
.AppendIdnt(rec
.fields
, fId
);
655 (* ------------------------------------------------------------ *)
657 PROCEDURE (spc
: DefNamespace
)AddFormals(typ
: Ty
.Procedure
;
658 mth
: Per
.MethodDef
), NEW;
664 pars
: POINTER TO ARRAY OF Per
.Param
;
667 typ
.retType
:= cpTypeFromCTS(mth
.GetRetType(), spc
);
668 pars
:= mth
.GetParams();
669 FOR indx
:= 0 TO LEN(pars
) - 1 DO
672 thsT
:= thsP
.GetParType();
673 IF thsT
IS Per
.ManagedPointer
THEN
674 thsT
:= thsT(Per
.PtrType
).GetBaseType(); pMod
:= Sy
.var
;
676 pPar
:= mkParam(thsP
.GetName(), pMod
, cpTypeFromCTS(thsT
, spc
), FALSE
);
677 Id
.AppendParam(typ
.formals
, pPar
);
681 (* ------------------------------------------------------------ *)
683 PROCEDURE (spc
: DefNamespace
)AddRecMth(rec
: Ty
.Record
;
684 mth
: Per
.MethodDef
), NEW;
692 rcv
: Per
.Type
; (* Receiver type *)
695 (* SPECIAL FOR PRE 1.4 VERSION *)
696 IF isGenericMethod(mth
) THEN
697 Glb
.CondMsg(" Hiding generic method -- " + ilName(mth
));
699 ELSIF isVarargMethod(mth
) THEN
700 Glb
.CondMsg(" Hiding Vararg call method -- " + ilName(mth
));
703 bts
:= BITS(mth
.GetMethAttributes());
704 mod
:= modeFromMbrAtt(bts
);
705 IF mod
> Sy
.prvMode
THEN
706 hsh
:= Nh
.enterStr(mth
.Name());
708 IF stMth
IN bts
THEN (* static method *)
709 pId
:= Id
.newPrcId();
710 pId
.SetKind(Id
.conPrc
);
713 pTp
:= Ty
.newPrcTp();
716 spc
.AddFormals(pTp
, mth
);
717 res
:= rec
.symTb
.enter(hsh
, pId
);
718 Sy
.AppendIdnt(rec
.statics
, pId
);
721 ELSIF hsh
= Glb
.ctorBkt
THEN (* constructor method *)
722 pId
:= Id
.newPrcId();
723 pId
.SetKind(Id
.ctorP
);
724 pId
.hash
:= Glb
.initBkt
;
725 pId
.prcNm
:= BOX(".ctor");
727 pTp
:= Ty
.newPrcTp();
730 spc
.AddFormals(pTp
, mth
);
731 rcv
:= mth
.GetParent()(Per
.Type
);
732 pTp
.retType
:= cpTypeFromCTS(rcv
, spc
);
733 res
:= rec
.symTb
.enter(Glb
.initBkt
, pId
);
734 Sy
.AppendIdnt(rec
.statics
, pId
);
737 ELSE (* instance method *)
738 mId
:= Id
.newMthId();
739 mId
.SetKind(Id
.conMth
);
744 rcv
:= mth
.GetParent()(Per
.Type
);
745 IF isValClass(rcv
) THEN pMd
:= Sy
.var
END;
747 mId
.rcvFrm
:= mkParam("this", pMd
, cpTypeFromCTS(rcv
, spc
), TRUE
);
748 pTp
:= Ty
.newPrcTp();
752 spc
.AddFormals(pTp
, mth
);
755 mId
.mthAtt
:= Id
.isAbs
;
756 ELSIF (vrMth
IN bts
) & ~
(fnMth
IN bts
) THEN
757 mId
.mthAtt
:= Id
.extns
;
759 IF ~
(vrMth
IN bts
) OR (nwMth
IN bts
) THEN
760 INCL(mId
.mthAtt
, Id
.newBit
);
763 (* FIXME -- boxRcv flag needs to be set ... *)
765 res
:= rec
.symTb
.enter(hsh
, mId
);
766 Sy
.AppendIdnt(rec
.methods
, mId
);
771 (* ------------------------------------------------------------ *)
773 PROCEDURE (spc
: DefNamespace
)AddRecEvt(rec
: Ty
.Record
;
774 evt
: Per
.Event
), NEW;
776 nam
: RTS
.NativeString
;
781 eTp
:= evt
.GetEventType();
783 hsh
:= Nh
.enterStr(nam
);
784 fId
:= Id
.newFldId();
786 fId
.SetMode(Sy
.pubMode
);
788 fId
.type
:= cpTypeFromCTS(eTp
, spc
);
789 res
:= rec
.symTb
.enter(hsh
, fId
);
790 Sy
.AppendIdnt(rec
.fields
, fId
);
793 (* ------------------------------------------------------------ *)
795 PROCEDURE MakeRefCls(cls
: Per
.ClassDef
;
799 VAR ptr
: Ty
.Pointer
;
800 (* ------------------------------------------------- *)
801 PROCEDURE mkRecord(cls
: Per
.ClassDef
;
803 att
: Per
.TypeAttr
) : Ty
.Record
;
810 ifA
: POINTER TO ARRAY OF Per
.Class
;
813 rec
:= Ty
.newRecTp();
814 spr
:= cls
.get_SuperType();
816 ifA
:= cls
.GetInterfaces();
818 FOR idx
:= 0 TO LEN(ifA
) - 1 DO
820 IF ~
(ifE
IS Per
.ClassSpec
) & isPublicClass(ifE
) THEN
821 Sy
.AppendType(rec
.interfaces
, cpTypeFromCTS(ifE
, spc
));
822 ELSIF Glb
.verbose
THEN
828 IF spr
= NIL THEN knd
:= objTyp
ELSE knd
:= getKind(spr
) END;
829 IF knd
# objTyp
THEN rec
.baseTp
:= cpTypeFromCTS(spr
, spc
) END;
831 * The INTERFACE test must come first, since
832 * these have the ABSTRACT bit set as well.
834 IF intTp
IN bts
THEN rec
.recAtt
:= Ty
.iFace
;
836 * Now the ABSTRACT but not interface case.
838 ELSIF absTp
IN bts
THEN rec
.recAtt
:= Ty
.isAbs
;
840 * If class is sealed, then default for CP.
842 ELSIF sldTp
IN bts
THEN rec
.recAtt
:= Ty
.noAtt
;
844 * Else CP default is EXTENSIBLE.
846 ELSE rec
.recAtt
:= Ty
.extns
;
849 * This is effectively the "no __copy__" flag.
851 IF ~Glb
.cpCmpld
THEN INCL(rec
.xAttr
, Sy
.isFn
) END;
855 (* ------------------------------------------------- *)
858 * Create the descriptors.
860 ptr
:= Ty
.newPtrTp();
861 tId
:= Id
.newTypId(ptr
);
863 ptr
.boundTp
:= mkRecord(cls
, spc
, att
);
864 ptr
.boundTp(Ty
.Record
).bindTp
:= ptr
;
865 tId
.hash
:= Nh
.enterStr(gpName(cls
));
869 (* ------------------------------------------------------------ *)
871 PROCEDURE MakeEnumTp(cls
: Per
.ClassDef
;
876 * Create the descriptors.
878 enu
:= Ty
.newEnuTp();
879 tId
:= Id
.newTypId(enu
);
880 tId
.hash
:= Nh
.enterStr(gpName(cls
));
885 (* ------------------------------------------------ *)
887 PROCEDURE MakeValCls(cls
: Per
.ClassDef
;
892 * Create the descriptors.
894 rec
:= Ty
.newRecTp();
895 tId
:= Id
.newTypId(rec
);
897 tId
.hash
:= Nh
.enterStr(gpName(cls
));
898 IF ~Glb
.cpCmpld
THEN INCL(rec
.xAttr
, Sy
.isFn
) END;
902 (* ------------------------------------------------ *)
904 PROCEDURE MakePrcCls(cls
: Per
.ClassDef
;
906 VAR prc
: Ty
.Procedure
;
909 * Create the descriptors.
911 (* (* We have no way of distinguishing between *)
912 * prc
:= Ty
.newPrcTp(); (* CP EVENT and CP PROCEDURE types from the *)
913 *)
(* PE-file. So, default to EVENT meantime. *)
914 prc
:= Ty
.newEvtTp();
915 tId
:= Id
.newTypId(prc
);
917 tId
.hash
:= Nh
.enterStr(gpName(cls
));
921 (* ------------------------------------------------------------ *)
923 PROCEDURE (spc
: DefNamespace
)DefineRec(cls
: Per
.ClassDef
;
924 rec
: Ty
.Record
), NEW;
926 flds
: POINTER TO ARRAY OF Per
.FieldDef
;
927 evts
: POINTER TO ARRAY OF Per
.Event
;
928 mths
: POINTER TO ARRAY OF Per
.MethodDef
;
931 * Now fill in record fields ...
933 flds
:= cls
.GetFields();
934 FOR indx
:= 0 TO LEN(flds
) - 1 DO
935 spc
.AddRecFld(rec
, flds
[indx
]);
938 * Now fill in record events ...
940 evts
:= cls
.GetEvents();
941 FOR indx
:= 0 TO LEN(evts
) - 1 DO
942 spc
.AddRecEvt(rec
, evts
[indx
]);
945 * Now fill in record methods ...
947 mths
:= cls
.GetMethods();
948 FOR indx
:= 0 TO LEN(mths
) - 1 DO
949 spc
.AddRecMth(rec
, mths
[indx
]);
953 (* ------------------------------------------------------------ *)
955 PROCEDURE (spc
: DefNamespace
)DefineEnu(cls
: Per
.ClassDef
;
957 CONST litB
= 6; (* 40H *)
960 flds
: POINTER TO ARRAY OF Per
.FieldDef
;
965 sCon
: Per
.SimpleConstant
;
968 * Now fill in record details ...
970 flds
:= cls
.GetFields();
971 FOR indx
:= 0 TO LEN(flds
) - 1 DO
973 bits
:= BITS(thsF
.GetFieldAttr());
974 mode
:= modeFromMbrAtt(bits
);
975 IF (mode
> Sy
.prvMode
) & (litB
IN bits
) THEN
976 sCon
:= thsF
.GetValue()(Per
.SimpleConstant
);
977 WITH sCon
: Per
.IntConst
DO valu
:= sCon
.GetLong();
978 | sCon
: Per
.UIntConst
DO valu
:= sCon
.GetULongAsLong();
980 thsC
:= Id
.newConId();
982 thsC
.hash
:= Nh
.enterStr(thsF
.Name());
983 thsC
.conExp
:= Xp
.mkNumLt(valu
);
984 thsC
.type
:= Bi
.intTp
;
985 Sy
.AppendIdnt(enu
.statics
, thsC
);
990 (* ------------------------------------------------------------ *)
992 PROCEDURE (spc
: DefNamespace
)DefinePrc(cls
: Per
.ClassDef
;
993 prc
: Ty
.Procedure
), NEW;
996 invk
: Per
.MethodDef
;
999 * Now fill in parameter details ...
1001 invk
:= cls
.GetMethod(MKSTR("Invoke"));
1002 spc
.AddFormals(prc
, invk
);
1006 (* ------------------------------------------------------------ *)
1008 PROCEDURE MakeTypIds
*(thsN
: DefNamespace
);
1010 thsC
: Per
.ClassDef
;
1011 attr
: Per
.TypeAttr
;
1017 * For every namespace, define gpcp descriptors
1018 * for each class, method, field and constant.
1020 Glb
.CondMsg(" CP Module name - " + Nh
.charOpenOfHash(thsN
.bloc
.hash
)^
);
1021 Glb
.CondMsg(' Alternative import name
- "' + thsN.bloc.scopeNm^ + '"'
);
1022 FOR indx
:= 0 TO LEN(thsN
.clss
) - 1 DO
1023 thsC
:= thsN
.clss
[indx
];
1024 attr
:= thsC
.GetAttributes();
1025 tEnu
:= getKind(thsC
);
1028 Console
.WriteString(" ");
1029 Console
.WriteString(kindStr(tEnu
)); Console
.Write(ASCII
.HT
);
1030 Console
.WriteString(gpName(thsC
));
1035 | refCls
: MakeRefCls(thsC
, thsN
, attr
, tpId
);
1036 | valCls
: MakeValCls(thsC
, tpId
);
1037 | enuCls
: MakeEnumTp(thsC
, tpId
);
1039 * | evtCls : MakeEvtCls(thsC, tpId);
1041 | dlgCls
: MakePrcCls(thsC
, tpId
);
1044 (* ---- temporary ---- *)
1046 (* ---- temporary ---- *)
1047 IF isProtectedType(attr
) THEN
1048 tpId
.SetMode(Sy
.protect
);
1050 tpId
.SetMode(Sy
.pubMode
);
1052 tpId
.dfScp
:= thsN
.bloc
;
1053 IF ~thsN
.bloc
.symTb
.enter(tpId
.hash
, tpId
) THEN
1055 * Just a sanity check!
1057 clsh
:= thsN
.bloc
.symTb
.lookup(tpId
.hash
);
1058 ASSERT((clsh
IS Id
.TypId
) & (clsh
.type
IS Ty
.Opaque
));
1060 thsN
.bloc
.symTb
.Overwrite(tpId
.hash
, tpId
);
1062 (* ---- temporary ---- *)
1064 (* ---- temporary ---- *)
1065 APPEND(thsN
.tIds
, tpId
);
1069 (* ------------------------------------------------ *)
1070 (* ------------------------------------------------ *
1072 PROCEDURE MakeRefIds(thsN : RefNamespace);
1074 thsC : Per.ClassRef;
1079 * For every namespace, define gpcp TypId descriptors for each class
1082 Glb
.Message(" GPCP-Module name - " + Nh
.charOpenOfHash(thsN
.bloc
.hash
)^
);
1084 FOR indx
:= 0 TO LEN(thsN
.clss
) - 1 DO
1085 thsC
:= thsN
.clss
[indx
];
1087 Console
.WriteString(" class rfrnce ");
1088 Console
.WriteString(gpName(thsC
));
1091 tpId
:= makeNameType(thsN
.bloc
, Nh
.enterStr(gpName(thsC
)));
1092 APPEND(thsN
.tIds
, tpId
);
1096 * ------------------------------------------------ *)
1097 (* ------------------------------------------------ *)
1099 PROCEDURE MakeBlkId
*(spc
: Namespace
; aNm
: Glb
.CharOpen
);
1102 INCL(spc
.bloc
.xAttr
, Sy
.need
);
1103 Glb
.BlkIdInit(spc
.bloc
, aNm
, Nh
.charOpenOfHash(spc
.hash
));
1104 IF Glb
.superVb
THEN Glb
.Message("Creating blk - " +
1105 Nh
.charOpenOfHash(spc
.bloc
.hash
)^
) END;
1108 (* ------------------------------------------------ *)
1110 PROCEDURE DefineClss
*(thsN
: DefNamespace
);
1115 thsC
: Per
.ClassDef
;
1118 * For every namespace, define gpcp descriptors
1119 * for each class, method, field and constant.
1121 FOR indx
:= 0 TO LEN(thsN
.clss
) - 1 DO
1122 thsC
:= thsN
.clss
[indx
];
1123 thsI
:= thsN
.tIds
[indx
];
1124 tEnu
:= getKind(thsC
);
1127 | valCls
: thsN
.DefineRec(thsC
, thsI
.type(Ty
.Record
));
1128 | enuCls
: thsN
.DefineEnu(thsC
, thsI
.type(Ty
.Enum
));
1129 | dlgCls
: thsN
.DefinePrc(thsC
, thsI
.type(Ty
.Procedure
));
1130 | refCls
: thsT
:= thsI
.type(Ty
.Pointer
).boundTp
;
1131 thsN
.DefineRec(thsC
, thsT(Ty
.Record
));
1133 * | evtCls : thsN.MakeEvtCls(thsC, ); (* Can't distinguish from dlgCls! *)
1140 (* ------------------------------------------------------------ *)
1141 (* Separate flat class-list into lists for each namespace *)
1142 (* ------------------------------------------------------------ *)
1144 PROCEDURE Classify
*(IN clss
: ARRAY OF Per
.ClassDef
;
1145 OUT nVec
: VECTOR
OF DefNamespace
);
1147 thsC
: Per
.ClassDef
;
1148 attr
: Per
.TypeAttr
;
1149 (* ======================================= *)
1150 PROCEDURE Insert(nVec
: VECTOR
OF DefNamespace
;
1151 thsC
: Per
.ClassDef
);
1154 nSpc
: RTS
.NativeString
;
1155 cNam
: RTS
.NativeString
;
1156 newN
: DefNamespace
;
1158 nSpc
:= gpSpce(thsC
);
1159 cNam
:= gpName(thsC
);
1160 IF nSpc
= "" THEN thsH
:= anon
ELSE thsH
:= Nh
.enterStr(nSpc
) END;
1162 * See if already a Namespace for this hash bucket
1164 FOR jndx
:= 0 TO LEN(nVec
) - 1 DO
1165 IF nVec
[jndx
].hash
= thsH
THEN
1166 APPEND(nVec
[jndx
].clss
, thsC
); RETURN; (* FORCED EXIT! *)
1170 * Else insert in a new Namespace
1172 NEW(newN
); (* Create new DefNamespace object *)
1173 NEW(newN
.clss
, 8); (* Create new vector of ClassDef *)
1174 NEW(newN
.tIds
, 8); (* Create new vector of Id.TypId *)
1176 APPEND(newN
.clss
, thsC
); (* Append class to new class vector *)
1177 APPEND(nVec
, newN
); (* Append new DefNamespace to result *)
1179 (* ======================================= *)
1182 FOR indx
:= 0 TO LEN(clss
) - 1 DO
1184 IF isPublicClass(thsC
) THEN
1186 ELSIF Glb
.verbose
THEN
1189 (* ------------------------------------- *
1190 * attr := thsC.GetAttributes();
1191 * IF isExportedType(attr) THEN
1192 * IF ~isGenericClass(thsC) THEN (* SPECIAL FOR PRE 1.4 VERSION *)
1193 * Insert(nVec
, thsC
);
1194 * ELSIF Glb
.verbose
THEN
1195 * Glb
.Message(" Hiding generic class -- " +
1196 * gpSpce(thsC
) + "." + gpName(thsC
));
1199 * ------------------------------------- *)
1202 IF LEN(nVec
) = 1 THEN
1203 Glb
.Message(" Found one def namespace");
1205 Glb
.Message(" Found "+Ltv
.intToCharOpen(LEN(nVec
))^
+" def namespaces");
1210 (* ------------------------------------------------------------- *)
1211 (* ------------------------------------------------------------- *)
1213 PROCEDURE InitCorLibTypes
*();
1216 * Create import descriptor for [mscorlib]System
1218 Bi
.MkDummyImport("mscorlib_System", "[mscorlib]System", corLib
);
1220 * Create various classes.
1222 ntvObj
:= makeNameType(corLib
, Nh
.enterStr("Object")).type
;
1223 ntvStr
:= makeNameType(corLib
, Nh
.enterStr("String")).type
;
1224 ntvExc
:= makeNameType(corLib
, Nh
.enterStr("Exception")).type
;
1225 ntvTyp
:= makeNameType(corLib
, Nh
.enterStr("Type")).type
;
1226 ntvEvt
:= makeNameType(corLib
, Nh
.enterStr("MulticastDelegate")).type
;
1227 ntvVal
:= makeNameType(corLib
, Nh
.enterStr("ValueType")).type
;
1228 ntvEnu
:= makeNameType(corLib
, Nh
.enterStr("Enum")).type
;
1230 * Do the unsigned types with no CP equivalent.
1232 sysU16
:= makeNameType(corLib
, Nh
.enterStr("UInt16")).type
;
1233 sysU32
:= makeNameType(corLib
, Nh
.enterStr("UInt32")).type
;
1234 sysU64
:= makeNameType(corLib
, Nh
.enterStr("UInt64")).type
;
1235 voidSt
:= makeNameType(corLib
, Nh
.enterStr("VoidStar")).type
;
1236 intPtr
:= makeNameType(corLib
, Nh
.enterStr("IntPtr")).type
;
1237 uIntPt
:= makeNameType(corLib
, Nh
.enterStr("UIntPtr")).type
;
1238 tpdRef
:= makeNameType(corLib
, Nh
.enterStr("TypedReference")).type
;
1239 END InitCorLibTypes
;
1241 (* ------------------------------------------------------------- *)
1243 PROCEDURE ImportCorlib*();
1245 Glb.InsertImport(corLib);
1246 INCL(corLib.xAttr, Sy.need);
1249 (* ------------------------------------------------------------- *)
1251 PROCEDURE ImportCorlib
*(spc
: DefNamespace
);
1253 IF (spc
# NIL) & (spc
.bloc
# corLib
) THEN
1254 IF ~Sy
.refused(corLib
, spc
.bloc
) THEN
1256 Console
.WriteString("Inserting import <");
1257 Console
.WriteString(Nh
.charOpenOfHash(corLib
.hash
));
1258 Console
.WriteString("> in Namespace ");
1259 Console
.WriteString(Nh
.charOpenOfHash(spc
.bloc
.hash
));
1264 INCL(corLib
.xAttr
, Sy
.need
);
1267 (* ------------------------------------------------------------- *)
1269 PROCEDURE BindSystemTypes
*();
1270 VAR blk
: Id
.BlkId
; (* The Blk descriptor *)
1272 (* -------------------------- *)
1273 PROCEDURE MakeAbstract(blk
: Id
.BlkId
; hsh
: INTEGER);
1275 blk
.symTb
.lookup(hsh
).type(Ty
.Record
).recAtt
:= Ty
.isAbs
;
1277 (* -------------------------- *)
1280 * Load import descriptor for [mscorlib]System
1282 corLib
:= Glb
.thisMod
.symTb
.lookup(
1283 Nh
.enterStr("mscorlib_System"))(Id
.BlkId
);
1287 * THIS IS ONLY EXPERIMENTAL
1288 * We make the record types that correspond to the
1289 * primitive types abstract to prevent the declaration
1290 * of variables of these types.
1292 * The static methods can still be called, of course.
1294 MakeAbstract(blk
, Nh
.enterStr("Boolean"));
1295 MakeAbstract(blk
, Nh
.enterStr("Byte"));
1296 MakeAbstract(blk
, Nh
.enterStr("Char"));
1297 MakeAbstract(blk
, Nh
.enterStr("SByte"));
1298 MakeAbstract(blk
, Nh
.enterStr("Int16"));
1299 MakeAbstract(blk
, Nh
.enterStr("Int32"));
1300 MakeAbstract(blk
, Nh
.enterStr("Int64"));
1301 MakeAbstract(blk
, Nh
.enterStr("UInt16"));
1302 MakeAbstract(blk
, Nh
.enterStr("UInt32"));
1303 MakeAbstract(blk
, Nh
.enterStr("UInt64"));
1305 * Create various classes.
1307 tId
:= blk
.symTb
.lookup(Nh
.enterStr("Object"));
1310 tId
:= blk
.symTb
.lookup(Nh
.enterStr("String"));
1313 tId
:= blk
.symTb
.lookup(Nh
.enterStr("Exception"));
1316 tId
:= blk
.symTb
.lookup(Nh
.enterStr("Type"));
1319 tId
:= blk
.symTb
.lookup(Nh
.enterStr("MulticastDelegate"));
1322 tId
:= blk
.symTb
.lookup(Nh
.enterStr("ValueType"));
1325 tId
:= blk
.symTb
.lookup(Nh
.enterStr("Enum"));
1328 * Do the unsigned types with no CP equivalent.
1330 tId
:= blk
.symTb
.lookup(Nh
.enterStr("UInt16"));
1333 tId
:= blk
.symTb
.lookup(Nh
.enterStr("UInt32"));
1336 tId
:= blk
.symTb
.lookup(Nh
.enterStr("UInt64"));
1339 * Do the miscellaneous values
1341 tId
:= blk
.symTb
.lookup(Nh
.enterStr("IntPtr"));
1345 tId
:= blk
.symTb
.lookup(Nh
.enterStr("UIntPtr"));
1348 tId
:= blk
.symTb
.lookup(Nh
.enterStr("TypedReference"));
1351 END BindSystemTypes
;
1353 (* ------------------------------------------------------------- *)
1357 (* ------------------------------------------------------------- *)