-- BcdBind.mesa
-- Last edited by Satterthwaite on September 15, 1982 3:38 pm
-- 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],
  Strings: TYPE USING [SubStringDescriptor],
  Symbols: TYPE USING [CXIndex, CXNull, HTIndex, STIndex, STNull, STRecord],
  SymbolOps: TYPE USING [FindString],
  Table: TYPE USING [Base],
  Tree: TYPE USING [Scan, Null],
  TreeOps: TYPE USING [ScanList];

BcdBind: PROGRAM
    IMPORTS
      Alloc, BcdErrorDefs, BcdUtilDefs, SymbolOps, 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] = {
    found: BOOL;
    ss: Strings.SubStringDescriptor _ [base: @ssb.string, offset: name, length: ssb.size[name]];
    [found, hti] _ SymbolOps.FindString[@ss];
    IF ~found 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 = WITH t SELECT FROM symbol => index, ENDCASE => ERROR;
      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 + (WITH m: mtb[mti] SELECT FROM
		direct => MTRecord.direct.SIZE + m.length*Link.SIZE,
		indirect => MTRecord.indirect.SIZE,
		multiple => MTRecord.multiple.SIZE,
		ENDCASE => ERROR)
       UNTIL mti = mtLimit DO
      SetRelocationForModule[mti];
      WITH m: mtb[mti] SELECT FROM
        direct =>
	  FOR i: CARDINAL IN [0 .. m.length) DO
	    m.frag[i] _ RelocateLink[m.frag[i]
	        ! BcdErrorDefs.GetModule => {RESUME [mti, i]}];
	    ENDLOOP;
        indirect => BindFragment[mti, m.links];
	multiple => BindFragment[mti, m.links];
	ENDCASE => ERROR;
      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]};

  }.