-- file Sequencer.mesa
-- last modified by Satterthwaite, July 27, 1983 2:51 pm
-- last modified by Russ Atkinson, 10-Dec-80 10:53:50

DIRECTORY
  CBinary: TYPE USING [DebugTab, ErrorTab, MesaTab],
  Alloc: TYPE USING [
    Handle, Selector, TableInfo, Chunkify, Create, Destroy, Failure, Reset],
  CharIO: TYPE USING [PutChar, PutOctal, PutString],
  CompilerOps: TYPE USING [LetterSwitches, StreamId, Transaction],
  CompilerUtil: TYPE USING [
    TableId,
    InstallParseTables, PrefillSymbols, P1Unit, P2Unit, P3Unit, P3Postlude, P4Unit, P5module,
    EndObjectFile, PrintBodies, PrintSymbols, PrintTree, StartObjectFile, TableOut],
  ComData: TYPE USING [
    bcdSeg, codeSeg, compilerVersion, globalFrameSize, interface, linkCount, matched,
    nErrors, nWarnings, objectBytes, objectFile, objectStamp, objectVersion,
    ownSymbols, pattern, source, sourceTokens, symSeg, switches, table, textIndex, zone],
  Copier: TYPE USING [FileInit, FileReset],
  File: TYPE USING [nullCapability],
  FileParmOps: TYPE USING [AcquireOutput, ReleaseOutput],
  FileStream: TYPE USING [Create, SetLength],
  LiteralOps: TYPE USING [Initialize, Finalize],
  Log: TYPE USING [Error],
  OSMiscOps: TYPE USING [
    BcdCreateTime, GenerateUniqueId, GetTableBase, --ImageId,--
    MergeStamps, SignalArgs, StampToTime, TimeToStamp],
  Stream: TYPE USING [Handle, Delete, SendNow],
  Strings: TYPE USING [String, AppendString],
  SymLiteralOps: TYPE USING [Finalize, Initialize],
  SymbolPack: TYPE,
  SymbolOps: TYPE USING [Finalize, Initialize],
  SymbolSegment: TYPE USING [Tables, treeType],
  SymbolTable: TYPE USING [Forget, anySpan],
  Time: TYPE USING [Append, Unpack],
  TimeStamp: TYPE USING [Stamp],
  Tree: TYPE USING [Link],
  TreeOps: TYPE USING [Finalize, Initialize, PopTree, Reset];

