-- RCompImpl.mesa
-- last edit by Schmidt, May 4, 1982 1:00 pm
-- last edit by Satterthwaite, January 31, 1983 10:19 am
-- Pilot 6.0/ Mesa 7.0


DIRECTORY
  CompilerOps: TYPE USING [
    AppendHerald, DefaultSwitches, DoTransaction, 
    LetterSwitches, Start, Stop, StreamId, Transaction],
  CWF: TYPE USING [FWF0, FWF1, FWF2, FWF3, FWFC, FWFCR, SetCode, WF0, WF1, WF2],
  Dir: TYPE USING [DepSeq, FileInfo],
  Directory: TYPE USING [DeleteFile, Error, Handle, Lookup, UpdateDates],
  File: TYPE USING [Capability, read],
  FileParms: TYPE USING [
    ActualId, BindingProc, Name, nullActual, nullSymbolSpace, SymbolSpace],
  FileStream: TYPE USING [Create],
  Heap: TYPE USING [systemZone],
  Inline: TYPE USING [DIVMOD, LongDivMod],
  IO: TYPE USING[Handle, PutF, PutChar, rope],
  LongString: TYPE USING [
    AppendChar, AppendSubString, EqualString, EquivalentString, SubStringDescriptor],
  MDComp: TYPE USING [SetVersAndModulename],
  MDDB: TYPE USING [GetBcdDepSeq, GetSrcDepSeq],
  MDMain: TYPE USING [DebugWP],
  MDModel: TYPE USING [
    EraseCacheEntry, FoldInParms, GetFileInfo, GetSrcCreate, LISTSymbol, LocForType,
    LOCSymbol, LookupFileInfo, MODELSymbol, STRINGSymbol, SymbolSeq, TYPESymbol],
  MDUtil: TYPE USING [AcquireMsgLock, IOConfirm, ReleaseMsgLock],
  RComp: TYPE USING [],
  Rope: TYPE USING [Text],
  Runtime: TYPE USING [IsBound, RunConfig],
  Stream: TYPE USING [Delete, Handle, PutChar],
  Subr: TYPE USING [AbortMyself, NewFile, NewStream, Write],
  Time: TYPE USING [Current],
  TimeStamp: TYPE USING [Null],
  TypeScript: TYPE USING[TS, UserAbort],
  ViewerClasses: TYPE USING [Viewer],
  ViewerOps: TYPE USING [CreateViewer, FindViewer, OpenIcon, RestoreViewer, SetNewFile],
  WindowManager: TYPE USING [WaitCursor, UnWaitCursor];
							
