-- file SymbolPack.Mesa
-- last modified by Satterthwaite,  9-Feb-82  9:56:48

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 HTIndex 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 [hti: HTIndex] = {
    desc: Strings.SubStringDescriptor;
    ss: SubString = @desc;
    hti _ hashVec[HashValue[s]];
    WHILE hti # HTNull DO
      SubStringForHash[ss, hti];
      IF Strings.EqualSubStrings[s,ss] THEN EXIT;
      hti _ ht[hti].link;
      ENDLOOP;
    RETURN};

  HashValue: PROC [s: SubString] RETURNS [HVIndex] = {
    CharBits: PROC [CHARACTER, 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;
    v _ CharBits[b[s.offset], Mask]*177b + CharBits[b[s.offset+(n-1)], Mask];
    RETURN [Inline.BITXOR[v, n*17b] MOD LENGTH[hashVec^]]};

  SubStringForHash: PROC [s: SubString, hti: HTIndex] = {
    s.base _ ssb;
    IF hti = HTNull
      THEN s.offset _ s.length _ 0
      ELSE s.length _ ht[hti].ssIndex - (s.offset _ ht[hti-1].ssIndex)};


 -- context management

  CtxEntries: PROC [ctx: CTXIndex] RETURNS [n: CARDINAL] = {
    n _ 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 = SENull 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 = SENull
	THEN ISENull
	ELSE
	  WITH id: seb[sei] SELECT FROM
	    terminal => ISENull,
	    sequential => sei + SIZE[sequential id SERecord],
	    linked => id.link,
	    ENDCASE => ISENull]};

  SearchContext: PROC [hti: HTIndex, ctx: CTXIndex] RETURNS [ISEIndex] = {
    sei, root: ISEIndex;
    IF ctx # CTXNull AND hti # HTNull
      THEN {
	sei _ root _ ctxb[ctx].seList;
	DO
	  IF sei = SENull THEN EXIT;
	  IF seb[sei].hash = hti THEN RETURN [sei];
	  WITH id: seb[sei] SELECT FROM
	    sequential => sei _ sei + SIZE[sequential id SERecord];
	    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 _ FIRST[MDIndex], mdi + SIZE[MDRecord] 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 = SENull
      THEN RecordSENull
      ELSE WITH seb[type] SELECT FROM
        record => LOOPHOLE[type, RecordSEIndex],
	ENDCASE => RecordSENull]};
	
  ClusterSe: PROC [type: SEIndex] RETURNS [SEIndex] = {
    WITH t: seb[type] SELECT FROM
      id => {
        next: SEIndex = 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]) # SENull DO root _ next ENDLOOP;
    RETURN};

  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: SEIndex] 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: SEIndex] RETURNS [TypeClass] = {
    RETURN [IF type = SENull THEN nil ELSE seb[UnderType[type]].typeTag]};

  TypeLink: PROC [type: SEIndex] RETURNS [SEIndex] = {
    sei: CSEIndex = UnderType[type];
    RETURN [WITH se: seb[sei] SELECT FROM
      record => WITH se SELECT FROM linked => linkType, ENDCASE => SENull,
      ENDCASE => SENull]};

  TypeRoot: PROC [type: SEIndex] RETURNS [root: SEIndex] = {
    next: SEIndex;
    root _ type;
    WHILE (next _ TypeLink[root]) # SENull DO root _ next ENDLOOP;
    RETURN};

  UnderType: PROC [type: SEIndex] RETURNS [CSEIndex] = {
    sei: SEIndex _ type;
    WHILE sei # SENull 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: SEIndex] RETURNS [TransferMode] = {
    sei: CSEIndex = UnderType[type];
    RETURN [WITH t: seb[sei] SELECT FROM transfer => t.mode, ENDCASE => none]};


 -- information returning procedures

  WordFill: CARDINAL = WordLength-1;
  BytesPerWord: CARDINAL = WordLength/ByteLength;

  BitsForType: PROC [type: SEIndex] RETURNS [CARDINAL] = {
    n: CARDINAL;
    sei: CSEIndex = UnderType[type];
    RETURN [IF sei = SENull
      THEN 0
      ELSE
	WITH t: seb[sei] SELECT FROM
	  basic => t.length,
	  enumerated => BitsForRange[Cardinality[sei]-1],
	  record => t.length,
	  array =>
	    IF (n_BitsPerElement[t.componentType, t.packed]*Cardinality[t.indexType]) >
	     WordLength
	      THEN ((n + (WordLength-1))/WordLength)*WordLength
	      ELSE n,
	  opaque => t.length,
	  subrange => IF t.empty THEN 0 ELSE BitsForRange[Cardinality[sei]-1],
	  ENDCASE => WordsForType[sei]*WordLength]};

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

  BitsPerElement: PROC [type: SEIndex, packed: BOOLEAN] RETURNS [CARDINAL] = {
    nBits: CARDINAL = BitsForType[type];
    RETURN [IF packed AND nBits <= ByteLength
      THEN SymbolOps.PackedSize[nBits]
      ELSE (nBits+WordFill)/WordLength * WordLength]};

  Cardinality: PROC [type: SEIndex] RETURNS [CARDINAL] = {
    sei: CSEIndex = UnderType[type];
    RETURN [WITH t: seb[sei] SELECT FROM
      enumerated => t.nValues,
      subrange => IF t.empty THEN 0 ELSE t.range+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 _ FIRST[ExtIndex], exti + SIZE[ExtRecord] 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: CARDINAL] = {
    word, nW: CARDINAL;
    word _ 0;
    FOR sei: ISEIndex _ FirstCtxSe[seb[field].idCtx], NextSe[sei] DO
      nW _ WordsForType[seb[sei].idType];
      IF sei = field THEN EXIT;
      word _ word + nW;
      ENDLOOP;
    RETURN [offset: BitAddress[wd:word, bd:0], size: nW * WordLength]};

  HashForSe: PROC [sei: ISEIndex] RETURNS [HTIndex] = {
    RETURN [IF sei = ISENull THEN HTNull 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]};

  RCType: PROC [type: CSEIndex] RETURNS [RefClass] = {
    next: SEIndex;
    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;
    RETURN};

  WordsForType: PROC [type: SEIndex] RETURNS [CARDINAL] = {
    sei: CSEIndex = UnderType[type];
    b: CARDINAL;
    RETURN [IF sei = SENull
      THEN 0
      ELSE
	WITH t: seb[sei] SELECT FROM
	  mode => 1,	-- fudge for compiler (Pass4:Binding)
	  basic => (t.length + WordFill)/WordLength,
	  enumerated => 1,
	  record => (t.length + WordFill)/WordLength,
	  ref => 1,
	  array =>
	    IF (b_BitsPerElement[t.componentType, t.packed]) < WordLength
	      THEN (Cardinality[t.indexType]+(WordLength/b-1))/(WordLength/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 + 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: BOOLEAN]]
      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};

  }.