Sequencer: MONITOR
    IMPORTS
      Alloc, CBinary, CharIO, CompilerUtil, Copier, FileStream, FileParmOps, Log, LiteralOps,
      OSMiscOps, Stream, SymLiteralOps, SymbolOps, SymbolTable, Strings, Time, TreeOps, 
      ownSymbols: SymbolPack, dataPtr: ComData
    EXPORTS CompilerOps, CompilerUtil = { 

-- scratch region and scratch zone management

  zone: UNCOUNTED ZONE;
  table: Alloc.Handle _ NIL;

  AcquireZone: PUBLIC PROC RETURNS [UNCOUNTED ZONE] = {
    RETURN [zone]};
    

-- stream management

  StreamId: TYPE = CompilerOps.StreamId;
  TransactionPtr: TYPE = POINTER TO CompilerOps.Transaction;

  getStream: PROC [StreamId] RETURNS [Stream.Handle];

  streamInfo: ARRAY StreamId[$source .. $log] OF RECORD [
    access: {read, write},
    stream: Stream.Handle,
    status: RECORD [count: NAT, open: BOOL]];

  AcquireStream: PUBLIC PROC [id: StreamId] RETURNS [stream: Stream.Handle] = {
    IF streamInfo[id].stream = NIL THEN {
      streamInfo[id].stream _ getStream[id];
      streamInfo[id].status _ [count:0, open:TRUE]};
    stream _ streamInfo[id].stream;
    IF streamInfo[id].status = [count: 0, open: FALSE] THEN
      streamInfo[id].status.open _ TRUE;
    streamInfo[id].status.count _ streamInfo[id].status.count + 1};

  ReleaseStream: PUBLIC PROC [id: StreamId] = {
    streamInfo[id].status.count _ streamInfo[id].status.count - 1;
    IF streamInfo[id].status.count = 0 THEN {
      IF streamInfo[id].access = $write THEN streamInfo[id].stream.SendNow[];
      streamInfo[id].status.open _ FALSE}};


-- table segment management

  tableBase: ARRAY CompilerUtil.TableId [$error..$debug] OF LONG POINTER;
  
  AcquireTable: PUBLIC PROC [id: CompilerUtil.TableId] RETURNS [LONG POINTER] = {
    RETURN [tableBase[id]]};

  ReleaseTable: PUBLIC PROC [id: CompilerUtil.TableId] = {};


-- compiler inquiries

  DefaultSwitches: PUBLIC PROC RETURNS [CompilerOps.LetterSwitches] = {
    RETURN [[
      TRUE , -- A  Address fault for NIL checks
      TRUE , -- B  Bounds checking
      TRUE , -- C  compile for Cedar (special FORK)
      FALSE, -- D  call Debugger on compiler error (FALSE => just log error)
      TRUE , -- E  fixed (big Eval stack)
      TRUE , -- F  Floating point microcode
      TRUE , -- G  TRUE => loG goes to compiler.log, FALSE => use foo.errlog
      FALSE, -- H  unused
      FALSE, -- I  unused
      FALSE, -- J  cross-Jumping optimization
      FALSE, -- K  unused
      TRUE , -- L  allocate space for code Links
      TRUE , -- M  reference counting Microcode
      TRUE , -- N  Nil pointer checking
      FALSE, -- O  unused
      FALSE, -- P  Pause after compilation with errors
      FALSE, -- Q  unused
      FALSE, -- R  unused
      TRUE , -- S  Sort (by static frequency) global vars & entry indexes
      FALSE, -- T  unused
      FALSE, -- U  uninitialized variable checking
      FALSE, -- V  unused
      TRUE , -- W  log Warning messages
      FALSE, -- X  unused
      FALSE, -- Y  complain about KFCB
      FALSE  -- Z  unused
      ]]};

  CompilerVersion: PUBLIC PROC RETURNS [TimeStamp.Stamp] = {
    RETURN [dataPtr.compilerVersion]};

  AppendHerald: PUBLIC PROC [s: Strings.String] = {
    t: STRING = [20];
    Time.Append[t, Time.Unpack[[OSMiscOps.BcdCreateTime[]]]];
    Strings.AppendString[s, "Cedar 5.0a Compiler of "L];
    Strings.AppendString[s, t]};

  
-- compiler sequencing

  pass: CHARACTER ['1..'5];

  ExtendedTables: TYPE = Alloc.Selector[SymbolSegment.Tables.FIRST .. SymbolSegment.Tables.LAST+1];
  
  Initialize: PROC = {
    weights: ARRAY ExtendedTables OF Alloc.TableInfo _ [
      [30], [20], [4], [4], [4], [2], [4], [1], [2], [1], [2], [2], [20]];	-- empirical
    IF table = NIL THEN {
      table _ Alloc.Create[weights: DESCRIPTOR[weights]]; 
      table.Chunkify[SymbolSegment.treeType];
      table.Chunkify[SymbolSegment.Tables.LAST+1]}	-- codeType
    ELSE table.Reset[];
    SymbolOps.Initialize[table, zone];  LiteralOps.Initialize[table, zone];
    TreeOps.Initialize[table, zone]};

  Finalize: PROC [parms: TransactionPtr, ownedObject: BOOL] = {
    parms.objectVersion _ dataPtr.objectVersion;
    parms.interface _ dataPtr.interface;
    parms.matched _ dataPtr.matched AND (dataPtr.nErrors = 0);
    parms.sourceTokens _ dataPtr.sourceTokens;
    parms.nErrors _ dataPtr.nErrors;  parms.nWarnings _ dataPtr.nWarnings;
    parms.objectBytes _ dataPtr.objectBytes;
    parms.objectFrameSize _ dataPtr.globalFrameSize;  
    parms.linkCount _ dataPtr.linkCount;
    parms.bcdPages _ [base: dataPtr.bcdSeg.base, pages: dataPtr.bcdSeg.pages];
    parms.codePages _ [base: dataPtr.codeSeg.base, pages: dataPtr.codeSeg.pages];
    parms.symbolPages _ [base: dataPtr.symSeg.base, pages: dataPtr.symSeg.pages];
    CompilerUtil.EndObjectFile[dataPtr.nErrors=0];
    IF streamInfo[$object].stream # NIL THEN {
      Stream.Delete[streamInfo[$object].stream]; streamInfo[$object].stream _ NIL};
    IF ownedObject AND parms.objectFile # File.nullCapability THEN
      FileParmOps.ReleaseOutput[parms.objectFile];
    TreeOps.Finalize[];  LiteralOps.Finalize[];  SymbolOps.Finalize[];
    table.Reset[]};

  Debug: PROC [tree, symbols: PROC [Alloc.Handle]] = {
    tree[table]; symbols[table]};


  Punt: PUBLIC ERROR = CODE;


  started: BOOL _ FALSE;
  
  Start: PUBLIC ENTRY PROC [scratchZone: UNCOUNTED ZONE] = {
    IF started THEN Stop[];
    zone _ scratchZone;  table _ NIL;
    started _ TRUE};
    
  Stop: PUBLIC ENTRY PROC = {
    IF started THEN {
      zone _ NIL;
      IF table # NIL THEN {Alloc.Destroy[table]; table _ NIL};
      started _ FALSE}};
      
  DoTransaction: PUBLIC ENTRY PROC [parms: TransactionPtr] = {
    root: Tree.Link;
    msg, signal: UNSPECIFIED;
    debug: BOOL;
    nParseErrors: CARDINAL;
    parsed, aborted: BOOL;
    ownedObject: BOOL _ FALSE;

    PrintTreeRoot: PROC [table: Alloc.Handle] = {
      CompilerUtil.PrintTree[table, root]};
    PrintSymbols: PROC [table: Alloc.Handle] = {
      CompilerUtil.PrintSymbols[table, dataPtr.interface]};
    
    IF ~started THEN RETURN WITH ERROR Punt[];
    getStream _ parms.getStream;
    dataPtr.source _ parms.source;
    dataPtr.objectFile _ parms.objectName;
    dataPtr.switches _ parms.switches;
    dataPtr.matched _ parms.op = replace;
    dataPtr.pattern _ parms.pattern;
    debug _ dataPtr.switches['d];  dataPtr.switches['d] _ FALSE;

    dataPtr.objectVersion _ OSMiscOps.GenerateUniqueId[];
    dataPtr.objectStamp _ OSMiscOps.TimeToStamp[dataPtr.source.version];
    -- encode switches, compiler version (see DIRECTORY processing also)
      dataPtr.objectStamp _ OSMiscOps.MergeStamps[
        dataPtr.objectStamp, OSMiscOps.TimeToStamp[[0, 0, LOOPHOLE[dataPtr.switches]]]];
      dataPtr.objectStamp _ OSMiscOps.MergeStamps[
        dataPtr.objectStamp, OSMiscOps.TimeToStamp[dataPtr.compilerVersion]];

    dataPtr.nErrors _ dataPtr.nWarnings _ 0;  aborted _ FALSE;
    streamInfo[$source] _
      [access: $read, stream: parms.sourceStream, status: [count: 0, open: FALSE]];
    streamInfo[$object] _ streamInfo[$log] _
      [access: $write, stream: NIL, status: [count: 0, open: FALSE]];
    Initialize[];
    dataPtr.table _ table;  dataPtr.zone _ zone;

      BEGIN
      ENABLE { 
	Alloc.Failure => {IF ~debug THEN GO TO storageFull};
	UNWIND => {Finalize[parms, ownedObject]};
	ANY => {
	  IF ~debug THEN {[msg, signal] _ OSMiscOps.SignalArgs[]; GO TO uncaughtSignal}}};

      CompilerUtil.PrefillSymbols[];
      dataPtr.textIndex _ 0;

    -- first pass
      IF parms.startPass # NIL AND ~parms.startPass[1] THEN GO TO cancel;
      pass _ '1;
      parsed _ CompilerUtil.P1Unit[];
      nParseErrors _ dataPtr.nErrors;
      IF ~parsed THEN GO TO failed;
      root _ TreeOps.PopTree[];  TreeOps.Reset[];
      IF parms.debugPass <= 1 THEN Debug[PrintTreeRoot, PrintSymbols];

    -- second pass
      IF parms.startPass # NIL AND ~parms.startPass[2] THEN GO TO cancel;
      pass _ '2;
      root _ CompilerUtil.P2Unit[root];
      IF parms.debugPass <= 2 THEN Debug[PrintTreeRoot, PrintSymbols];

    -- third and fourth passes
      IF parms.startPass # NIL AND ~parms.startPass[3] THEN GO TO cancel;
      SymLiteralOps.Initialize[table];
      Copier.FileInit[
	  [dataPtr.objectVersion, [parms.objectName, 0, parms.objectName.length]],
	  table, zone, parms.fileParms];

	BEGIN
	ENABLE Alloc.Failure => {GO TO noSpace};

	pass _ '3;
	root _ CompilerUtil.P3Unit[root];
	CompilerUtil.P3Postlude[dataPtr.nErrors <= nParseErrors];

	IF parms.debugPass <= 3 THEN Debug[PrintTreeRoot, PrintSymbols];
	IF dataPtr.nErrors > nParseErrors THEN GO TO DeleteFiles;

	dataPtr.objectVersion _ OSMiscOps.StampToTime[dataPtr.objectStamp];
	parms.fileParms.Forget[
	  [dataPtr.objectVersion, [parms.objectName, 0, parms.objectName.length]]];
	IF parms.objectFile = File.nullCapability THEN {
	  parms.objectFile _ FileParmOps.AcquireOutput[parms.objectName];
	  ownedObject _ TRUE}
	ELSE SymbolTable.Forget[[parms.objectFile, SymbolTable.anySpan]];
	IF parms.objectFile # File.nullCapability THEN {
	  streamInfo[$object].stream _ FileStream.Create[parms.objectFile];
	  FileStream.SetLength[streamInfo[$object].stream, 0]};
	CompilerUtil.StartObjectFile[AcquireStream[$object], zone];

	IF parms.startPass # NIL AND ~parms.startPass[4] THEN GO TO subCancel;
	pass _ '4;
	CompilerUtil.P4Unit[root];
	IF parms.debugPass <= 4 THEN Debug[CompilerUtil.PrintBodies, PrintSymbols];
	GO TO DeleteFiles;

	EXITS
	  DeleteFiles => Copier.FileReset[];
	  subCancel => {Copier.FileReset[]; GO TO cancel};
	  noSpace => {Copier.FileReset[]; SymLiteralOps.Finalize[]; GO TO storageFull};
	END;

      IF dataPtr.nErrors # 0 THEN GO TO failed;

    -- fifth pass
      IF ~dataPtr.interface THEN {
	ENABLE UNWIND => {CompilerUtil.EndObjectFile[FALSE]};
	IF parms.startPass # NIL AND ~parms.startPass[5] THEN GO TO cancel;
	pass _ '5;
	CompilerUtil.P5module[]};
      SymLiteralOps.Finalize[];

      IF parms.startPass # NIL AND ~parms.startPass[6] THEN GO TO cancel;
      CompilerUtil.TableOut[table];
