<> <> <> <> DIRECTORY ConvertUnsafe USING [LS, SubString, EqualSubStrings], PrincOpsUtils USING [BITAND, BITXOR], Literals USING [Base], Symbols, SymbolOps USING [PackedSize], SymbolSegment USING [Base, ExtIndex, ExtRecord, FGTEntry, STHeader], TimeStamp USING [Stamp], Tree USING [Base, Link, Null]; SymbolPack: PROGRAM IMPORTS PrincOpsUtils, ConvertUnsafe EXPORTS SymbolOps = PUBLIC {OPEN Symbols; SymbolTableBase: TYPE = POINTER TO FRAME[SymbolPack]; link: SymbolTableBase; cacheInfo: LONG POINTER; <<>> <> hashVec: LONG POINTER TO HashVector; -- hash index ht: LONG DESCRIPTOR FOR ARRAY Name OF HTRecord; -- hash table ssb: ConvertUnsafe.LS; -- id string seb: Symbols.Base; -- se table ctxb: Symbols.Base; -- context table mdb: Symbols.Base; -- module directory base bb: Symbols.Base; -- body table tb: Tree.Base; -- tree area ltb: Literals.Base; -- literal area extb: SymbolSegment.Base; -- extension map mdLimit: MDIndex; -- module directory size extLimit: SymbolSegment.ExtIndex; -- extension size mainCtx: CTXIndex; stHandle: LONG POINTER TO SymbolSegment.STHeader; <<>> <> sourceFile: ConvertUnsafe.LS; fgTable: LONG DESCRIPTOR FOR ARRAY OF SymbolSegment.FGTEntry; <<>> <> notifier: PROC [SymbolTableBase]; NullNotifier: PROC [SymbolTableBase] = { }; <<>> <> SubString: TYPE = ConvertUnsafe.SubString; FindString: PROC [s: SubString] RETURNS [name: Name] = { ss: SubString; name _ hashVec[HashValue[s]]; WHILE name # nullName DO ss _ SubStringForName[name]; IF ConvertUnsafe.EqualSubStrings[s, ss] THEN EXIT; name _ ht[name].link; ENDLOOP; }; HashValue: PROC [s: SubString] RETURNS [HVIndex] = { CharBits: PROC [CHAR, WORD] RETURNS [WORD] = LOOPHOLE[PrincOpsUtils.BITAND]; Mask: WORD = 337b; -- masks out ASCII case shifts v: WORD = CharBits[s.base[s.offset], Mask]*177b + CharBits[s.base[s.offset+(s.length-1)], Mask]; RETURN [PrincOpsUtils.BITXOR[v, s.length*17b] MOD hashVec^.LENGTH]; }; SubStringForName: PROC [name: Name] RETURNS[s: ConvertUnsafe.SubString] = { s.base _ ssb; IF name = nullName THEN s.offset _ s.length _ 0 ELSE s.length _ ht[name].ssIndex - (s.offset _ ht[name-1].ssIndex); }; <<>> <> CtxEntries: PROC [ctx: CTXIndex] RETURNS [n: CARDINAL_0] = { IF ctx = CTXNull THEN RETURN; WITH c: ctxb[ctx] SELECT FROM included => IF ~c.reset THEN RETURN; ENDCASE; FOR sei: ISEIndex _ FirstCtxSe[ctx], NextSe[sei] UNTIL sei = ISENull DO n _ n+1 ENDLOOP; }; FirstCtxSe: PROC [ctx: CTXIndex] RETURNS [ISEIndex] = { RETURN [IF ctx = CTXNull THEN ISENull ELSE ctxb[ctx].seList]}; NextSe: PROC [sei: ISEIndex] RETURNS [ISEIndex] = { RETURN [ IF sei = ISENull THEN ISENull ELSE WITH id: seb[sei] SELECT FROM terminal => ISENull, sequential => sei + SERecord.id.sequential.SIZE, linked => id.link, ENDCASE => ISENull]; }; SearchContext: PROC [name: Name, ctx: CTXIndex] RETURNS [ISEIndex] = { sei, root: ISEIndex; IF ctx # CTXNull AND name # nullName THEN { sei _ root _ ctxb[ctx].seList; DO IF sei = ISENull THEN EXIT; IF seb[sei].hash = name THEN RETURN [sei]; WITH id: seb[sei] SELECT FROM sequential => sei _ sei + SERecord.id.sequential.SIZE; linked => IF (sei _ id.link) = root THEN EXIT; ENDCASE => EXIT; ENDLOOP; }; RETURN [ISENull]; }; SeiForValue: PROC [value: CARDINAL, ctx: CTXIndex] RETURNS [ISEIndex] = { FOR sei: ISEIndex _ FirstCtxSe[ctx], NextSe[sei] UNTIL sei = ISENull DO IF seb[sei].idValue = value THEN RETURN [sei] ENDLOOP; RETURN [ISENull]; }; <<>> <> FindMdi: PROC [stamp: TimeStamp.Stamp] RETURNS [MDIndex] = { FOR mdi: MDIndex _ MDIndex.FIRST, mdi + MDRecord.SIZE UNTIL mdi = mdLimit DO IF mdb[mdi].stamp = stamp THEN RETURN [mdi] ENDLOOP; RETURN [MDNull]; }; <<>> <> ArgCtx: PROC [type: CSEIndex] RETURNS [CTXIndex] = { sei: RecordSEIndex = ArgRecord[type]; RETURN [IF sei = RecordSENull THEN CTXNull ELSE seb[sei].fieldCtx]; }; ArgRecord: PROC [type: CSEIndex] RETURNS [RecordSEIndex] = { RETURN [ IF type = nullType THEN RecordSENull ELSE WITH seb[type] SELECT FROM record => LOOPHOLE[type, RecordSEIndex], ENDCASE => RecordSENull]; }; ClusterSe: PROC [type: Type] RETURNS [Type] = { WITH t: seb[type] SELECT FROM id => { next: Type = t.idInfo; RETURN [ IF t.extended THEN type ELSE WITH u: seb[next] SELECT FROM id => IF t.hash = u.hash THEN ClusterSe[next] ELSE type, ENDCASE => type ]; }; ENDCASE => RETURN [type]; }; NormalType: PROC [type: CSEIndex] RETURNS [nType: CSEIndex] = { RETURN [ WITH t: seb[type] SELECT FROM subrange => NormalType[UnderType[t.rangeType]], long, real => NormalType[UnderType[t.rangeType]], ENDCASE => type ]; }; RecordLink: PROC [type: RecordSEIndex] RETURNS [RecordSEIndex] = { RETURN [ WITH t: seb[type] SELECT FROM linked => LOOPHOLE[UnderType[t.linkType], RecordSEIndex], ENDCASE => RecordSENull ]}; RecordRoot: PROC [type: RecordSEIndex] RETURNS [root: RecordSEIndex] = { next: RecordSEIndex; root _ type; WHILE (next _ RecordLink[root]) # RecordSENull DO root _ next ENDLOOP; }; ReferentType: PROC [type: CSEIndex] RETURNS [CSEIndex] = { sei: CSEIndex = NormalType[type]; RETURN [ WITH t: seb[sei] SELECT FROM ref => UnderType[t.refType], ENDCASE => typeANY ]}; TransferTypes: PROC [type: Type] RETURNS [typeIn, typeOut: RecordSEIndex] = { sei: CSEIndex = UnderType[type]; WITH t: seb[sei] SELECT FROM transfer => RETURN [typeIn: ArgRecord[t.typeIn], typeOut: ArgRecord[t.typeOut]]; ENDCASE; RETURN [RecordSENull, RecordSENull]; }; TypeForm: PROC [type: Type] RETURNS [TypeClass] = { RETURN [IF type = nullType THEN $nil ELSE seb[UnderType[type]].typeTag]; }; TypeLink: PROC [type: Type] RETURNS [Type] = { sei: CSEIndex = UnderType[type]; RETURN [ WITH se: seb[sei] SELECT FROM record => WITH se SELECT FROM linked => linkType, ENDCASE => nullType, ENDCASE => nullType ]; }; TypeRoot: PROC [type: Type] RETURNS [root: Type] = { next: Type; root _ type; WHILE (next _ TypeLink[root]) # nullType DO root _ next ENDLOOP; }; UnderType: PROC [type: Type] RETURNS [CSEIndex] = { sei: Type _ type; WHILE sei # nullType DO WITH se: seb[sei] SELECT FROM id => {IF se.idType # typeTYPE THEN ERROR; sei _ se.idInfo}; ENDCASE => EXIT; ENDLOOP; RETURN [LOOPHOLE[sei, CSEIndex]]; }; XferMode: PROC [type: Type] RETURNS [TransferMode] = { sei: CSEIndex = UnderType[type]; RETURN [WITH t: seb[sei] SELECT FROM transfer => t.mode, ENDCASE => $none]; }; <<>> <> wordFill: CARDINAL = WordLength-1; Untruncate: PRIVATE PROC [n: CARDINAL] RETURNS [LONG CARDINAL] = { RETURN [IF n=0 THEN CARDINAL.LAST.LONG+1 ELSE n]}; BitsForRange: PROC [maxValue: CARDINAL] RETURNS [nBits: CARDINAL] = { fieldMax: CARDINAL; nBits _ 1; fieldMax _ 1; WHILE nBits < WordLength AND fieldMax < maxValue DO nBits _ nBits + 1; fieldMax _ 2*fieldMax + 1 ENDLOOP; }; BitsForType: PROC [type: Type] RETURNS [BitCount] = { n: BitCount; sei: CSEIndex = UnderType[type]; RETURN [ IF sei = CSENull THEN 0 ELSE WITH t: seb[sei] SELECT FROM basic => t.length, enumerated => IF t.empty THEN 0 ELSE BitsForRange[Cardinality[sei]-1], record => t.length, array => IF (n_BitsPerElement[t.componentType, t.packed]*Cardinality[t.indexType]) > WordLength THEN ((n + wordFill)/WordLength)*WordLength ELSE n, opaque => t.length, relative => BitsForType[t.offsetType], subrange => IF t.empty THEN 0 ELSE BitsForRange[Cardinality[sei]-1], ENDCASE => WordsForType[sei]*WordLength]; }; BitsPerElement: PROC [type: Type, packed: BOOL] RETURNS [BitCount] = { nBits: BitCount = BitsForType[type]; RETURN [ IF packed AND (nBits#0 AND nBits<=PackedBitCount.LAST) -- IN PackedBitCount THEN SymbolOps.PackedSize[PackedBitCount[nBits]] ELSE (nBits+wordFill)/WordLength * WordLength ]; }; Cardinality: PROC [type: Type] RETURNS [LONG CARDINAL] = { sei: CSEIndex = UnderType[type]; RETURN [ WITH t: seb[sei] SELECT FROM enumerated => IF t.empty THEN 0 ELSE Untruncate[t.nValues], -- compatibility hack subrange => IF t.empty THEN 0 ELSE t.range.LONG+1, basic => IF t.code = codeCHAR THEN 256 ELSE 0, relative => Cardinality[t.offsetType], ENDCASE => 0]; }; FindExtension: PROC [sei: ISEIndex] RETURNS [type: ExtensionType, tree: Tree.Link] = { OPEN SymbolSegment; FOR exti: ExtIndex _ ExtIndex.FIRST, exti + ExtRecord.SIZE UNTIL exti = extLimit DO IF extb[exti].sei = sei THEN RETURN [extb[exti].type, extb[exti].tree]; ENDLOOP; RETURN [$none, Tree.Null]; }; FnField: PROC [field: ISEIndex] RETURNS [offset: BitAddress, size: FieldBitCount] = { word, nW: CARDINAL; word _ 0; FOR sei: ISEIndex _ FirstCtxSe[seb[field].idCtx], NextSe[sei] DO nW _ CARDINAL[WordsForType[seb[sei].idType]]; IF sei = field THEN EXIT; word _ word + nW; ENDLOOP; RETURN [offset: BitAddress[wd:word, bd:0], size: nW * WordLength]; }; NameForSe: PROC [sei: ISEIndex] RETURNS [Name] = { RETURN [IF sei = ISENull THEN nullName ELSE seb[sei].hash]}; LinkMode: PROC [sei: ISEIndex] RETURNS [Linkage] = { RETURN [ IF seb[sei].idType = typeTYPE THEN (IF TypeForm[seb[sei].idInfo] = $opaque THEN $type ELSE $manifest) ELSE SELECT XferMode[seb[sei].idType] FROM $proc, $program => IF seb[sei].constant THEN (IF seb[sei].extended THEN $val ELSE $manifest) ELSE $val, $signal, $error => IF seb[sei].constant THEN $manifest ELSE $val, ENDCASE => IF seb[sei].constant THEN $manifest ELSE $ref ]; }; RecField: PROC [field: ISEIndex] RETURNS [offset: BitAddress, size: FieldBitCount] = { RETURN [offset: seb[field].idValue, size: seb[field].idInfo]}; RCType: PROC [type: CSEIndex] RETURNS [RefClass] = { next: Type; struc: RefClass _ $simple; FOR sei: CSEIndex _ type, UnderType[next] DO WITH t: seb[sei] SELECT FROM record => SELECT TRUE FROM ~t.hints.refField => RETURN [$none]; t.hints.unifield => next _ seb[ctxb[t.fieldCtx].seList].idType; ENDCASE => RETURN [$composite]; ref => RETURN [IF t.counted THEN struc ELSE $none]; array => {struc _ $composite; next _ t.componentType}; relative => next _ t.offsetType; subrange => next _ t.rangeType; long => next _ t.rangeType; union => RETURN [IF t.hints.refField THEN $composite ELSE $none]; sequence => {struc _ $composite; next _ t.componentType}; zone => RETURN [IF t.counted THEN struc ELSE $none]; ENDCASE => RETURN [$none]; ENDLOOP; }; VariantField: PROC [type: CSEIndex] RETURNS [sei: ISEIndex] = { WITH t: seb[type] SELECT FROM record => FOR sei _ FirstCtxSe[t.fieldCtx], NextSe[sei] UNTIL sei = ISENull DO SELECT TypeForm[seb[sei].idType] FROM $sequence, $union => EXIT; ENDCASE; ENDLOOP; ENDCASE => sei _ ISENull; }; WordsForType: PROC [type: Type] RETURNS [WordCount] = { sei: CSEIndex = UnderType[type]; b: BitCount; itemsPerWord: ARRAY PackedBitCount OF [0..16] = [16, 8, 4, 4, 2, 2, 2, 2]; RETURN [ IF sei = CSENull THEN 0 ELSE WITH t: seb[sei] SELECT FROM mode => 1, -- fudge for compiler (Pass4.Binding) basic => (t.length + wordFill)/WordLength, enumerated => IF t.empty THEN 0 ELSE 1, record => (t.length.LONG + wordFill)/WordLength, ref => 1, array => IF (b_BitsPerElement[t.componentType, t.packed])#0 AND b<=PackedBitCount.LAST <> THEN (Cardinality[t.indexType] + (itemsPerWord[b]-1))/itemsPerWord[b] ELSE Cardinality[t.indexType] * ((b+wordFill)/WordLength), arraydesc => 2, transfer => IF t.mode = port THEN 2 ELSE 1, relative => WordsForType[t.offsetType], opaque => (t.length.LONG + wordFill)/WordLength, zone => (IF t.mds THEN 1 ELSE 2), subrange => IF t.empty THEN 0 ELSE 1, long => WordsForType[t.rangeType] + 1, real => 2, ENDCASE => 0 ]; }; <<>> <> ParentBti: PROC [bti: BTIndex] RETURNS [BTIndex] = { UNTIL bb[bti].link.which = $parent DO bti _ bb[bti].link.index ENDLOOP; RETURN [bb[bti].link.index]; }; SiblingBti: PROC [bti: BTIndex] RETURNS [BTIndex] = { RETURN [IF bb[bti].link.which = $sibling THEN bb[bti].link.index ELSE BTNull]}; SonBti: PROC [bti: BTIndex] RETURNS [BTIndex] = {RETURN [bb[bti].firstSon]}; EnumerateBodies: PROC [root: BTIndex, proc: PROC [BTIndex] RETURNS [stop: BOOL]] RETURNS [bti: BTIndex] = { prev: BTIndex; bti _ root; UNTIL bti = BTNull DO IF proc[bti] THEN GO TO Stopped; IF bb[bti].firstSon # BTNull THEN bti _ bb[bti].firstSon ELSE DO IF bti = root THEN GO TO Done; prev _ bti; bti _ bb[bti].link.index; IF bb[prev].link.which # $parent THEN EXIT; ENDLOOP; REPEAT Stopped => NULL; Done => bti _ BTNull; ENDLOOP; }; }.