-- file SymbolPack.mesa
-- last modified by Satterthwaite, February 24, 1983 1:55 pm

DIRECTORY
  Inline: TYPE USING [BITAND, BITXOR],
  Literals: TYPE USING [Base],
  Strings: TYPE USING [String, SubString, SubStringDescriptor, EqualSubStrings],
  Symbols: TYPE,
  SymbolOps: TYPE USING [PackedSize],
  SymbolSegment: TYPE USING [Base, ExtIndex, ExtRecord, FGTEntry, STHeader],
  TimeStamp: TYPE USING [Stamp],
  Tree: TYPE USING [Base, Link, Null];

SymbolPack: PROGRAM
    IMPORTS Inline, Strings
    EXPORTS SymbolOps =
 PUBLIC {
  OPEN Symbols;

  SymbolTableBase: TYPE = POINTER TO FRAME[SymbolPack];

  link: SymbolTableBase;
  cacheInfo: LONG POINTER;

  -- tables defining the current symbol table
    hashVec: LONG POINTER TO HashVector;		-- hash index
    ht: LONG DESCRIPTOR FOR ARRAY Name OF HTRecord;	-- hash table
    ssb: Strings.String;		-- 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;

  -- info defining the source file links
    sourceFile: Strings.String;
    fgTable: LONG DESCRIPTOR FOR ARRAY OF SymbolSegment.FGTEntry;

 -- the following procedure is called if the base values change
  notifier: PROC [SymbolTableBase];

  NullNotifier: PROC [SymbolTableBase] = { };


 -- hash manipulation

  SubString: TYPE = Strings.SubString;

  FindString: PROC [s: SubString] RETURNS [name: Name] = {
    desc: Strings.SubStringDescriptor;
    ss: SubString = @desc;
    name _ hashVec[HashValue[s]];
    WHILE name # nullName DO
      SubStringForName[ss, name];
      IF Strings.EqualSubStrings[s,ss] THEN EXIT;
      name _ ht[name].link;
      ENDLOOP;
    RETURN};

  HashValue: PROC [s: SubString] RETURNS [HVIndex] = {
    CharBits: PROC [CHAR, WORD] RETURNS [WORD] = LOOPHOLE[Inline.BITAND];
    Mask: WORD = 337b;		-- masks out ASCII case shifts
    n: CARDINAL = s.length;
    b: Strings.String = s.base;
    v: WORD = CharBits[b[s.offset], Mask]*177b + CharBits[b[s.offset+(n-1)], Mask];
    RETURN [Inline.BITXOR[v, n*17b] MOD hashVec^.LENGTH]};

  SubStringForName: PROC [s: SubString, name: Name] = {
    s.base _ ssb;
    IF name = nullName THEN s.offset _ s.length _ 0
    ELSE s.length _ ht[name].ssIndex - (s.offset _ ht[name-1].ssIndex)};


 -- context management

  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;
    RETURN};

  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]};

 -- module management

  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]};


 -- type manipulation

  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: Type] RETURNS [CSEIndex] = {
    csei: CSEIndex = UnderType[type];
    RETURN [WITH t: seb[csei] SELECT FROM
      subrange => NormalType[t.rangeType],
      long, real => NormalType[t.rangeType],
      ENDCASE => csei]};

  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;
    RETURN};

  ReferentType: PROC [type: Type] RETURNS [Type] = {
    csei: CSEIndex = NormalType[type];
    RETURN [WITH t: seb[csei] SELECT FROM
      ref => t.refType,
      ENDCASE => typeANY]};

  TransferTypes: PROC [type: Type] RETURNS [typeIn, typeOut: RecordSEIndex] = {
    csei: CSEIndex = UnderType[type];
    WITH t: seb[csei] 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] = {
    csei: CSEIndex = UnderType[type];
    RETURN [WITH se: seb[csei] 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;
    RETURN};

  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] = {
    csei: CSEIndex = UnderType[type];
    RETURN [WITH t: seb[csei] SELECT FROM transfer => t.mode, ENDCASE => $none]};


 -- information returning procedures

  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;
    RETURN};

  BitsForType: PROC [type: Type] RETURNS [BitCount] = {
    n: BitCount;
    csei: CSEIndex = UnderType[type];
    RETURN [IF csei = CSENull
      THEN 0
      ELSE
	WITH t: seb[csei] SELECT FROM
	  basic => t.length,
	  enumerated => IF t.empty THEN 0 ELSE BitsForRange[Cardinality[csei]-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[csei]-1],
	  ENDCASE => WordsForType[csei]*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] = {
    csei: CSEIndex = UnderType[type];
    RETURN [WITH t: seb[csei] 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: Type] RETURNS [RefClass] = {
    sei: Type _ type;
    struc: RefClass _ $simple;
    DO
      csei: CSEIndex = UnderType[sei];
      WITH t: seb[csei] SELECT FROM
	record =>
	  SELECT TRUE FROM
	    ~t.hints.refField => RETURN [$none];
	    t.hints.unifield => sei _ seb[ctxb[t.fieldCtx].seList].idType;
	    ENDCASE => RETURN [$composite];
	ref => RETURN [IF t.counted THEN struc ELSE $none];
	array => {struc _ $composite; sei _ t.componentType};
	relative => sei _ t.offsetType;
	subrange => sei _ t.rangeType;
	long => sei _ t.rangeType;
	union => RETURN [IF t.hints.refField THEN $composite ELSE $none];
	sequence => {struc _ $composite; sei _ t.componentType};
	zone => RETURN [IF t.counted THEN struc ELSE $none];
	ENDCASE => RETURN [$none];
      ENDLOOP};

  VariantField: PROC [type: Type] RETURNS [sei: ISEIndex] = {
    csei: CSEIndex = UnderType[type];
    WITH t: seb[csei] 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;
    RETURN};

  WordsForType: PROC [type: Type] RETURNS [WordCount] = {
    csei: CSEIndex = UnderType[type];
    b: BitCount;
    itemsPerWord: ARRAY PackedBitCount OF [0..16] = [16, 8, 4, 4, 2, 2, 2, 2];
    RETURN [IF csei = CSENull
      THEN 0
      ELSE
	WITH t: seb[csei] 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
	        -- b IN PackedBitCount
	      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]};


 -- body table management

  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;
    RETURN};

  }.