-- file SymbolPackExt.mesa
-- last modified by Satterthwaite, February 17, 1983 4:14 pm

DIRECTORY
  Alloc: TYPE USING [
    Handle, Index, Notifier, AddNotify, Bounds, DropNotify, Top, Words],
  Strings: TYPE USING [
    String, SubString, SubStringDescriptor, AppendSubString, EqualSubStrings],
  Symbols: TYPE USING [
    Base, ExtensionType, HashVector, HVIndex, HTRecord, HTIndex, Name,
    SERecord, ISEIndex, CSEIndex,
    ContextLevel, CTXIndex, CTXRecord, MDIndex, BTIndex,
    nullName, HTNull, ISENull, CSENull, CTXNull, BTNull,
    ByteLength, lG, lL, lZ, typeANY, typeTYPE, WordLength,
    htType, ssType, seType, ctxType, mdType, bodyType],
  SymbolOps: TYPE USING [
    CtxEntries, FindExtension, FirstCtxSe, HashValue, NextSe, ParentBti,
    SubStringForName, TypeForm, XferMode],
  SymbolPack: TYPE,
  SymbolSegment: TYPE USING [
    Base, ExtIndex, ExtRecord, extType, ltType, treeType],
  Tree: TYPE USING [Base, Link, Map, Null];