--    IF parms.startPass # NIL THEN [] _ parms.startPass[0];
      IF dataPtr.nErrors # 0 THEN GO TO failed;

      EXITS
	failed => aborted _ TRUE;
        cancel => {Log.Error[aborted];  aborted _ TRUE};
	uncaughtSignal => {
	  OPEN CharIO;
	  errorStream: Stream.Handle = AcquireStream[$log];
	  Log.Error[compilerError];  aborted _ TRUE;
	  PutString[errorStream, "in Pass "L];  PutChar[errorStream, pass];
	  PutString[errorStream, ", signal = "L];  PutOctal[errorStream, signal];
	  PutString[errorStream, ", message = "L];  PutOctal[errorStream, msg];
	  PutChar[errorStream, '\n];
	  ReleaseStream[$log];
	  Finalize[parms, ownedObject];  RETURN WITH ERROR Punt[]};
	storageFull => StorageProblem["overflow"L];
      END;

    Finalize[parms, ownedObject]};

  StorageProblem: PROC [message: STRING] = {
    OPEN CharIO;
    errorStream: Stream.Handle = AcquireStream[$log];
    dataPtr.nErrors _ dataPtr.nErrors+1;
    PutString[errorStream, "\nStorage "L];  PutString[errorStream, message];
    PutString[errorStream, " in Pass "L];  PutChar[errorStream, pass];
    PutChar[errorStream, '\n];
    ReleaseStream[$log]};


-- * * * * * *  M A I N   B O D Y   C O D E  * * * * * *

  START dataPtr; 	-- initialize STRING variables, etc.
  START ownSymbols;
  dataPtr.ownSymbols _ ownSymbols;
--dataPtr.compilerVersion _ OSMiscOps.ImageId[];
  dataPtr.compilerVersion _ [net: 0Ch, host: 0Ch, time: 0F0000005h]; -- Cedar release

  CompilerUtil.InstallParseTables[OSMiscOps.GetTableBase[CBinary.MesaTab]] ;
  tableBase[$error] _ OSMiscOps.GetTableBase[CBinary.ErrorTab];
  tableBase[$debug] _ OSMiscOps.GetTableBase[CBinary.DebugTab];

  }.