
<<file PGSBcd.mesa>>
<<last modified by Satterthwaite, November 2, 1982 11:19 am>>
<<Last Edited by: Maxwell, August 8, 1983 2:34 pm>>

DIRECTORY
BcdDefs: TYPE,
FileSegment: TYPE USING [Pages],
IO: TYPE USING [GetIndex, SetIndex, STREAM, PutChar, UnsafePutBlock],
PGSConDefs: TYPE USING [
objectVersion, outeol, outstring, pgsVersion, resetoutstream, seterrstream,
sourceName, sourceVersion, warningsLogged, WriteSymbols],
PrincOps: TYPE USING [bytesPerPage, bytesPerWord, wordsPerPage],
PrincOpsUtils: TYPE USING [LowHalf],
Rope: TYPE USING [Cat, Find, Flatten, FromChar, Length, ROPE, Substr],
TableCommand: TYPE USING [FindInterface, FindItem, BadInterface],
UnsafeStorage: TYPE USING [GetSystemUZone, NewUObject];

PGSBcd: PROGRAM
IMPORTS IO, PGSConDefs, PrincOpsUtils, Rope, TableCommand, UnsafeStorage
EXPORTS PGSConDefs = {

StreamIndex: TYPE = INT; -- FileStream.FileByteIndex
bytesPerWord: CARDINAL = PrincOps.bytesPerWord;

<<BCD construction>>

bcdHeader: BcdDefs.BCD;
module: BcdDefs.MTRecord.direct;
export: BcdDefs.EXPHandle;
defsFile: BcdDefs.FTRecord;
codeSeg, symbolSeg: BcdDefs.SGRecord;
ssb: Rope.ROPE;

out: IO.STREAM;
moduleIndex, segIndex: StreamIndex;    -- for fixup
moduleId: Rope.ROPE;
systemZone: UNCOUNTED ZONE _ UnsafeStorage.GetSystemUZone[];


InitializePackedString: PROC = {ssb _ Rope.FromChar[LOOPHOLE[0]]};
<<ssb.string.length _ 1; ssb.size[1] _ 0};>>

AddName: PROC [n: Rope.ROPE] RETURNS [name: BcdDefs.NameRecord] = {
IF n = NIL THEN name _ BcdDefs.NullName
ELSE {
lengthChar: CHAR _ PrincOpsUtils.LowHalf[n.Length[]];
name _ BcdDefs.NameRecord[ssb.Length[]+1];
ssb _ Rope.Cat[ssb, Rope.FromChar[lengthChar], n]};
RETURN};

FillInModule: PROC [name: BcdDefs.NameRecord, altoCode: BOOL] = {
OPEN BcdDefs;
module _ MTRecord[
name: name, namedInstance: FALSE, initial: FALSE,
file: FTSelf, linkLoc: frame, config: CTNull,
code: [
sgi: SGIndex.FIRST, linkspace: FALSE, packed: FALSE,
offset: 0, length: 0],
sseg: SGIndex.FIRST+SGRecord.SIZE,
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 _ UnsafeStorage.NewUObject[BcdDefs.EXPRecord.SIZE+size, systemZone];
export^ _ BcdDefs.EXPRecord[
name: name, size: size, port: interface,
namedInstance: FALSE, typeExported: FALSE,
file: BcdDefs.FTIndex.FIRST, 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..BcdDefs.BCD.SIZE) 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 _ BcdDefs.BCD.SIZE;
h.ssOffset _ BcdDefs.BCD.SIZE;
h.ssLimit _ StringBody[ssb.Length[]].SIZE;    -- all strings must be entered by now
h.mtOffset _ h.ssOffset + LOOPHOLE[h.ssLimit, CARDINAL];
h.mtLimit _ BcdDefs.MTIndex.FIRST + BcdDefs.MTRecord.direct.SIZE;
h.sgOffset _ h.mtOffset + LOOPHOLE[h.mtLimit, CARDINAL];
h.sgLimit _ BcdDefs.SGIndex.FIRST + 2*BcdDefs.SGRecord.SIZE;
IF export # NIL THEN {
h.ftOffset _ h.sgOffset + LOOPHOLE[h.sgLimit, CARDINAL];
h.ftLimit _ BcdDefs.FTIndex.FIRST + BcdDefs.FTRecord.SIZE;
h.expOffset _ h.ftOffset + LOOPHOLE[h.ftLimit, CARDINAL];
h.expLimit _ BcdDefs.EXPIndex.FIRST + BcdDefs.EXPRecord.SIZE+export.size};
h.rtPages _ [0, 0]};

WriteBcd: PROC [out: IO.STREAM] = {
ssb _ Rope.Flatten[ssb]; -- so we can blt it out
out.UnsafePutBlock[[@bcdHeader, 0, BcdDefs.BCD.SIZE*bytesPerWord]];
out.UnsafePutBlock[[LOOPHOLE[ssb], 0, StringBody[ssb.Length[]].SIZE*bytesPerWord]];
moduleIndex _ IO.GetIndex[out];
out.UnsafePutBlock[[@module, 0, BcdDefs.MTRecord.direct.SIZE*bytesPerWord]];
segIndex _ IO.GetIndex[out];
out.UnsafePutBlock[[@codeSeg, 0, BcdDefs.SGRecord.SIZE*bytesPerWord]];
out.UnsafePutBlock[[@symbolSeg, 0, BcdDefs.SGRecord.SIZE*bytesPerWord]];
IF export # NIL THEN {
out.UnsafePutBlock[[@defsFile, 0, BcdDefs.FTRecord.SIZE*bytesPerWord]];
out.UnsafePutBlock[[export, 0, (BcdDefs.EXPRecord.SIZE+export.size)*bytesPerWord]];
systemZone.FREE[@export]}};

PagesForWords: PROC [nWords: CARDINAL] RETURNS [CARDINAL] = INLINE {
RETURN[(nWords + (PrincOps.wordsPerPage-1))/PrincOps.wordsPerPage]};


<<overall control>>

WriteBcdHeader: PUBLIC PROC [
outStream: IO.STREAM,
tableId, binaryId: Rope.ROPE,    -- file being written
interfaceId, fileId: Rope.ROPE,    -- interface being exported
altoCode: BOOL _ TRUE] = {
symbols: FileSegment.Pages;
out _ outStream;  
IF tableId # NIL THEN moduleId _ tableId
ELSE {
dotIndex: INT _ Rope.Find[binaryId, "."];
IF dotIndex < 0 THEN moduleId _ binaryId 
ELSE moduleId _ Rope.Substr[binaryId, 0, dotIndex]};
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"];
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"];
GO TO fail}];
FillInExport[dName, size, entry];
EXITS
fail => {
OPEN PGSConDefs;
outstring[" -- SELF used"];
outeol[2]; resetoutstream[]; warningsLogged _ TRUE;
export _ NIL}};
FillInHeader[]; -- Do this after all strings entered
WriteBcd[out];
IO.SetIndex[out, PrincOps.bytesPerPage]};

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

}.