RCompImpl: PROGRAM 
  IMPORTS
      CompilerOps, CWF, Directory, FileStream, Heap, Inline, IO,
      LongString, MDComp, MDDB, MDMain, MDModel, MDUtil, Runtime, Stream, Subr,
      Time, TypeScript, ViewerOps, WindowManager
  EXPORTS RComp = {

 -- MDS Usage!
  sourcesh: Stream.Handle _ NIL;		-- source input file
  logsh: Stream.Handle _ NIL;		-- "Compiler.Log"
  ttyTypeScript: TypeScript.TS _ NIL;
  msgout: IO.Handle _ NIL;
  good, warn, err: CARDINAL _ 0;
  compilerStarted: BOOL _ FALSE;
  timeCompilerStarted: LONG CARDINAL _ 0;
 -- endof MDS

  Compile: PUBLIC PROC[symbolseq: MDModel.SymbolSeq, sploc: MDModel.LOCSymbol, 
	tryreplacement: BOOL, oldbcdfilename: LONG STRING,
	spmodel: MDModel.MODELSymbol, confirm: REF BOOL, typeScript: TypeScript.TS,
	ttyin, ttyout, msgwindow: IO.Handle] 
      RETURNS[errors, warnings, replaceable, declined: BOOL] = {
    t: CompilerOps.Transaction;
    cap: File.Capability;
    splist: MDModel.LISTSymbol _ sploc.parmlist;
    onestarttime: LONG CARDINAL;
    dontconfirm: BOOL = (IF confirm = NIL THEN FALSE ELSE ~(confirm^));
    loadedOk: BOOL;
    fi: Dir.FileInfo _ NIL;
    oldBcdDepSeq: Dir.DepSeq _ NIL;

    -- inherits spmodel, sploc, symbolseq
    -- splist is initailized once

    DirectoryBinding: PROC[
	formalId, formalType: FileParms.Name, defaultLocator: LONG STRING,
	binder: FileParms.BindingProc] = {
      typename: STRING _ [40];
      LongString.AppendSubString[typename, @formalType];
      WHILE splist ~= NIL AND ~ISTYPE[splist.first, MDModel.TYPESymbol] DO
	splist _ splist.rest;
	ENDLOOP;
      WITH splist.first SELECT FROM
        sptype: MDModel.TYPESymbol => {
	  sptypeloc: MDModel.LOCSymbol;
	  bcdFileName: STRING _ [40];
	  fiInner: Dir.FileInfo;
	  IF ~LongString.EqualString[sptype.typeName, typename] THEN {
	    CWF.WF2["Error - %s not in correct parameter order (should be %s).\n"L, 
				typename, sptype.typeName];
	    RETURN};
	  sptypeloc _ sptype.LocForType[];
	  IF sptypeloc = NIL THEN {
	    CWF.WF1["Error - %s has no value.\n"L, typename]; RETURN};
	  fiInner _ sptypeloc.GetFileInfo[];
	  IF fiInner.bcdVers = TimeStamp.Null THEN
	    MDComp.SetVersAndModulename[sptypeloc];
	  binder[[
	      version: fiInner.bcdVers,
	      locator: [base: fiInner.bcdFileName, offset: 0, length: fiInner.bcdFileName.length]]];
	  splist _ splist.rest};
        ENDCASE => CWF.WF1["Error - %s cannot be found on parameter list.\n"L, typename]};
		

    -- called after DirectoryBinding, unless it is a hidden Directory parameter
    -- or is the old bcd in replacement mode
    DirectoryAcquire: PROC[type: LongString.SubStringDescriptor, actual: FileParms.ActualId]
	RETURNS [ss: FileParms.SymbolSpace] = {
      depseq: Dir.DepSeq;
      typename: STRING _ [40];
      bcdFileName: STRING _ [40];
      fiInner: Dir.FileInfo;

      {
      LongString.AppendSubString[bcdFileName, @actual.locator];
      IF bcdFileName[bcdFileName.length-1] = '. THEN
	bcdFileName.length _ bcdFileName.length - 1;
      IF LongString.EquivalentString[oldbcdfilename, bcdFileName] THEN {
	IF oldBcdDepSeq = NIL THEN ERROR;
	RETURN[oldBcdDepSeq.symbolSpace]};
      ss _ FileParms.nullSymbolSpace;
      LongString.AppendSubString[typename, @type];
      FOR plist: MDModel.LISTSymbol _ sploc.parmlist, plist.rest UNTIL plist = NIL DO
	WITH plist.first SELECT FROM
	  sptype: MDModel.TYPESymbol => {
	    sptypeloc: MDModel.LOCSymbol = sptype.LocForType[];
	    IF
	      sptypeloc ~= NIL
	      AND (fiInner _ sptypeloc.GetFileInfo[]) ~= NIL
	      AND fiInner.bcdVers = actual.version 
	      AND LongString.EqualString[fiInner.bcdFileName, bcdFileName]
	    THEN GOTO foundIt};
	  ENDCASE => NULL;
	ENDLOOP;
      -- compiler can discover hidden definitions and not call DirectoryBinding,
      -- so we must be prepared to add it at this point
      CWF.FWF3[
        MDMain.DebugWP,
        "Looking up directory entry (type %s, file %s) for %s.\n"L,
        typename, bcdFileName, fi.bcdFileName];
      fiInner _ MDModel.LookupFileInfo[bcdFileName, actual.version];
      IF fiInner = NIL THEN {
	CWF.WF2["Error - cannot find %s of %v in model.\n"L, bcdFileName, @actual.version];
	RETURN[FileParms.nullSymbolSpace]};
      EXITS
	foundIt => NULL;
      };

      depseq _ MDDB.GetBcdDepSeq[fiInner, 0];
      IF depseq = NIL THEN {
	CWF.FWF1[MDMain.DebugWP, "DirectoryAcquire: Can't open %s.\n"L, bcdFileName];
	RETURN};
      IF actual.version = TimeStamp.Null THEN
	CWF.FWF1[
	  MDMain.DebugWP, "DirectoryAcquire: Version of %s is null.\n"L, bcdFileName]
      ELSE IF actual.version ~= depseq.bcdVers THEN 
	CWF.FWF3[
	  MDMain.DebugWP,
	  "DirectoryAcquire: Versions don't match %s: cache says %v, compiler wants %v\n"L, 
	  bcdFileName, @depseq.bcdVers, @actual.version];
      IF depseq.symbolSpace = FileParms.nullSymbolSpace THEN ERROR;
      RETURN[depseq.symbolSpace]};
	
    DeleteBadBcd: PROC = {
      IF t.objectName ~= NIL THEN Directory.DeleteFile[t.objectName];
      t.objectName _ NIL;
      MDModel.EraseCacheEntry[fi: fi, src: FALSE]};
	
    Cleanup: PROC = {
      IF t.sourceStream ~= NIL THEN Stream.Delete[t.sourceStream];
      t.sourceStream _ sourcesh _ NIL};
	
    {
    ENABLE
      UNWIND => {DeleteBadBcd[]; Cleanup[]};
    explicitSortSwitch: BOOL _ FALSE;
    srcDepSeq: Dir.DepSeq;

    msgout _ msgwindow;
    ttyTypeScript _ typeScript;
    errors _ warnings _ declined _ TRUE;
    replaceable _ FALSE;
    t.sourceStream _ NIL;
    t.objectName _ NIL;
    fi _ sploc.GetFileInfo[];
    IF AskTheUser[fi.srcFileName, ttyin, ttyout, dontconfirm] THEN RETURN;
    declined _ FALSE;
    -- make sure the compiler is loaded, etc.
    IF ~compilerStarted THEN {
      loadedOk _ StartBatchCompile[];
      IF ~loadedOk THEN RETURN};
    -- set up Transaction record contents
    t.op _ IF tryreplacement THEN $replace ELSE $compile;
    t.source _ [
        version: [net: 0, host: 0, time: MDModel.GetSrcCreate[fi]],
	locator: [base: fi.srcFileName, offset: 0, length: fi.srcFileName.length]];
    cap _ Directory.UpdateDates[fi.srcCap, File.read];
    sourcesh _ t.sourceStream _ FileStream.Create[cap];
    t.fileParms _ [DirectoryBinding, DirectoryAcquire, DirectoryRelease, DirectoryForget];
    t.switches _ CompilerOps.DefaultSwitches[];
    srcDepSeq _ MDDB.GetSrcDepSeq[fi, t.source.version.time];
    IF ~srcDepSeq.isdefns THEN {
      -- switches only matter for implementors
      FOR plist: MDModel.LISTSymbol _ sploc.parmlist, plist.rest WHILE plist ~= NIL DO
	WITH plist.first SELECT FROM
	  spstr: MDModel.STRINGSymbol =>
	    [t.switches, explicitSortSwitch] _ MDModel.FoldInParms[spstr.strval];
	  ENDCASE => NULL;
	ENDLOOP;
      IF ~explicitSortSwitch THEN t.switches['s] _ FALSE};
    IF tryreplacement THEN {
      IF fi.bcdVers = TimeStamp.Null THEN ERROR;
      t.pattern _ [
          version: fi.bcdVers, 
          locator: [base: oldbcdfilename, offset: 0, length: oldbcdfilename.length]];
      oldBcdDepSeq _ fi.bcdDepSeq;	-- will get old BCD!
      IF oldBcdDepSeq = NIL THEN ERROR;
      -- if there is old bcd, and the user did not specify explicitly /s or /-s
      -- then sort as the old bcd was sorted
      IF ~explicitSortSwitch THEN t.switches['s] _ oldBcdDepSeq.switches['s]}
    ELSE t.pattern _ FileParms.nullActual;
    t.objectName _ fi.bcdFileName;
    t.objectFile _ Subr.NewFile[fi.bcdFileName, Subr.Write, 10];
    t.debugPass _ LAST[CARDINAL];
    t.getStream _ LogGetStream;
    t.startPass _ CompilerPass;
    PrintStartOne[@t];
    onestarttime _ Time.Current[];
    -- these are here to hide them from the user
    t.switches['d] _ TRUE;	-- debugging
    t.switches['g] _ FALSE;	-- log is always Compiler.Log
    MDUtil.AcquireMsgLock[];
    -- actually call the Compiler!
    CompilerOps.DoTransaction[@t ! UNWIND => MDUtil.ReleaseMsgLock[]];
    MDUtil.ReleaseMsgLock[];
    PrintStopOne[@t, onestarttime];
    replaceable _ tryreplacement AND t.matched;
    errors _ t.nErrors # 0;
    warnings _ t.nWarnings # 0;
    IF errors THEN err _ err + 1;
    IF warnings THEN warn _ warn + 1;
    IF ~errors AND ~warnings THEN good _ good + 1;
    IF ~errors THEN fi.bcdVers _ t.objectVersion
    ELSE DeleteBadBcd[];
    Cleanup[];
    }};

  StopBatchCompile: PUBLIC PROC RETURNS[nOk, nWarn, nErr: CARDINAL] = {
    log: ViewerClasses.Viewer;
    IF ~compilerStarted THEN RETURN[0, 0, 0];	-- noop call; compiler not running
    IF good # 0 THEN CWF.FWF1[LogWP, " %u successful; "L, @good];
    IF warn # 0 THEN CWF.FWF1[LogWP, " %u w/warnings; "L, @warn];
    IF err # 0 THEN CWF.FWF1[LogWP, " %u w/errors; "L, @err];
    timeCompilerStarted _ Time.Current[] - timeCompilerStarted;
    CWF.FWF1[LogWP, "\nTotal elapsed time %y.\n"L, @timeCompilerStarted];
    Stream.Delete[logsh];  logsh _ NIL;
    CompilerOps.Stop[];
    compilerStarted _ FALSE;
    log _ ViewerOps.FindViewer["Compiler.Log"];
    IF log ~= NIL THEN ViewerOps.RestoreViewer[log];
    IF warn > 0 OR err > 0 THEN {
      IF log ~= NIL THEN ViewerOps.OpenIcon[log]
      ELSE CreateANewViewer["Compiler.log"]};
    msgout _ NIL;
    RETURN[good, warn, err]};


 -- local procedures

  CreateANewViewer: PROC [name: Rope.Text] = {
    viewer: ViewerClasses.Viewer;
    WindowManager.WaitCursor[];
    viewer _ ViewerOps.CreateViewer[
	  flavor: $Text,
	  info: [name: name, file: LOOPHOLE[name], iconic: FALSE, column: left]];
    MDUtil.AcquireMsgLock[];
    msgout.PutF["\nCreated Viewer: %s\n", IO.rope[name]
		! UNWIND => {MDUtil.ReleaseMsgLock[]}];
    MDUtil.ReleaseMsgLock[];
    ViewerOps.SetNewFile[viewer];
    WindowManager.UnWaitCursor[]};

  StartBatchCompile: PROC RETURNS[loadedOk: BOOL] = {
    herald: STRING _ [100];
    good _ warn _ err _ 0;
    logsh _ NIL;
    loadedOk _ LoadCompiler[];
    timeCompilerStarted _ Time.Current[];
    IF ~loadedOk THEN RETURN;
    Directory.DeleteFile["Compiler.Log"L
	! Directory.Error => {CONTINUE}];
    [] _ LogGetStream[log];	-- creates new log
    CompilerOps.AppendHerald[herald];
    CWF.WF2["%s\n%lt\n"L, herald, @timeCompilerStarted];
    CWF.FWF2[LogWP, "%s\n%lt\n"L, herald, @timeCompilerStarted];
    CompilerOps.Start[Heap.systemZone];
    compilerStarted _ TRUE};

  AskTheUser: PROC[filename: LONG STRING, ttyin, ttyout: IO.Handle, dontconfirm: BOOL]
      RETURNS[declined: BOOL _ TRUE] = {
    ch: CHAR;
    -- ask the user if he really wants it compiled
    CWF.WF1["Compile %s ... "L, filename];
    ch _ IF dontconfirm THEN 'y ELSE MDUtil.IOConfirm['y, ttyin, ttyout];
    IF ch = 'q THEN {
      CWF.WF0["Quit.\n"L]; SIGNAL Subr.AbortMyself};
    IF ch = 'y THEN {
      declined _ FALSE; CWF.WF0["Yes.\n"L]}
    ELSE CWF.WF0["No.\n"L]};

  DirectoryRelease: PROC[ss: FileParms.SymbolSpace] = {};

  DirectoryForget: PROC[actual: FileParms.ActualId] = {};

  PrintStartOne: PROC[t: POINTER TO CompilerOps.Transaction] = {
    swstr: STRING _ [30];
    CWF.FWF1[MsgWP, "Compiling: %s"L, t.source.locator.base];
    CWF.FWF1[LogWP, "\nCommand: %s"L, t.source.locator.base];
    ProduceDifferentialSwitches[swstr, t.switches];
    CWF.FWF1[LogWP, "%s\n"L, swstr];
    CWF.FWF0[MsgWP, swstr]};

  ProduceDifferentialSwitches: PROC[swstr: LONG STRING, sw: CompilerOps.LetterSwitches] = {
    standardSwitches: CompilerOps.LetterSwitches _ CompilerOps.DefaultSwitches[];
    first: BOOL _ TRUE;
    swstr.length _ 0;
    FOR c: CHAR IN ['a .. 'z] DO
      sd: BOOL = (IF c = 'p THEN FALSE ELSE standardSwitches[c]);
      IF sw[c] ~= sd THEN {
	IF first THEN {first _ FALSE; LongString.AppendChar[swstr, '/]};
	IF sd THEN LongString.AppendChar[swstr, '-];
	LongString.AppendChar[swstr, c]};
      ENDLOOP};

  PrintStopOne: PROC[
      t: POINTER TO CompilerOps.Transaction, oneStartTime: LONG CARDINAL] = {
    -- first MsgSW
    IF t.nErrors > 0 THEN 
      CWF.FWF1[MsgWP, "%u errors"L, @t.nErrors]
    ELSE CWF.FWF0[MsgWP, "no errors"L];
    IF t.nWarnings > 0 THEN CWF.FWF1[MsgWP, ", %u warnings"L, @t.nWarnings];
    CWF.FWFCR[MsgWP];
    -- now log
    CWF.FWF1[LogWP, "%s -- "L, t.source.locator.base];
    IF t.nErrors > 0 THEN {
      CWF.FWF1[LogWP, " aborted, %u errors"L, @t.nErrors];
      IF t.nWarnings > 0 THEN CWF.FWF1[LogWP, " and %u warnings"L, @t.nWarnings];
      oneStartTime _ Time.Current[] - oneStartTime;
      CWF.FWF1[LogWP, ", time: %y.\n\n"L, @oneStartTime]}
    ELSE {
      oneStartTime _ Time.Current[] - oneStartTime;
      CWF.FWF2[LogWP, "source tokens: %u, time: %y"L, @t.sourceTokens, @oneStartTime];
      IF t.objectBytes > 0 THEN 
	CWF.FWF3[LogWP, "\n  code bytes: %u, links: %u, global frame words: %u"L,
	  @t.objectBytes, @t.linkCount, @t.objectFrameSize];
      IF t.nWarnings > 0 THEN CWF.FWF1[LogWP, "\n%u warnings"L, @t.nWarnings];
      CWF.FWF0[LogWP, "\n\n"L]}};

  LoadCompiler: PROC RETURNS[success: BOOL _ TRUE] = {
    cap: File.Capability;
    success _ TRUE;
    IF Runtime.IsBound[CompilerOps.Start] THEN RETURN;  -- already loaded
    CWF.WF0["Loading Compiler ... "L];
    {    
    ENABLE ANY => { CWF.WF0["failed.\n"L]; GOTO out};
    cap _ Directory.Lookup["compiler.bcd"L];
    Runtime.RunConfig[file: cap, offset: 1, codeLinks: TRUE];
    CWF.WF0["done.\n"L];
    EXITS
      out => success _ FALSE;
    }};

  LogGetStream: PROC[sid: CompilerOps.StreamId] RETURNS[sh: Stream.Handle] = {
    IF sid = source THEN RETURN[sourcesh];	-- temporary
    IF sid ~= log THEN ERROR;
    IF logsh = NIL THEN logsh _ Subr.NewStream["Compiler.Log"L, Subr.Write];
    sh _ logsh};

  CompilerPass: PROC[p: CARDINAL] RETURNS[goOn: BOOL] = {
    goOn _ ~TypeScript.UserAbort[ttyTypeScript];
    CWF.FWFC[MsgWP, '.]};

  MsgWP: PROC[ch: CHAR] = {msgout.PutChar[ch]};

  LogWP: PROC[ch: CHAR] = {logsh.PutChar[ch]};

  CWFYRoutine: PROC[uns: LONG POINTER, form: LONG STRING, wp: PROC[CHAR]] = {
    time: LONG CARDINAL = LOOPHOLE[uns, LONG POINTER TO LONG CARDINAL]^;
    hr, min, sec: CARDINAL;
    [min, sec] _ Inline.LongDivMod[time, 60];
    [hr, min] _ Inline.DIVMOD[min, 60];
    IF hr > 0 THEN CWF.FWF3[wp, "%u:%02u:%02u"L, @hr, @min, @sec]
    ELSE IF min > 0 THEN CWF.FWF2[wp, "%u:%02u"L, @min, @sec]
    ELSE CWF.FWF1[wp, "%u"L, @sec]};

  CWF.SetCode['y, CWFYRoutine];
  }.