-- file PGSBcd.mesa
-- last modified by Satterthwaite, July 2, 1982 4:13 pm

DIRECTORY
  BcdDefs: TYPE,
  BcdOps: TYPE USING [EXPHandle, NameString],
  Environment: TYPE USING [bytesPerPage, bytesPerWord],
  FileSegment: TYPE USING [Pages],
  FileStream: TYPE USING [FileByteIndex, GetIndex, SetIndex],
  PGSConDefs: TYPE USING [
    objectVersion, outeol, outstring, pgsVersion, resetoutstream, seterrstream,
    sourceName, sourceVersion, warningsLogged, WriteSymbols],
  Spaces: TYPE USING [Node, Free, FreeString, PagesForWords, String],
  Stream: TYPE USING [Handle, PutByte, PutBlock],
  Strings: TYPE USING [String, AppendChar, AppendString],
  TableCommand: TYPE USING [FindInterface, FindItem, BadInterface];

PGSBcd: PROGRAM
    IMPORTS FileStream, PGSConDefs, Spaces, Stream, Strings, TableCommand
    EXPORTS PGSConDefs = {

  StreamIndex: TYPE = FileStream.FileByteIndex;
  bytesPerWord: CARDINAL = Environment.bytesPerWord;
  
 -- BCD construction

  bcdHeader: BcdDefs.BCD;
  module: direct BcdDefs.MTRecord;
  export: BcdOps.EXPHandle;
  defsFile: BcdDefs.FTRecord;
  codeSeg, symbolSeg: BcdDefs.SGRecord;
  ssb: BcdOps.NameString _ NIL;

  out: Stream.Handle;
  moduleIndex, segIndex: StreamIndex;	-- for fixup
  moduleId: STRING _ [40];

  InitializePackedString: PROC = {
    ssb _ LOOPHOLE[Spaces.String[60]];
    ssb.string.length _ 1; ssb.size[1] _ 0};

  AddName: PROC [n: Strings.String] RETURNS [name: BcdDefs.NameRecord] = {
    IF n = NIL THEN name _ BcdDefs.NullName
    ELSE {
      Strings.AppendChar[@ssb.string, LOOPHOLE[n.length]];
      name _ BcdDefs.NameRecord[ssb.string.length];
      Strings.AppendString[@ssb.string, n]};
    RETURN};

  FillInModule: PROC [name: BcdDefs.NameRecord, altoCode: BOOLEAN] = {
    OPEN BcdDefs;
    module _ MTRecord[
      name: name, namedInstance: FALSE, initial: FALSE,
      file: FTSelf, linkLoc: frame, config: CTNull,
      code: [
	sgi: FIRST[SGIndex], linkspace: FALSE, packed: FALSE,
	offset: 0, length: 0],
      sseg: FIRST[SGIndex]+SIZE[SGRecord],
      frameRefs: FALSE, frameType: 0, framesize: 4,
      tableCompiled: TRUE, altoCode: altoCode, long: FALSE,
      residentFrame: FALSE, crossJumped: FALSE, packageable: TRUE,
      gfi: 1, variables: EVNull, ngfi: 1,
      boundsChecks: FALSE, nilChecks: FALSE,
      extension: direct[length: 0, frag: ]];
    codeSeg _ [class: code, file: FTSelf, base: 2, pages: 0, extraPages: 0];
    symbolSeg _ [class: symbols, file: FTNull, base: 0, pages: 0, extraPages: 0]};

  FillInExport: PROC [name: BcdDefs.NameRecord, size, entry: CARDINAL] = {
    export _ Spaces.Node[SIZE[BcdDefs.EXPRecord]+size];
    export^ _ BcdDefs.EXPRecord[
      name: name, size: size, port: interface,
      namedInstance: FALSE, typeExported: FALSE,
      file: FIRST[BcdDefs.FTIndex], links:];
    FOR i: CARDINAL IN [0..size) DO export.links[i] _ BcdDefs.NullLink ENDLOOP;
    export.links[entry] _ BcdDefs.Link[variable[vgfi:1, var:0, vtag:var]]};

  FillInHeader: PROC = {
    OPEN h: bcdHeader;
    -- clear all fields
    LOOPHOLE[bcdHeader, ARRAY [0..SIZE[BcdDefs.BCD]) OF CARDINAL] _ ALL[0];
    h.versionIdent _ BcdDefs.VersionID;
    h.version _ PGSConDefs.objectVersion;
    h.creator _ PGSConDefs.pgsVersion;
    h.sourceVersion _ PGSConDefs.sourceVersion;
    h.source _ IF PGSConDefs.sourceName = NIL
		THEN BcdDefs.NullName ELSE AddName[PGSConDefs.sourceName];
    h.nPages _ 1;
    h.nConfigs _ 0;  h.nModules _ 1;
    h.nImports _ 0;  h.nExports _ IF export = NIL THEN 0 ELSE 1;
    h.definitions _ h.repackaged _ h.typeExported _ FALSE;
    h.tableCompiled _ TRUE;
    h.versions _ FALSE;
    h.extended _ TRUE;
    h.spare1 _ TRUE;	-- large eval stack
    h.spare2 _ FALSE;
    h.firstdummy _ 2;  h.nDummies _ 0;
    h.ctOffset _ h.impOffset _ h.ntOffset _ SIZE[BcdDefs.BCD];
    h.ssOffset _ SIZE[BcdDefs.BCD];
    h.ssLimit _ SIZE[StringBody[ssb.string.length]];	-- all strings must be entered by now
    h.mtOffset _ h.ssOffset + LOOPHOLE[h.ssLimit, CARDINAL];
    h.mtLimit _ FIRST[BcdDefs.MTIndex] + SIZE[direct BcdDefs.MTRecord];
    h.sgOffset _ h.mtOffset + LOOPHOLE[h.mtLimit, CARDINAL];
    h.sgLimit _ FIRST[BcdDefs.SGIndex] + 2*SIZE[BcdDefs.SGRecord];
    IF export # NIL THEN {
      h.ftOffset _ h.sgOffset + LOOPHOLE[h.sgLimit, CARDINAL];
      h.ftLimit _ FIRST[BcdDefs.FTIndex] + SIZE[BcdDefs.FTRecord];
      h.expOffset _ h.ftOffset + LOOPHOLE[h.ftLimit, CARDINAL];
      h.expLimit _ FIRST[BcdDefs.EXPIndex] + SIZE[BcdDefs.EXPRecord]+export.size};
    h.rtPages _ [0, 0]};

  WriteBcd: PROC [out: Stream.Handle] = {
    out.PutBlock[[@bcdHeader, 0, SIZE[BcdDefs.BCD]*bytesPerWord]];
    out.PutBlock[[ssb, 0, SIZE[StringBody[ssb.string.length]]*bytesPerWord]];
    Spaces.FreeString[LOOPHOLE[ssb]];  ssb _ NIL;
    moduleIndex _ FileStream.GetIndex[out];
    out.PutBlock[[@module, 0, SIZE[direct BcdDefs.MTRecord]*bytesPerWord]];
    segIndex _ FileStream.GetIndex[out];
    out.PutBlock[[@codeSeg, 0, SIZE[BcdDefs.SGRecord]*bytesPerWord]];
    out.PutBlock[[@symbolSeg, 0, SIZE[BcdDefs.SGRecord]*bytesPerWord]];
    IF export # NIL THEN {
      out.PutBlock[[@defsFile, 0, SIZE[BcdDefs.FTRecord]*bytesPerWord]];
      out.PutBlock[[export, 0, (SIZE[BcdDefs.EXPRecord]+export.size)*bytesPerWord]];
      Spaces.Free[export]}};


 -- overall control

  WriteBcdHeader: PUBLIC PROC [
      outStream: Stream.Handle,
      tableId, binaryId: Strings.String,	-- file being written
      interfaceId, fileId: Strings.String,	-- interface being exported
      altoCode: BOOLEAN _ TRUE] = {
    symbols: FileSegment.Pages;
    out _ outStream;  moduleId.length _ 0;
    IF tableId # NIL THEN Strings.AppendString[moduleId, tableId]
    ELSE
      FOR i: CARDINAL IN [0 .. binaryId.length) DO
	IF binaryId[i] = '. THEN EXIT;
	Strings.AppendChar[moduleId, binaryId[i]];
	ENDLOOP;
    InitializePackedString[];
    FillInModule[AddName[moduleId], altoCode];
    -- fill in interface info
    IF interfaceId = NIL THEN export _ NIL
    ELSE {
      dName: BcdDefs.NameRecord = AddName[interfaceId];
      size, entry: CARDINAL;
      [defsFile.version, symbols] _
	TableCommand.FindInterface[interfaceId, fileId
	 ! TableCommand.BadInterface => {
	    OPEN PGSConDefs;
	    seterrstream[];  outeol[1]; 
	    outstring[id]; outstring[" cannot be opened"L];
	    GO TO fail}];
      defsFile.name _ IF fileId = NIL THEN dName ELSE AddName[fileId];
      [size, entry] _ TableCommand.FindItem[symbols, moduleId
	 ! TableCommand.BadInterface => {
	    OPEN PGSConDefs;
	    seterrstream[];  outeol[1]; 
	    outstring[moduleId]; outstring[" not found"L];
	    GO TO fail}];
      FillInExport[dName, size, entry];
      EXITS
	fail => {
	  OPEN PGSConDefs;
	  outstring[" -- SELF used"L];
	  outeol[2]; resetoutstream[]; warningsLogged _ TRUE;
	  export _ NIL}};
    FillInHeader[]; -- Do this after all strings entered
    WriteBcd[out];
    FileStream.SetIndex[out, Environment.bytesPerPage]};

  FixupBcdHeader: PUBLIC PROC = {
    bytesPerPage: CARDINAL = Environment.bytesPerPage;
    endIndex: StreamIndex _ FileStream.GetIndex[out];
    nBytes: CARDINAL = endIndex - bytesPerPage;
--  IF export # NIL THEN RETURN;	** from ModuleMaker ??
    module.code.length _ nBytes;
    codeSeg.pages _ Spaces.PagesForWords[(nBytes + (bytesPerWord-1))/bytesPerWord];
    IF bcdHeader.nExports = 0 THEN {
      startIndex: StreamIndex;
      symbolBytes: CARDINAL;
      UNTIL (startIndex _ FileStream.GetIndex[out]) MOD bytesPerPage = 0 DO
	out.PutByte[0] ENDLOOP;
      symbolSeg _ [
          class: symbols, file: BcdDefs.FTSelf,
          base: codeSeg.base+codeSeg.pages, pages: , extraPages: 0];
      PGSConDefs.WriteSymbols[out, moduleId];
      endIndex _ FileStream.GetIndex[out];
      symbolBytes _ endIndex-startIndex;
      symbolSeg.pages _
	Spaces.PagesForWords[(symbolBytes + (bytesPerWord-1))/bytesPerWord]};
    FileStream.SetIndex[out, moduleIndex];
    out.PutBlock[[@module, 0, SIZE[direct BcdDefs.MTRecord]*bytesPerWord]];
    FileStream.SetIndex[out, segIndex];
    out.PutBlock[[@codeSeg, 0, SIZE[BcdDefs.SGRecord]*bytesPerWord]];
    out.PutBlock[[@symbolSeg, 0, SIZE[BcdDefs.SGRecord]*bytesPerWord]];
    FileStream.SetIndex[out, endIndex]};

  }.