-- BcdBind.mesa
-- Last edited by Satterthwaite on August 1, 1983 11:38 am
-- Last edited by Lewis on 16-Dec-80 10:12:01

DIRECTORY
  Alloc: TYPE USING [AddNotify, Bounds, DropNotify, Handle, Notifier, Top],
  BcdBindDefs: TYPE USING [RelocHandle],
  BcdComData: TYPE USING [currentName, table, textIndex, zone],
  BcdControlDefs: TYPE USING [],
  BcdDefs: TYPE USING [
    CTIndex, cttype, cxtype, EPLimit, EXPIndex, EXPNull, exptype,
    FTIndex, FTNull, fttype, GFTIndex, IMPIndex, IMPNull, IMPRecord, imptype,
    LFIndex, LFNull, lftype, Link, MTIndex, MTRecord, mttype,
    NameRecord, NullLink, NullName, sstype, sttype, treetype, UnboundLink],
  BcdErrorDefs: TYPE USING [
    ErrorHti, ErrorInterface, ErrorSti, Error2Files, GetModule, GetSti],
  BcdOps: TYPE USING [NameString],
  BcdUtilDefs: TYPE USING [
    EqVersions, GetDummyGfi, GetGfi, InstanceName, NameForSti],
  HashOps: TYPE USING [FindString],
  Strings: TYPE USING [SubStringDescriptor],
  Symbols: TYPE USING [CXIndex, cxNull, htNull, HTIndex, STIndex, stNull, STRecord],
  Table: TYPE USING [Base],
  Tree: TYPE USING [Link, Scan, null],
  TreeOps: TYPE USING [ScanList];

