<<>> <> <> <> <> DIRECTORY Alloc USING [AddNotify, DropNotify, Handle, Notifier, Top, Units], ConvertUnsafe USING [SubString], LiteralOps USING [FindCard], Literals USING [STIndex], MimData USING [idATOM, idINT, interface, mainCtx, ownSymbols, typeRefANY], RTMob USING [RefLitIndex, TypeIndex], SymbolOps USING [ClusterSe, CtxLevel, DecodeBitAddr, DecodeType, EncodeCard, EncodeTreeIndex, EnterString, FirstCtxSe, FromType, MakeCtxSe, MakeNonCtxSe, NextSe, own, TypeForm, UnderType], Symbols USING [Base, BitAddress, CSEIndex, CTXIndex, CTXNull, ctxType, FirstStandardCtx, ISEIndex, ISENull, LastStandardCtx, lZ, MDIndex, MDNull, Name, nullType, OwnMdi, SERecord, seType, Type, typeANY], SymbolSegment USING [atType], SymLiteralOps USING [RefLitItem, RefLitsVisitor, TypesVisitor], Table USING [Base, IndexRep, Selector], Target: TYPE MachineParms USING [bitOrder, bitsPerWord], Tree USING [Link, nullIndex], TreeOps USING [PopTree, PushLit, PushNode, PushSe, SetAttr, SetInfo], Types USING [Equivalent]; SymLiteralOpsImpl: PROGRAM IMPORTS Alloc, MimData, LiteralOps, SymbolOps, TreeOps, Types EXPORTS SymLiteralOps = { OPEN Symbols; RefLitItem: TYPE = SymLiteralOps.RefLitItem; bitsPerWord: NAT = Target.bitsPerWord; <> SymLitRecord: TYPE = RECORD [ used: BOOL, cases: SELECT tag: * FROM type => [typeCode: Type, canonical: BOOL], lit => [type: Type, info: RefLitItem] ENDCASE]; SymLitIndex: TYPE = Table.Base RELATIVE LONG ORDERED POINTER TO SymLitRecord; SymLitFirst: SymLitIndex = LOOPHOLE[Table.IndexRep[tag: 0, highBits:0, lowBits:0]]; <> table: Alloc.Handle ¬ NIL; atType: Table.Selector = SymbolSegment.atType; slb: Table.Base ¬ NIL; seb: Symbols.Base ¬ NIL; ctxb: Symbols.Base ¬ NIL; UpdateBases: Alloc.Notifier = { seb ¬ base[seType]; ctxb ¬ base[ctxType]; slb ¬ base[atType]; seb ¬ base[seType]; }; <> Matched: SIGNAL[m1, m2: Type] RETURNS [BOOL] = CODE; NameEqual: PROC [key, entry: Type] RETURNS [BOOL] = { RETURN [(key = entry) OR Isomorphic[key, entry ! Matched => {RESUME [FALSE]}]]; }; Isomorphic: PROC [key, entry: Type] RETURNS [BOOL] = { DO IF key = entry THEN RETURN [TRUE]; WITH type1: seb[key] SELECT FROM id => RETURN [SymbolOps.ClusterSe[SymbolOps.own, key] = SymbolOps.ClusterSe[SymbolOps.own, entry]]; cons => WITH type2: seb[entry] SELECT FROM cons => WITH t1: type1 SELECT FROM record => WITH t2: type2 SELECT FROM record => { IF t1.fieldCtx = t2.fieldCtx THEN RETURN [TRUE]; IF t1.painted OR t2.painted THEN RETURN [FALSE]; IF SIGNAL Matched[key, entry] THEN RETURN [TRUE]; RETURN [IsoFields[t1.fieldCtx, t2.fieldCtx ! Matched => IF m1=key AND m2=entry THEN RESUME [TRUE]]]; }; ENDCASE; ref => WITH t2: type2 SELECT FROM ref => IF (t1.counted = t2.counted) AND (t1.ordered = t2.ordered) AND (t1.readOnly = t2.readOnly) AND (t1.length = t2.length) THEN { key ¬ t1.refType; entry ¬ t2.refType; LOOP; }; ENDCASE; any => WITH t2: type2 SELECT FROM any => RETURN [TRUE]; ENDCASE; ENDCASE => RETURN [key = entry]; ENDCASE; ENDCASE; RETURN [FALSE]; ENDLOOP; }; IsoFields: PROC [ctx1, ctx2: CTXIndex] RETURNS [BOOL] = { sei1: ISEIndex ¬ SymbolOps.FirstCtxSe[SymbolOps.own, ctx1]; sei2: ISEIndex ¬ SymbolOps.FirstCtxSe[SymbolOps.own, ctx2]; UNTIL sei1 = sei2 DO IF seb[sei1].hash # seb[sei2].hash OR ~Isomorphic[seb[sei1].idType, seb[sei2].idType] THEN RETURN [FALSE]; sei1 ¬ SymbolOps.NextSe[SymbolOps.own, sei1]; sei2 ¬ SymbolOps.NextSe[SymbolOps.own, sei2]; ENDLOOP; RETURN [sei1 = sei2]; }; Equivalent: PROC [key, entry: Type] RETURNS [BOOL] = { RETURN [(key = entry) OR ( Types.Equivalent[ [MimData.ownSymbols, SymbolOps.UnderType[SymbolOps.own, key]], [MimData.ownSymbols, SymbolOps.UnderType[SymbolOps.own, entry]]] AND ~Fuzzy[key, entry])] }; Fuzzy: PROC [sei1, sei2: Type] RETURNS [BOOL] = INLINE { RETURN [SymbolOps.TypeForm[SymbolOps.own, sei1] = array AND (~seb[sei1].mark4 OR ~seb[sei2].mark4)]; }; <> UTypeId: PUBLIC PROC [type: Type] RETURNS [mdi: MDIndex, index: Type] = { sei: Type = SymbolOps.ClusterSe[SymbolOps.own, type]; WITH se: seb[sei] SELECT FROM id => { ctx: CTXIndex = se.idCtx; WITH c: ctxb[ctx] SELECT FROM included => IF SymbolOps.CtxLevel[SymbolOps.own, ctx] = lZ THEN {index ¬ sei; mdi ¬ OwnMdi} ELSE {index ¬ SymbolOps.DecodeType[se.idValue]; mdi ¬ c.module}; ENDCASE => { index ¬ sei; mdi ¬ IF Predeclared[sei] THEN MDNull ELSE OwnMdi; }; }; cons => { index ¬ sei; mdi ¬ WITH t: se SELECT FROM basic => MDNull, enumerated => IF t.valueCtx IN [FirstStandardCtx .. LastStandardCtx] THEN MDNull ELSE OwnMdi, record => IF t.fieldCtx IN [FirstStandardCtx .. LastStandardCtx] THEN MDNull ELSE OwnMdi, opaque => IF Predeclared[t.id] THEN MDNull ELSE OwnMdi, ENDCASE => OwnMdi; }; ENDCASE; }; Predeclared: PROC [type: Type] RETURNS [BOOL] = INLINE { RETURN [type = nullType OR ( WITH se: seb[type] SELECT FROM id => se.idCtx IN (CTXNull .. LastStandardCtx], ENDCASE => FALSE)] }; <> nTypes: CARDINAL ¬ 0; nTypeRefs: CARDINAL ¬ 0; typeMapId: ISEIndex ¬ ISENull; EnterType: PUBLIC PROC [type: Type, canonical: BOOL, used: BOOL] = { sei: Type = SymbolOps.ClusterSe[SymbolOps.own, type]; slLimit: SymLitIndex = table.Top[SymbolSegment.atType]; nTypeRefs ¬ nTypeRefs + 1; IF alwaysCanonical THEN canonical ¬ TRUE; FOR sli: SymLitIndex ¬ SymLitFirst, sli+SymLitRecord.SIZE UNTIL sli = slLimit DO WITH s: slb[sli] SELECT FROM type => IF canonical = s.canonical AND (IF canonical THEN Equivalent ELSE NameEqual)[sei, s.typeCode] THEN { IF used THEN s.used ¬ TRUE; EXIT; }; ENDCASE; REPEAT FINISHED => InsertType[sei, canonical, used]; ENDLOOP }; TypeIndex: PUBLIC PROC [type: Type, canonical: BOOL, used: BOOL] RETURNS [RTMob.TypeIndex] = { sei: Type = SymbolOps.ClusterSe[SymbolOps.own, type]; i: CARDINAL ¬ 0; IF alwaysCanonical THEN canonical ¬ TRUE; FOR sli: SymLitIndex ¬ SymLitIndex.FIRST, sli+SymLitRecord.SIZE WHILE i < nTypes DO WITH s: slb[sli] SELECT FROM type => { tc: Type ¬ s.typeCode; IF tc = type THEN GO TO found; SELECT canonical FROM TRUE => <> IF Equivalent[sei, tc] THEN GO TO found; ENDCASE => <> IF NameEqual[sei, tc] THEN GO TO found; EXITS found => { IF used THEN s.used ¬ TRUE; RETURN [[i]]; }; }; ENDCASE; i ¬ i+1; ENDLOOP; ERROR; }; alwaysCanonical: BOOL ¬ TRUE; <> TypeRef: PUBLIC PROC [type: Type, canonical: BOOL] RETURNS [Tree.Link] = { sei: Type = SymbolOps.ClusterSe[SymbolOps.own, type]; i: CARDINAL ¬ 0; IF alwaysCanonical THEN canonical ¬ TRUE; RETURN [IndexedRef[typeMapId, TypeIndex[type, canonical, TRUE], typeANY]]; }; DescribeTypes: PUBLIC PROC RETURNS [offset, length: CARD] = { RETURN [offset: BitOffset[typeMapId], length: nTypes]; }; EnumerateTypes: PUBLIC PROC [scan: SymLiteralOps.TypesVisitor] = { i: CARDINAL ¬ 0; FOR sli: SymLitIndex ¬ SymLitFirst, sli+SymLitRecord.SIZE WHILE i < nTypes DO WITH s: slb[sli] SELECT FROM type => IF s.typeCode # Symbols.nullType THEN scan[s.typeCode, s.canonical, s.used]; ENDCASE; i ¬ i + 1; ENDLOOP }; InsertType: PROC [type: Type, canonical: BOOL, used: BOOL] = { sli: SymLitIndex = table.Units[atType, SymLitRecord.SIZE]; slb[sli] ¬ [used, type[canonical: canonical, typeCode: type]]; nTypes ¬ nTypes + 1; }; <> nLits: CARDINAL ¬ 0; nLitRefs: CARDINAL ¬ 0; firstLit: SymLitIndex ¬ SymLitFirst; -- tight bound after Reset litMapId: ISEIndex ¬ ISENull; EnterLit: PROC [type: Type, item: RefLitItem] = { slLimit: SymLitIndex = table.Top[SymbolSegment.atType]; nLitRefs ¬ nLitRefs + 1; EnterType[type, alwaysCanonical, TRUE]; FOR sli: SymLitIndex ¬ SymLitFirst, sli+SymLitRecord.SIZE UNTIL sli = slLimit DO WITH s: slb[sli] SELECT FROM lit => IF s.info = item THEN EXIT; ENDCASE; REPEAT FINISHED => InsertLit[item, type]; ENDLOOP }; LitIndex: PROC [item: RefLitItem, used: BOOL ¬ FALSE] RETURNS [RTMob.RefLitIndex] = { i: CARDINAL ¬ 0; FOR sli: SymLitIndex ¬ firstLit, sli+SymLitRecord.SIZE WHILE i < nLits DO WITH s: slb[sli] SELECT FROM lit => IF s.info = item THEN { IF used THEN s.used ¬ TRUE; RETURN [[i]]; }; ENDCASE; i ¬ i+1; ENDLOOP; ERROR; }; InsertLit: PROC [item: RefLitItem, type: Type] = { sli: SymLitIndex = table.Units[atType, SymLitRecord.SIZE]; slb[sli] ¬ [FALSE, lit[type, item]]; nLits ¬ nLits + 1; }; EnterAtom: PUBLIC PROC [name: Name] = { EnterLit[MimData.idATOM, [atom[pName: name]]]; }; AtomIndex: PUBLIC PROC [name: Name] RETURNS [RTMob.RefLitIndex] = { RETURN [LitIndex[[atom[pName: name]], FALSE]]; }; AtomRef: PUBLIC PROC [name: Name] RETURNS [Tree.Link] = { RETURN [IndexedRef[litMapId, LitIndex[[atom[pName: name]], TRUE], MimData.idATOM]]; }; EnterText: PUBLIC PROC [sti: Literals.STIndex, type: Type] = { EnterLit[type, [text[value: sti]]]; }; TextIndex: PUBLIC PROC [sti: Literals.STIndex] RETURNS [RTMob.RefLitIndex] = { RETURN [LitIndex[[text[value: sti]]]]; }; TextRef: PUBLIC PROC [sti: Literals.STIndex] RETURNS [Tree.Link] = { RETURN [IndexedRef[litMapId, LitIndex[[text[value: sti]], TRUE], MimData.typeRefANY]]; }; DescribeRefLits: PUBLIC PROC RETURNS [offset, length: CARD] = { temp: INT ¬ BitOffset[litMapId]; RETURN [offset: LOOPHOLE[temp, CARD], length: nLits]; }; EnumerateRefLits: PUBLIC PROC [scan: SymLiteralOps.RefLitsVisitor] = { i: CARDINAL ¬ 0; FOR sli: SymLitIndex ¬ firstLit, sli+SymLitRecord.SIZE WHILE i < nLits DO WITH s: slb[sli] SELECT FROM lit => {scan[s.info, s.type, s.used]; i ¬ i+1}; ENDCASE; ENDLOOP }; <> Initialize: PUBLIC PROC [ownTable: Alloc.Handle] = { table ¬ ownTable; table.AddNotify[UpdateBases]; nLits ¬ nLitRefs ¬ 0; nTypes ¬ nTypeRefs ¬ 0; firstLit ¬ SymLitFirst; -- see Reset typeMapId ¬ litMapId ¬ ISENull; }; Reset: PUBLIC PROC [pad: BOOL] = { IF nTypes # 0 THEN { slLimit: SymLitIndex = table.Top[atType]; lastType: SymLitIndex ¬ slLimit - SymLitRecord.SIZE; DO UNTIL firstLit = slLimit OR slb[firstLit].tag = lit DO firstLit ¬ firstLit + SymLitRecord.SIZE; ENDLOOP; UNTIL slb[lastType].tag = type DO lastType ¬ lastType - SymLitRecord.SIZE; ENDLOOP; IF lastType < firstLit THEN EXIT; { t: SymLitRecord ¬ slb[firstLit]; slb[firstLit] ¬ slb[lastType]; slb[lastType] ¬ t; }; ENDLOOP; IF ~MimData.interface THEN typeMapId ¬ CreateMap["&types"L, typeANY, nTypes, nTypeRefs]; }; IF nLits # 0 THEN IF NOT MimData.interface THEN litMapId ¬ CreateMap["&refs"L, MimData.typeRefANY, nLits, nLitRefs]; }; Finalize: PUBLIC PROC = {table.DropNotify[UpdateBases]; table ¬ NIL}; <> CreateMap: PROC [id: LONG STRING, cType: Type, nEntries, nRefs: CARDINAL] RETURNS [sei: ISEIndex] = { desc: ConvertUnsafe.SubString ¬ [base:id, offset:0, length:id.length]; mapType: CSEIndex ¬ CreateUnnamedMap[cType, nEntries]; sei ¬ SymbolOps.MakeCtxSe[SymbolOps.EnterString[desc], MimData.mainCtx]; seb[sei].idType ¬ mapType; seb[sei].public ¬ seb[sei].extended ¬ seb[sei].constant ¬ seb[sei].linkSpace ¬ FALSE; seb[sei].immutable ¬ TRUE; seb[sei].idValue ¬ SymbolOps.EncodeTreeIndex[Tree.nullIndex]; seb[sei].idInfo ¬ SymbolOps.EncodeCard[nRefs]; seb[sei].mark3 ¬ seb[sei].mark4 ¬ TRUE; }; CreateUnnamedMap: PROC [cType: Type, nEntries: CARDINAL] RETURNS [mapType: CSEIndex] = { iType: CSEIndex ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.subrange.SIZE]; seb[iType].typeInfo ¬ subrange[ filled: TRUE, empty: FALSE, biased: TRUE, rangeType: MimData.idINT, origin: 0, range: nEntries-1]; seb[iType].mark3 ¬ seb[iType].mark4 ¬ TRUE; mapType ¬ SymbolOps.MakeNonCtxSe[SERecord.cons.array.SIZE]; seb[mapType].typeInfo ¬ array[ packed: FALSE, bitOrder: IF Target.bitOrder = msBit THEN msBit ELSE lsBit, indexType: iType, componentType: cType]; seb[mapType].mark3 ¬ seb[mapType].mark4 ¬ TRUE; }; BitOffset: PROC [sei: ISEIndex] RETURNS [offset: CARD ¬ 0] = INLINE { IF sei # ISENull THEN { addr: BitAddress = SymbolOps.DecodeBitAddr[seb[sei].idValue]; offset ¬ addr; }; }; IndexedRef: PROC [array: ISEIndex, item: CARDINAL, type: Type] RETURNS [Tree.Link] = { TreeOps.PushSe[array]; TreeOps.PushLit[LiteralOps.FindCard[item]]; TreeOps.PushNode[index, 2]; TreeOps.SetAttr[2, FALSE]; TreeOps.SetInfo[SymbolOps.FromType[type]]; RETURN [TreeOps.PopTree[]]; }; }.