SymbolPackExt: PROGRAM
    IMPORTS
      Alloc, Strings, SymbolOps,
      own: SymbolPack
    EXPORTS SymbolOps = PUBLIC {
  OPEN SymbolOps, Symbols;

  charsPerWord: PRIVATE NAT = Symbols.WordLength/Symbols.ByteLength;
  SubString: PRIVATE TYPE = Strings.SubString;

 -- variables for building the symbol string

  ssw: PRIVATE Alloc.Index;

-- tables defining the current symbol table

  table: PRIVATE Alloc.Handle;
  zone: PRIVATE UNCOUNTED ZONE ← NIL;
  
  hashVec: PRIVATE LONG POINTER TO HashVector;
  ht: PRIVATE LONG DESCRIPTOR FOR ARRAY Name OF HTRecord;

  htb: PRIVATE Symbols.Base;		-- hash table
  ssb: PRIVATE Strings.String;		-- id string
  seb: PRIVATE Symbols.Base;		-- se table
  ctxb: PRIVATE Symbols.Base;		-- context table
  mdb: PRIVATE Symbols.Base;		-- module directory base
  bb: PRIVATE Symbols.Base;		-- body table
  extb: PRIVATE SymbolSegment.Base;	-- extension table

  UpdateBases: PRIVATE Alloc.Notifier = {
    -- called whenever the main symbol table is repacked
    own.hashVec ← hashVec;
    htb ← base[htType];
    own.ssb ← ssb ← LOOPHOLE[base[ssType], Strings.String];
    own.ht ← ht ← DESCRIPTOR[htb, ht.LENGTH];
    own.seb ← seb ← base[seType];
    own.ctxb ← ctxb ← base[ctxType];  own.mdb ← mdb ← base[mdType];
    own.bb ← bb ← base[bodyType];
    own.tb ← base[SymbolSegment.treeType];
    own.ltb ← base[SymbolSegment.ltType];
    own.extb ← extb ← base[SymbolSegment.extType];
    own.notifier[own]};


  initialized: PRIVATE BOOL ← FALSE;

  Initialize: PROC [ownTable: Alloc.Handle, scratchZone: UNCOUNTED ZONE] = { 
    -- called to set up the compiler's symbol table 
    IF initialized THEN Finalize[];
    zone ← scratchZone;
    hashVec ← zone.NEW[HashVector ← ALL[HTNull]];
    own.notifier ← own.NullNotifier;
    own.mdLimit ← MDIndex.FIRST;
    own.extLimit ← SymbolSegment.ExtIndex.FIRST;
    own.mainCtx ← CTXNull;  own.stHandle ← NIL;  own.sourceFile ← NIL;
    ht ← NIL;
    table ← ownTable;  table.AddNotify[UpdateBases];
    ssw ← table.Words[ssType, StringBody[0].SIZE] + StringBody[0].SIZE;
    ssb↑ ← StringBody[length:0, maxlength:0, text:];
    IF AllocateHash[] # nullName THEN ERROR;
    IF MakeNonCtxSe[SERecord.cons.nil.SIZE] # CSENull THEN ERROR;
    seb[CSENull] ← SERecord[mark3: FALSE, mark4: FALSE, body: cons[nil[]]];
    IF MakeNonCtxSe[SERecord.cons.mode.SIZE] # typeTYPE THEN ERROR;
    seb[typeTYPE] ← SERecord[mark3: TRUE, mark4: TRUE, body: cons[mode[]]];
    IF table.Words[ctxType, CTXRecord.nil.SIZE] # CTXNull THEN ERROR;
    ctxb[CTXNull] ← CTXRecord[FALSE, FALSE, ISENull, lZ, nil[]];
    initialized ← TRUE};
   
  Reset: PROC = {
    nC: CARDINAL = (table.Bounds[ssType].size - StringBody[0].SIZE)*charsPerWord;
    desc: Strings.SubStringDescriptor;
    hvi: HVIndex;
    htLimit: HTIndex = table.Bounds[htType].size/HTRecord.SIZE;
    ssw ← table.Top[ssType];
    ssb↑ ← [length: ht[htLimit-1].ssIndex, maxlength: nC, text:];
    own.ht ← ht ← DESCRIPTOR[htb, htLimit];
    hashVec↑ ← ALL[HTNull];
    FOR hti: HTIndex IN (HTNull .. htLimit) DO
      SubStringForName[@desc, hti];  hvi ← HashValue[@desc];
      ht[hti].link ← hashVec[hvi];  hashVec[hvi] ← hti;
      ht[hti].anyInternal ← ht[hti].anyPublic ← FALSE;
      ENDLOOP;
    own.mdLimit ← table.Top[mdType];
    own.extLimit ← table.Top[SymbolSegment.extType]};

  Finalize: PROC = {
    table.DropNotify[UpdateBases];  table ← NIL;
    zone.FREE[@hashVec];  zone ← NIL;
    initialized ← FALSE};
   

 -- hash entry creation

  EnterString: PROC [s: SubString] RETURNS [name: Name] = {
    hvi: HVIndex = HashValue[s];
    desc: Strings.SubStringDescriptor;
    offset, length, nw: CARDINAL;
    ssi: Alloc.Index;
    FOR name ← hashVec[hvi], ht[name].link UNTIL name = nullName DO
      SubStringForName[@desc, name];
      IF Strings.EqualSubStrings[s, @desc] THEN RETURN [name];
      ENDLOOP;
    offset ← ssb.length;  length ← s.length;
    nw ← (offset+length+(charsPerWord-1) - ssb.maxlength)/charsPerWord;
    IF nw # 0 THEN {
      IF (ssi ← table.Words[ssType, nw]) # ssw THEN ERROR;
      ssw ← ssw + nw;
      ssb↑ ← StringBody[
		length: ssb.length,
		maxlength: ssb.maxlength + nw*charsPerWord,
		text: ]};
    Strings.AppendSubString[ssb, s];
    name ← AllocateHash[];  ht[name].link ← hashVec[hvi];  hashVec[hvi] ← name;
    RETURN};

  AllocateHash: PRIVATE PROC RETURNS [HTIndex] = {
    hti: HTIndex = ht.LENGTH;
    [] ← table.Words[htType, HTRecord.SIZE];
    own.ht ← ht ← DESCRIPTOR[htb, ht.LENGTH+1];
    ht[hti] ← HTRecord[
	anyInternal: FALSE, anyPublic: FALSE,
	link: HTNull,
	ssIndex: ssb.length];
    RETURN [hti]};

  HashBlock: PROC RETURNS [LONG POINTER TO HashVector] = {
    RETURN [hashVec]};


 -- lexical level accounting

  StaticNestError: SIGNAL = CODE;

  NextLevel: PROC [cl: ContextLevel] RETURNS [nl: ContextLevel] = {
    IF cl+1 < ContextLevel.LAST THEN nl ← cl+1
    ELSE {SIGNAL StaticNestError; nl ← cl};
    RETURN};

  BlockLevel: PROC [cl: ContextLevel] RETURNS [nl: ContextLevel] = {
    RETURN [IF cl = lG THEN lL ELSE cl]};


 -- context table manipulation

  Circular: PRIVATE PROC [ctx: CTXIndex] RETURNS [BOOL] = INLINE {
    RETURN [WITH c:ctxb[ctx] SELECT FROM included=> ~c.reset, ENDCASE=> FALSE]};

  NewCtx: PROC [level: ContextLevel] RETURNS [ctx: CTXIndex] = {
    -- makes a non-include context entry
    ctx ← table.Words[ctxType, CTXRecord.simple.SIZE];
    ctxb[ctx] ← [
	rePainted: FALSE, varUpdated: FALSE,
	seList: ISENull,
	level: level,
	extension: simple[ctxNew: CTXNull]];
    RETURN};

  SetMainCtx: PROC [ctx: CTXIndex] = {own.mainCtx ← ctx};

  ResetCtxList: PROC [ctx: CTXIndex] = {
    -- change the list for ctx to a proper chain
    sei: ISEIndex = ctxb[ctx].seList;
    IF sei # ISENull THEN {ctxb[ctx].seList ← NextSe[sei]; SetSeLink[sei, ISENull]}};


  FirstVisibleSe: PROC [ctx: CTXIndex] RETURNS [sei: ISEIndex] = {
    sei ← ctxb[ctx].seList;
    WHILE sei # ISENull AND seb[sei].idCtx # ctx DO sei ← NextSe[sei] ENDLOOP;
    RETURN};

  NextVisibleSe: PROC [sei: ISEIndex] RETURNS [next: ISEIndex] = {
    IF (next ← sei) # ISENull THEN
      UNTIL (next ← NextSe[next]) = ISENull OR seb[next].idCtx = seb[sei].idCtx DO
	NULL ENDLOOP;
    RETURN};

  VisibleCtxEntries: PROC [ctx: CTXIndex] RETURNS [n: CARDINAL ← 0] = {
    IF ctx = CTXNull OR Circular[ctx] THEN RETURN;
    FOR sei: ISEIndex ← FirstCtxSe[ctx], NextSe[sei] UNTIL sei = ISENull DO
      IF seb[sei].idCtx = ctx THEN n ← n+1 ENDLOOP;
    RETURN};


  ContextVariant: PROC [ctx: CTXIndex] RETURNS [sei: ISEIndex] = {
    FOR sei ← FirstCtxSe[ctx], NextSe[sei] UNTIL sei = ISENull DO 
      IF TypeForm[seb[sei].idType] = union THEN RETURN ENDLOOP;
    RETURN [ISENull]};



 -- semantic entry creation

  MakeSeChain: PROC [ctx: CTXIndex, n: CARDINAL, linked: BOOL]
      RETURNS [seChain: ISEIndex] = {
    sei: ISEIndex;
    IF n = 0 THEN RETURN [ISENull];
    seChain ← table.Words[seType,
		  (n-1)*SERecord.id.sequential.SIZE + 
		   (IF linked THEN SERecord.id.linked.SIZE ELSE SERecord.id.terminal.SIZE)];
    sei ← seChain;
    THROUGH [1..n) DO
      seb[sei] ← [mark3:FALSE, mark4:FALSE, body:id[,,ctx,,,,,,nullName,,sequential[]]];
      sei ← sei + SERecord.id.sequential.SIZE;
      ENDLOOP;
    IF linked THEN
      seb[sei] ← [mark3:FALSE, mark4:FALSE, body:id[,,ctx,,,,,,nullName,,linked[ISENull]]]
    ELSE seb[sei] ← [mark3:FALSE, mark4:FALSE, body:id[,,ctx,,,,,,nullName,,terminal[]]];
    RETURN};


  MakeCtxSe: PROC [name: Name, ctx: CTXIndex] RETURNS [sei: ISEIndex] = {
    next, pSei: ISEIndex;
    sei ← table.Words[seType, SERecord.id.linked.SIZE];
    SELECT TRUE FROM
      (ctx = CTXNull) => next ← ISENull;
      Circular[ctx] => {
	pSei ← ctxb[ctx].seList;
	IF pSei = ISENull THEN next ← sei
	ELSE {next ← NextSe[pSei]; SetSeLink[pSei, sei]};
	ctxb[ctx].seList ← sei};
      ENDCASE => {
	pSei ← ctxb[ctx].seList;
	IF pSei = ISENull THEN {next ← ISENull; ctxb[ctx].seList ← sei}
	ELSE {
	  UNTIL (next ← NextSe[pSei]) = ISENull DO pSei ← next ENDLOOP;
	  SetSeLink[pSei, sei]}};
    seb[sei] ← [mark3:FALSE, mark4:FALSE, body:id[,,ctx,,,,,,name,,linked[link: next]]];
    RETURN};

  NameClash: SIGNAL [name: Name] = CODE;

  FillCtxSe: PROC [sei: ISEIndex, name: Name, public: BOOL] = {
    ctx: CTXIndex = seb[sei].idCtx;
    seb[sei].hash ← name;
    IF name # nullName THEN {
      IF ht[name].anyInternal AND ctx # CTXNull THEN
	FOR pSei: ISEIndex ← FirstCtxSe[ctx], NextSe[pSei] UNTIL pSei = sei DO
	  IF seb[pSei].hash = name THEN {SIGNAL NameClash[name]; EXIT};
	  ENDLOOP;
      ht[name].anyInternal ← TRUE;
      IF public THEN ht[name].anyPublic ← TRUE}};

  EnterExtension: PROC [sei: ISEIndex, type: ExtensionType, tree: Tree.Link] = {
    OPEN SymbolSegment;
    exti: ExtIndex;
    extLimit: ExtIndex = own.extLimit;
    FOR exti ← ExtIndex.FIRST, exti + ExtRecord.SIZE UNTIL exti = extLimit DO
      IF extb[exti].sei = sei THEN GO TO Update;
      REPEAT
        Update => extb[exti] ← ExtRecord[sei:sei, type:type, tree:tree];
        FINISHED =>
	  IF tree # Tree.Null THEN {
	    exti ← table.Words[extType, ExtRecord.SIZE];
	    own.extLimit ← own.extLimit + ExtRecord.SIZE;
	    extb[exti] ← ExtRecord[sei:sei, type:type, tree:tree]};
      ENDLOOP;
    seb[sei].extended ← TRUE};

  SetSeLink: PROC [sei, next: ISEIndex] = {
    WITH seb[sei] SELECT FROM linked => link ← next; ENDCASE => ERROR};


  MakeNonCtxSe: PROC [size: CARDINAL] RETURNS [sei: CSEIndex] = {
    sei ← table.Words[seType, size];
    seb[sei] ← [mark3: FALSE, mark4: FALSE, body: cons[typeInfo: ]];
    RETURN};


 -- copying within current table

  CopyBasicType: PROC [type: CSEIndex] RETURNS [copy: CSEIndex] = {
    WITH master: seb[type] SELECT FROM
      basic => {
	copy ← MakeNonCtxSe[SERecord.cons.basic.SIZE];
	seb[copy] ← SERecord[
	    mark3: master.mark3, mark4: master.mark4,
	    body: cons[basic[
		code: master.code, ordered: master.ordered,
		length: master.length]]]}
      ENDCASE => copy ← typeANY;
    RETURN};


  CopyXferType: PROC [type: CSEIndex, mapper: Tree.Map]
      RETURNS [copy: CSEIndex] = {
    WITH master: seb[type] SELECT FROM
      transfer => {
	copy ← MakeNonCtxSe[SERecord.cons.transfer.SIZE];
	seb[copy] ← SERecord[
	    mark3: master.mark3, mark4: master.mark4,
	    body: cons[transfer[
		mode: master.mode, safe: master.safe,
		typeIn: CopyArgs[master.typeIn, NIL],
		typeOut: CopyArgs[master.typeOut, mapper]]]]};
      ENDCASE => copy ← typeANY;
    RETURN};

  CopyArgSe: PROC [copy, master: ISEIndex] = {CopyArg[copy, master, NIL]};


  CopyArgs: PRIVATE PROC [args: CSEIndex, mapper: Tree.Map] RETURNS [copy: CSEIndex] = {
    IF args = CSENull THEN copy ← CSENull
    ELSE
      WITH t: seb[args] SELECT FROM
        record => {
	  ctx1: CTXIndex = t.fieldCtx;
	  ctx2: CTXIndex = NewCtx[ctxb[ctx1].level];
	  seChain: ISEIndex = MakeSeChain[ctx2, CtxEntries[ctx1], FALSE];
	  sei1: ISEIndex ← ctxb[ctx1].seList;
	  sei2: ISEIndex ← ctxb[ctx2].seList ← seChain;
	  UNTIL sei1 = ISENull DO
	    CopyArg[sei2, sei1, mapper];
	    sei1 ← NextSe[sei1]; sei2 ← NextSe[sei2];
	    ENDLOOP;
	  copy ← MakeNonCtxSe[SERecord.cons.record.notLinked.SIZE];
	  seb[copy] ← SERecord[mark3: t.mark3, mark4: t.mark4,
		body: cons[
		  record[
		    machineDep: FALSE,
		    painted: t.painted, argument: TRUE,
		    hints: t.hints,
		    fieldCtx: ctx2,
		    length: t.length,
		    monitored: FALSE,
		    linkPart: notLinked[]]]]};
        any => {
	  copy ← MakeNonCtxSe[SERecord.cons.any.SIZE];
	  seb[copy] ← SERecord[mark3: t.mark3, mark4: t.mark4,
		body: cons[any[]]]};
	ENDCASE => ERROR;
    RETURN};

  CopyArg: PRIVATE PROC [copy, master: ISEIndex, mapper: Tree.Map] = {
    seb[copy].hash ← seb[master].hash;
    seb[copy].public ← seb[master].public;
    seb[copy].immutable ← seb[master].immutable;
    seb[copy].constant ← seb[master].constant;
    seb[copy].idType ← seb[master].idType;
    seb[copy].idInfo ←  seb[master].idInfo;
    seb[copy].idValue ← seb[master].idValue;
    seb[copy].linkSpace ← FALSE;
    seb[copy].mark3 ← seb[master].mark3; seb[copy].mark4 ← seb[master].mark4;
    IF mapper # NIL AND seb[master].extended THEN {
      type: ExtensionType;
      t: Tree.Link;
      [type, t] ← FindExtension[master];
      EnterExtension[copy, type, mapper[t]]}
    ELSE seb[copy].extended ← FALSE};


 -- body table utilities

  LinkBti: PROC [bti, parent: BTIndex] = {
    prev: BTIndex;
    IF parent # BTNull THEN {
      IF (prev ← bb[parent].firstSon) = BTNull THEN bb[parent].firstSon ← bti
      ELSE {
	UNTIL bb[prev].link.which = parent DO prev ← bb[prev].link.index ENDLOOP;
	bb[prev].link ← [which:sibling, index:bti]}};
    bb[bti].link ← [which:parent, index:parent]};

  DelinkBti: PROC [bti: BTIndex] = {
    prev, next: BTIndex;
    parent: BTIndex = ParentBti[bti];
    IF parent # BTNull THEN {
      prev ← bb[parent].firstSon;
      IF prev = bti THEN
        bb[parent].firstSon ←
	  IF bb[bti].link.which = parent THEN BTNull ELSE bb[bti].link.index
      ELSE {
	UNTIL (next ← bb[prev].link.index) = bti DO prev ← next ENDLOOP;
	bb[prev].link ← bb[next].link}};
    bb[bti].link ← [which:parent, index:BTNull]};


 -- attribute extraction

  ConstantId: PROC [sei: ISEIndex] RETURNS [BOOL] = {
    RETURN [IF ~seb[sei].constant
      THEN FALSE
      ELSE
	SELECT XferMode[seb[sei].idType] FROM
	  proc, signal, error, program => seb[sei].mark4 AND seb[sei].idInfo = BTNull,
	  ENDCASE => TRUE]};

  }.