BcdBind: PROGRAM
    IMPORTS
      Alloc, BcdErrorDefs, BcdUtilDefs, HashOps, TreeOps,
      data: BcdComData
    EXPORTS BcdControlDefs = {
  OPEN BcdDefs, Symbols;

  BindError: PUBLIC ERROR ~ CODE;

  table: Alloc.Handle;
  tb, stb, ctb, cxb, mtb, lfb, etb, itb, ftb: Table.Base;
  ssb: BcdOps.NameString;

  Notifier: Alloc.Notifier ~ {
    tb  ← base[treetype];  stb ← base[sttype];  cxb ← base[cxtype];
    ctb ← base[cttype];    mtb ← base[mttype];  lfb ← base[lftype];
    etb ← base[exptype];   itb ← base[imptype];
    ftb ← base[fttype];
    ssb ← base[sstype]};


  Error: PROC ~ {ERROR BindError};

  ItiToIndex: PROC [impi: IMPIndex] RETURNS [CARDINAL] ~ INLINE {
    RETURN [LOOPHOLE[impi, CARDINAL]/IMPRecord.SIZE]};


  relocationHead: BcdBindDefs.RelocHandle;
  rel: BcdBindDefs.RelocHandle;

  BindRoot: PUBLIC PROC [relocationRoot: BcdBindDefs.RelocHandle] ~ {
    table ← data.table; table.AddNotify[Notifier];
    relocationHead ← relocationRoot;
    SetupGFMap[];
    AssignImports[
      ! BcdErrorDefs.GetSti => {
        IF rel # NIL THEN
          RESUME [StiForContext[
            IF rel.type = $inner THEN rel.parentcx ELSE rel.context]]}];
    BindModules[];
    ReleaseGFMap[];
    table.DropNotify[Notifier];  table ← NIL};

  LinkType: TYPE ~ RECORD [
    SELECT tag:* FROM
      gfi => [gfi: GFTIndex],
      import => [impi: IMPIndex],
      ENDCASE];

  GFMapItem: TYPE ~ RECORD [
    linkItem: LinkType,
    expi: EXPIndex,
    offset: [0..4)];

  GFMap: TYPE ~ RECORD [SEQUENCE length: CARDINAL OF GFMapItem];
  RelMap: TYPE ~ RECORD [SEQUENCE length: CARDINAL OF CARDINAL];
    
  finalFirstDummy: GFTIndex;
  gfMap: LONG POINTER TO GFMap ← NIL;
  relMap: LONG POINTER TO RelMap ← NIL;

  SetupGFMap: PROC ~ {
    nDummies: CARDINAL ← BcdUtilDefs.GetDummyGfi[0]-1;
    nImports: CARDINAL ~ table.Bounds[imptype].size/IMPRecord.SIZE;
    finalFirstDummy ← BcdUtilDefs.GetGfi[0];
    IF nDummies # 0 THEN nDummies ← nDummies + 1;
    gfMap ← (data.zone).NEW[GFMap[nDummies]];
    FOR i: CARDINAL IN [0..nDummies) DO gfMap[i] ← [[gfi[0]], EXPNull, 0] ENDLOOP;
    relMap ← (data.zone).NEW[RelMap[nImports]];
    FOR rel: BcdBindDefs.RelocHandle ← relocationHead, rel.link UNTIL rel = NIL DO
      FOR iti: IMPIndex ← IMPIndex.FIRST+rel.import, iti+IMPRecord.SIZE
       UNTIL iti = rel.importLimit DO
        relMap[ItiToIndex[iti]] ← itb[iti].gfi + rel.dummygfi-rel.originalfirstdummy;
        ENDLOOP;
      ENDLOOP};

  RelocatedGfi: PROC [iti: IMPIndex] RETURNS [CARDINAL] ~ {
    RETURN [IF iti = IMPNull THEN 0 ELSE relMap[ItiToIndex[iti]]]};

  ReleaseGFMap: PROC ~ {
    IF gfMap # NIL THEN (data.zone).FREE[@gfMap];
    IF relMap # NIL THEN (data.zone).FREE[@relMap]};


  NameToHti: PROC [name: NameRecord] RETURNS [hti: HTIndex] ~ {
    ss: Strings.SubStringDescriptor ← [base~@ssb.string, offset~name, length~ssb.size[name]];
    hti ← HashOps.FindString[@ss];
    IF hti = htNull THEN Error[]};

  ExpiForSti: PROC [sti: STIndex] RETURNS [EXPIndex] ~ {
    RETURN [IF sti = stNull
      THEN EXPNull
      ELSE
	WITH s~~stb[sti] SELECT FROM
	  external => WITH m~~s.map SELECT FROM interface => m.expi, ENDCASE => EXPNull,
	  ENDCASE => EXPNull]};


  AssignImports: PROC ~ {
    saveIndex: CARDINAL ~ data.textIndex;
    saveName: NameRecord ~ data.currentName;
    FOR rel ← relocationHead, rel.link UNTIL rel = NIL DO
      data.textIndex ← rel.textIndex;
      data.currentName ← BcdUtilDefs.NameForSti[StiForContext[rel.context]];
      SELECT TRUE FROM
	(rel.type = $outer) =>  AssignOuter[rel];
	(rel.parameters # Tree.null) =>  AssignByPosition[rel];
	ENDCASE =>  AssignByName[rel];
      ENDLOOP;
    data.textIndex ← saveIndex;  data.currentName ← saveName};
  
  AssignOuter: PROC [rel: BcdBindDefs.RelocHandle] ~ {
    FOR iti: IMPIndex ← IMPIndex.FIRST+rel.import, iti+IMPRecord.SIZE 
     UNTIL iti = rel.importLimit DO
      sti: STIndex ~ LookupInstance[iti, rel.context];
      IF sti = stNull THEN LOOP;
      IF stb[sti].impi # IMPNull
	THEN {
	  OPEN imp~~itb[stb[sti].impi];
	  stb[sti].impgfi ← imp.gfi ← BcdUtilDefs.GetGfi[imp.ngfi]}
        ELSE BcdErrorDefs.ErrorSti[$error, "is not imported by any module"L, sti];
      ENDLOOP};

  AssignByName: PROC [rel: BcdBindDefs.RelocHandle] ~ {
    iti, import: IMPIndex;
    export: EXPIndex;
    defgfi: CARDINAL;
    sti, parentSti: STIndex;
    FOR iti ← IMPIndex.FIRST+rel.import, iti+IMPRecord.SIZE UNTIL iti = rel.importLimit DO
      sti ← IF rel.type = $inner
		THEN LookupInstance[iti, rel.context]
		ELSE LookupInterface[iti, rel.context];
      IF sti = stNull THEN LOOP;
      defgfi ← stb[sti].impgfi;
      IF stb[sti].impi # IMPNull
	THEN
          SELECT rel.type FROM
            $inner => {
              IF (parentSti ← LookupInterface[iti, rel.parentcx]) = stNull
                THEN LOOP;
              import ← stb[parentSti].impi;  export ← ExpiForSti[parentSti];
              defgfi ← stb[parentSti].impgfi;
              sti ← parentSti};
            ENDCASE => {import ← stb[sti].impi; export ← ExpiForSti[sti]}
        ELSE {import ← IMPNull; export ← ExpiForSti[sti]};
      WITH s~~stb[sti] SELECT FROM
	external =>
	  WITH m~~s.map SELECT FROM
	    module => AssignModule[defgfi, m.mti, iti];
	    interface => AssignInterface[defgfi, import, export, iti];
	    unknown => AssignImport[defgfi, import, iti];
	    ENDCASE => Error[];
	unknown => AssignImport[defgfi, import, iti];
	ENDCASE => Error[];
      ENDLOOP};

  LookupInstance: PROC [iti: IMPIndex, cxi: CXIndex] RETURNS [STIndex] ~ {
    RETURN [IF cxi = cxNull
      THEN stNull
      ELSE Lookup[
	      hti~NameToHti[IF itb[iti].namedInstance
			THEN BcdUtilDefs.InstanceName[[import[iti]]]
			ELSE itb[iti].name],
	      cxi~rel.context]]};

  LookupInterface: PROC [iti: IMPIndex, cxi: CXIndex] RETURNS [STIndex] ~ {
    RETURN [IF cxi = cxNull THEN stNull ELSE Lookup[NameToHti[itb[iti].name], cxi]]};


  AssignByPosition: PROC [rel: BcdBindDefs.RelocHandle] ~ {
    iti: IMPIndex;
    TooManyParameters: ERROR ~ CODE;

    AssignPosition: Tree.Scan ~ {
      sti: STIndex ~ NARROW[t, Tree.Link.symbol].index;
      import: IMPIndex ~ stb[sti].impi;
      export: EXPIndex ~ ExpiForSti[sti];
      defgfi: CARDINAL ~ stb[sti].impgfi;
      IF iti = rel.importLimit THEN ERROR TooManyParameters;
      WITH s~~stb[sti] SELECT FROM
        external =>
          WITH m~~s.map SELECT FROM
            module => AssignModule[defgfi, m.mti, iti];
            interface => AssignInterface[defgfi, import, export, iti];
            unknown => AssignImport[defgfi, import, iti];
            ENDCASE => Error[];
        ENDCASE => BcdErrorDefs.ErrorSti[$error, "is undeclared"L, sti];
      iti ← iti + BcdDefs.IMPRecord.SIZE};

    iti ← IMPIndex.FIRST + rel.import;
    TreeOps.ScanList[rel.parameters, AssignPosition
      ! TooManyParameters => {GOTO tooMany}];
    IF iti # rel.importLimit THEN GOTO tooFew;
    EXITS
      tooMany =>  BcdErrorDefs.ErrorHti[$error,
	  "has too many parameters"L, HtiForRelocation[rel]];
      tooFew =>  BcdErrorDefs.ErrorHti[$error,
	  "has too few parameters"L, HtiForRelocation[rel]]};

  MakeLink: PROC [defgfi: CARDINAL, import: IMPIndex, offset: CARDINAL]
      RETURNS [LinkType] ~ {
    RETURN [SELECT TRUE FROM
      (defgfi # 0) => [gfi[defgfi+offset]],
      (import = IMPNull) => [gfi[0]],
      ENDCASE => [import[import]]]};

  AssignModule: PROC [defgfi: GFTIndex, mti: MTIndex, iti: IMPIndex] ~ {
    OPEN imp~~itb[iti];
    gfi: CARDINAL ~ RelocatedGfi[iti];
    IF imp.port # $module OR ~BcdUtilDefs.EqVersions[imp.file, mtb[mti].file] THEN
      BcdErrorDefs.Error2Files[
	class~$error,
	s~"is required for import, but available version is"L,
	ft1~imp.file, ft2~mtb[mti].file];
    gfMap[gfi] ← [
      linkItem~[gfi[IF defgfi # 0 THEN defgfi ELSE mtb[mti].gfi]],
      expi~EXPNull, offset~0]};

  AssignInterface: PROC [defgfi: GFTIndex, import: IMPIndex, expi: EXPIndex, iti: IMPIndex] ~ {
    OPEN exp~~etb[expi], imp~~itb[iti];
    gfi: CARDINAL ~ RelocatedGfi[iti];
    IF expi # EXPNull AND
     (imp.port # exp.port OR ~BcdUtilDefs.EqVersions[imp.file, exp.file]) THEN
        BcdErrorDefs.Error2Files[
	  class~$error,
	  s~"is required for import, but available version is"L,
	  ft1~imp.file, ft2~exp.file];
    IF imp.port = $module THEN
        gfMap[gfi] ← [
          linkItem~[gfi[etb[expi].links[0].gfi]],
          expi~EXPNull, offset~0]
    ELSE FOR i: [0..4) IN [0..imp.ngfi) DO
      gfMap[gfi+i] ← [
        linkItem~MakeLink[defgfi, import, i],
        expi~expi, offset~i];
      ENDLOOP};

  AssignImport: PROC [defgfi: GFTIndex, import: IMPIndex, iti: IMPIndex] ~ {
    OPEN imp~~itb[iti];
    gfi: CARDINAL ~ RelocatedGfi[iti];
    IF import # IMPNull AND
     (imp.port # itb[import].port OR
      ~BcdUtilDefs.EqVersions[imp.file, itb[import].file]) THEN
        BcdErrorDefs.Error2Files[
	  class~$error,
	  s~"is required for import, but available version is"L,
	  ft1~imp.file, ft2~itb[import].file];
    FOR i: [0..4) IN [0..imp.ngfi) DO
      gfMap[gfi+i] ← [
        linkItem~MakeLink[defgfi, import, i],
        expi~EXPNull, offset~i];
      ENDLOOP};

  Lookup: PROC [hti: HTIndex, cxi: CXIndex] RETURNS [sti: STIndex] ~ {
    FOR sti ← cxb[cxi].link, stb[sti].link UNTIL sti = stNull DO
      IF stb[sti].hti = hti THEN RETURN ENDLOOP;
    RETURN [stNull]};

  StiForContext: PROC [cxi: CXIndex] RETURNS [sti: STIndex] ~ {
    stLimit: STIndex ~ table.Top[sttype];
    FOR sti ← STIndex.FIRST, sti+STRecord.SIZE UNTIL sti = stLimit DO
      WITH s~~stb[sti] SELECT FROM
        local => IF s.context = cxi THEN RETURN;
        ENDCASE;
      ENDLOOP;
    RETURN [stNull]};

  HtiForRelocation: PROC [rel: BcdBindDefs.RelocHandle] RETURNS [HTIndex] ~ {
    sti: STIndex;
    mti: MTIndex;
    cti: CTIndex;
    IF rel.type # $file THEN {
      sti ← StiForContext[rel.context];  RETURN [stb[sti].hti]};
    mti ← MTIndex.FIRST + rel.module;  cti ← CTIndex.FIRST + rel.config;
    RETURN [NameToHti[IF mtb[mti].config = cti THEN ctb[cti].name ELSE mtb[mti].name]]};

  BindModules: PROC ~ {
    saveIndex: CARDINAL ~ data.textIndex;
    saveName: NameRecord ~ data.currentName;
    mtLimit: MTIndex ~ table.Top[mttype];
    rel ← relocationHead;
    FOR mti: MTIndex ← MTIndex.FIRST, mti + MTRecord.SIZE UNTIL mti = mtLimit DO
      SetRelocationForModule[mti];
      BindFragment[mti, mtb[mti].links];
      ENDLOOP;
    data.textIndex ← saveIndex;  data.currentName ← saveName};

  SetRelocationForModule: PROC [mti: MTIndex] ~ {
    gfi: GFTIndex ~ mtb[mti].gfi;
    FOR rel ← rel, rel.link UNTIL rel = NIL DO
      IF gfi IN [rel.firstgfi..rel.lastgfi] THEN GOTO found ENDLOOP;
    FOR rel ← relocationHead, rel.link UNTIL rel = NIL DO
      IF gfi IN [rel.firstgfi..rel.lastgfi] THEN GOTO found ENDLOOP;
    Error[];
    EXITS found => {
      data.textIndex ← rel.textIndex;
      data.currentName ← BcdUtilDefs.NameForSti[StiForContext[rel.context]]}};

  BindFragment: PROC [mti: MTIndex, lfi: LFIndex] ~ {
    IF lfi # LFNull THEN
      FOR i: CARDINAL IN [0 .. lfb[lfi].length) DO
	lfb[lfi].frag[i] ← RelocateLink[lfb[lfi].frag[i]
	    ! BcdErrorDefs.GetModule => {RESUME [mti, i]}];
	ENDLOOP};
    
  RelocateLink: PROC [cl: BcdDefs.Link] RETURNS [BcdDefs.Link] ~ {
    SELECT TRUE FROM
      (cl.vtag = $type) => ERROR;
      (cl.gfi = 0) => NULL;
      (cl.gfi < rel.originalfirstdummy) =>  cl.gfi ← cl.gfi + rel.firstgfi-1;
      ENDCASE => {
	gfi: CARDINAL;
	expi: EXPIndex;
	map: LONG POINTER TO GFMapItem;
	gfi ← cl.gfi + rel.dummygfi-rel.originalfirstdummy;
	DO
	  map ← @gfMap[gfi];
	  IF (expi←map.expi) # EXPNull THEN {
	    newCl: BcdDefs.Link ~ etb[expi].links[cl.ep + map.offset*EPLimit];
	    IF newCl # NullLink THEN RETURN [newCl]};
	  WITH map.linkItem SELECT FROM
	    m: LinkType.gfi => {
	      IF (gfi←m.gfi) = 0 THEN GOTO unbindable;
	      IF gfi < finalFirstDummy AND cl.ep = 0 THEN 
		cl ← [variable[vgfi~0, var~0, vtag~$var]];
	      EXIT};
	    m: LinkType.import => gfi ← RelocatedGfi[m.impi]+map.offset;
	    ENDCASE;
	  REPEAT
	    unbindable => {
	      importName: NameRecord;
	      offset: CARDINAL;
	      importFti: FTIndex;
	      [importName, offset, importFti] ← LookupImport[cl.gfi];
	      BcdErrorDefs.ErrorInterface[
		class~$warning, s~"is unbindable"L, 
	        import~[name~importName, fti~importFti], ep~(cl.ep + offset)];
	      RETURN [IF cl.vtag = $var THEN NullLink ELSE UnboundLink]};
	  ENDLOOP;
	cl.gfi ← gfi};
    RETURN [cl]};

  LookupImport: PROC [gfi: GFTIndex] 
      RETURNS [importName: NameRecord, offset: CARDINAL, importFti: FTIndex] ~ {
    FOR iti: IMPIndex ← (IMPIndex.FIRST + rel.import), 
     (iti + IMPRecord.SIZE) UNTIL iti = rel.importLimit DO  
      OPEN imp~~itb[iti];
      IF gfi IN [imp.gfi..imp.gfi+imp.ngfi) THEN
        RETURN[
          importName~imp.name, offset~(gfi-imp.gfi)*EPLimit, 
	  importFti~imp.file];
      ENDLOOP;
    RETURN [importName~NullName, offset~0, importFti~FTNull]};

  }.