(* Copyright (C) 1992, Digital Equipment Corporation           *)
(* All rights reserved.                                        *)
(* See the file COPYRIGHT for a full description.              *)

(* File: Emit.m3                                               *)
(* Last Modified On Fri Jun 26 10:16:14 PDT 1992 by kalsow     *)
(*      Modified On Wed Feb  6 02:23:40 1991 by muller         *)

MODULE Emit;

IMPORT String, MBuf, Variable, Host, Text, Type;
IMPORT Fmt, Scanner, Scope, Temp, Value, Wr, Word, Target;
IMPORT TextF, Thread, Reel, LReel, EReel, Int;
IMPORT EnumType, ObjectType, OpaqueType, RefType;

CONST
  EndString = '\000';
  IndentGap = 3;
  Margin    = 120;

TYPE
  StreamState = RECORD
    wr        : MBuf.T;
    indent    : INTEGER;
    newline   : BOOLEAN;
    m3Lines   : BOOLEAN;
    breakable : BOOLEAN;
    flushLine : BOOLEAN;
    file      : String.T;
    line      : INTEGER;
    width     : INTEGER;
    shutdown  : PROCEDURE ();
    target    : Wr.T;
  END;

VAR
  x	  : INTEGER;
  fmt     : TEXT;
  streams : ARRAY Stream OF StreamState;
  cur     : StreamState;
  current : Stream;
  digits  := ARRAY [0..15] OF CHAR { '0','1','2','3','4','5','6','7',
                                     '8','9','a','b','c','d','e','f' };

PROCEDURE SetLine () =
  VAR file: String.T;  line: INTEGER;
  BEGIN
    IF (cur.m3Lines) AND (cur.breakable) AND (NOT Host.Clines) THEN
      Scanner.LocalHere (file, line);
      IF (cur.flushLine) THEN
        NewLine ();
	INC (cur.line);
      ELSIF ((file = cur.file) AND (line = cur.line)) OR (line <= 0) THEN
        IF (cur.width <= Margin) THEN
          MBuf.PutChar (cur.wr, ' ');
	  cur.newline   := FALSE;
	  INC (cur.width);
	ELSIF (line > 0) THEN
	  MBuf.PutText (cur.wr, "\n#line ");
	  MBuf.PutInt (cur.wr, line);
          NewLine ();
	ELSE (* line <= 0  ==> line number doesn't matter *)
          NewLine ();
	END;
      ELSIF (file # cur.file) THEN
        MBuf.PutText (cur.wr, "\n#line ");
	IF (line > 0)
	  THEN MBuf.PutInt  (cur.wr, line);
	  ELSE MBuf.PutText (cur.wr, "9999");
	END;
        MBuf.PutText (cur.wr, " \"");
        String.Put (cur.wr, file);
        MBuf.PutChar (cur.wr, '\"');
        NewLine ();
        cur.file := file;
        cur.line := line;      
      ELSIF (cur.line <= line) AND (line <= cur.line+10) THEN
        WHILE (cur.line < line) DO
          NewLine ();
	  INC (cur.line);
	END;
      ELSE
        MBuf.PutText (cur.wr, "\n#line ");
	MBuf.PutInt  (cur.wr, line);
        NewLine ();
        cur.line := line;      
      END;
    END;
  END SetLine;

PROCEDURE NewLine () =
  BEGIN
    MBuf.PutChar (cur.wr, '\n');
    cur.newline := TRUE;
    cur.width   := 0;
  END NewLine;

PROCEDURE X () =
  VAR c: CHAR;  len := Text.Length (fmt);
  BEGIN
    LOOP
      IF (cur.breakable) THEN SetLine () END;
      IF (x >= len) THEN RETURN END;
      (** c := Text.GetChar (fmt, x); **)
      c := fmt[x]; (* IMPORT TextF *)
      CASE c (* x^ *) OF
      | '\n' =>
          IF (Host.Clines) OR (NOT cur.m3Lines) OR (cur.flushLine) THEN
            NewLine ();
	    INC (cur.line);
	    cur.flushLine := FALSE;
	  ELSE
            cur.breakable := TRUE;
	  END;
      | FlushLine =>
          IF (NOT cur.newline) THEN
	    MBuf.PutChar (cur.wr, '\n');
	    INC (cur.line);
	  END;
          cur.newline   := FALSE;
	  cur.breakable := FALSE;
	  cur.flushLine := TRUE;
	  cur.width     := 0;
      | Indent =>
          INC (cur.indent, IndentGap);
      | Outdent =>
          DEC (cur.indent, IndentGap);
      | EndString =>
          RETURN;
      ELSE
        IF (cur.newline) THEN
          FOR i := 1 TO cur.indent DO MBuf.PutChar (cur.wr,' ')  END;
          cur.newline := FALSE;
          cur.width := cur.indent;
        END;
        cur.breakable := FALSE;
	IF (c = Marker) THEN  INC (x); RETURN  END;
        MBuf.PutChar (cur.wr, (* x^ *) c);
        cur.newline := FALSE;
	INC (cur.width);
      END;
      INC (x);
    END;
  END X;

PROCEDURE TT (t: Temp.T) =
  VAR z: INTEGER; zz: TEXT;
  BEGIN
    X ();
    z := x; zz := fmt;
    Temp.Write (t);
    x := z; fmt:= zz;
  END TT;

PROCEDURE V (v: Variable.T) =
  VAR z: INTEGER; t: Temp.T; zz: TEXT;
  BEGIN
    X ();
    z := x; zz := fmt;
    t := Variable.Load (v);
    Temp.Write (t);
    Temp.Free (t);
    x := z; fmt := zz;
  END V;

PROCEDURE PutInt (i: INTEGER) =
  BEGIN
    MBuf.PutInt (cur.wr, i);
    INC (cur.width, 3);
  END PutInt;

PROCEDURE I (i: INTEGER) =
  BEGIN
    X ();
    IF (cur.breakable) THEN SetLine (); cur.breakable := FALSE; END;
    PutInt (i);
  END I;

PROCEDURE C (c: CHAR) =
  VAR n: INTEGER;
  BEGIN
    X ();
    IF (cur.breakable) THEN SetLine (); cur.breakable := FALSE; END;
    IF (c < ' ') OR (c = '\"') OR (c = '\'') OR ('~' < c) OR (c = '\\') THEN
      n := Word.And (ORD (c), 255);
      MBuf.PutChar (cur.wr, '\\');
      MBuf.PutChar (cur.wr, digits[n DIV 64]);  n := Word.And (n, 63);
      MBuf.PutChar (cur.wr, digits[n DIV 8]);   n := Word.And (n, 7);
      MBuf.PutChar (cur.wr, digits[n]);
      INC (cur.width, 4);
    ELSE (* simple graphic character *)
      MBuf.PutChar (cur.wr, c);
      INC (cur.width);
    END;
  END C;

PROCEDURE Q (s: String.T) =
  BEGIN
    X ();
    IF (cur.breakable) THEN SetLine (); cur.breakable := FALSE; END;
    String.PutChars (cur.wr, s);
    INC (cur.width, 4 * String.Length (s));
  END Q;

PROCEDURE S (s: String.T) =
  BEGIN
    X ();
    IF (cur.breakable) THEN SetLine (); cur.breakable := FALSE; END;
    String.Put (cur.wr, s);
    INC (cur.width, String.Length (s));
  END S;

PROCEDURE SS (READONLY ss: String.Stack) =
  BEGIN
    X ();
    IF (cur.breakable) THEN SetLine (); cur.breakable := FALSE; END;
    FOR i := 0 TO ss.top-1 DO
      String.Put (cur.wr, ss.stk[i]);
      INC (cur.width, String.Length (ss.stk[i]));
    END;
  END SS;

PROCEDURE R (r: LONGREAL) =
  VAR t: TEXT;  u: ARRAY [0..50] OF CHAR;  len: INTEGER;
  BEGIN
    X ();
    IF (cur.breakable) THEN SetLine (); cur.breakable := FALSE; END;
    t := Fmt.LongReal (r, 13, Fmt.Style.Sci);
    Text.SetChars (u, t);
    len := Text.Length (t);
    FOR i := 0 TO len - 1 DO
      IF u[i] = 'D' OR u[i] = 'd' OR u[i] = 'E' THEN u[i] := 'e'; EXIT; END;
    END;
    MBuf.PutSub (cur.wr, SUBARRAY (u, 0, len));
    INC (cur.width, len);
  END R;

PROCEDURE N (v: Value.T) =
  VAR z: INTEGER; zz: TEXT;
  BEGIN
    X ();
    z := x; zz := fmt;
    Scope.GenName (v);
    x := z; fmt:= zz;
  END N;

PROCEDURE H (h: INTEGER) =
  VAR buf: ARRAY [0..7] OF CHAR;
  BEGIN
    X ();
    IF (cur.breakable) THEN SetLine (); cur.breakable := FALSE; END;
    FOR i := 7 TO 0 BY -1 DO
      buf [i] := digits [Word.Mod (h, 16)];  h := Word.Divide (h, 16);
    END;
    MBuf.PutSub (cur.wr, buf);
    INC (cur.width, 8);
  END H;

PROCEDURE F (t: Type.T) =
  VAR h := Type.Name (t);  buf: ARRAY [0..7] OF CHAR;
  BEGIN
    X ();
    IF (cur.breakable) THEN SetLine (); cur.breakable := FALSE; END;
    FOR i := 7 TO 0 BY -1 DO
      buf [i] := digits [Word.Mod (h, 16)];  h := Word.Divide (h, 16);
    END;
    MBuf.PutText (cur.wr, "_t");
    MBuf.PutSub (cur.wr, buf);
    INC (cur.width, 10);
  END F;

PROCEDURE L (label: INTEGER) =
  BEGIN
    X ();
    IF (cur.breakable) THEN SetLine (); cur.breakable := FALSE; END;
    MBuf.PutText (cur.wr, "_L");
    INC (cur.width, 2);
    PutInt (label);
  END L;

PROCEDURE Op (f: Format) =
  BEGIN
    fmt := f; x := 0;
    X ();
  END Op;

PROCEDURE OpC (f: Format;  c: CHAR) =
  BEGIN
    fmt := f; x := 0;
    C (c);
    X ();
  END OpC;

PROCEDURE OpQ (f: Format; s: String.T) =
  BEGIN
    fmt := f; x := 0;
    Q (s);
    X ();
  END OpQ;

PROCEDURE OpS (f: Format; s: String.T) =
  BEGIN
    fmt := f; x := 0;
    S (s);
    X ();
  END OpS;

PROCEDURE OpSS (f: Format; s1, s2: String.T) =
  BEGIN
    fmt := f; x := 0;
    S (s1);
    S (s2);
    X ();
  END OpSS;

PROCEDURE OpSI (f: Format; s: String.T; i: INTEGER) =
  BEGIN
    fmt := f; x := 0;
    S (s);
    I (i);
    X ();
  END OpSI;

PROCEDURE OpIS (f: Format; i: INTEGER; s: String.T) =
  BEGIN
    fmt := f; x := 0;
    I (i);
    S (s);
    X ();
  END OpIS;

PROCEDURE OpI (f: Format; i: INTEGER) =
  BEGIN
    fmt := f; x := 0;
    I (i);
    X ();
  END OpI;

PROCEDURE OpII (f: Format; i1, i2: INTEGER) =
  BEGIN
    fmt := f; x := 0;
    I (i1);
    I (i2);
    X ();
  END OpII;

PROCEDURE OpIII (f: Format; i1, i2, i3: INTEGER) =
  BEGIN
    fmt := f; x := 0;
    I (i1);
    I (i2);
    I (i3);
    X ();
  END OpIII;

PROCEDURE OpV (f: Format; v: Variable.T) =
  BEGIN
    fmt := f; x := 0;
    V (v);
    X ();
  END OpV;

PROCEDURE OpL (f: Format; label: INTEGER) =
  BEGIN
    fmt := f; x := 0;
    L (label);
    X ();
  END OpL;

PROCEDURE OpR (f: Format; r: LONGREAL) =
  BEGIN
    fmt := f; x := 0;
    R (r);
    X ();
  END OpR;

PROCEDURE OpN (f: Format; v: Value.T) =
  BEGIN
    fmt := f; x := 0;
    N (v);
    X ();
  END OpN;

PROCEDURE OpH (f: Format; h: INTEGER) =
  BEGIN
    fmt := f; x := 0;
    H (h);
    X ();
  END OpH;

PROCEDURE OpHH (f: Format; h1, h2: INTEGER) =
  BEGIN
    fmt := f; x := 0;
    H (h1);
    H (h2);
    X ();
  END OpHH;

PROCEDURE OpF (f: Format; t: Type.T) =
  BEGIN
    fmt := f; x := 0;
    F (t);
    X ();
  END OpF;

PROCEDURE OpFF (f: Format; t1, t2: Type.T) =
  BEGIN
    fmt := f; x := 0;
    F (t1);
    F (t2);
    X ();
  END OpFF;

PROCEDURE OpFT (f: Format; t: Type.T;  z: Temp.T) =
  BEGIN
    fmt := f; x := 0;
    F  (t);
    TT (z);
    X ();
  END OpFT;

PROCEDURE OpT (f: Format; t: Temp.T) =
  BEGIN
    fmt := f; x := 0;
    TT (t);
    X ();
  END OpT;

PROCEDURE OpTT (f: Format; t1, t2: Temp.T) =
  BEGIN
    fmt := f; x := 0;
    TT (t1);
    TT (t2);
    X ();
  END OpTT;

PROCEDURE OpTTT (f: Format; t1, t2, t3: Temp.T) =
  BEGIN
    fmt := f; x := 0;
    TT (t1);
    TT (t2);
    TT (t3);
    X ();
  END OpTTT;

PROCEDURE OpTI (f: Format; t: Temp.T; i: INTEGER) =
  BEGIN
    fmt := f; x := 0;
    TT (t);
    I (i);
    X ();
  END OpTI;

PROCEDURE OpIT (f: Format; i: INTEGER; t: Temp.T) =
  BEGIN
    fmt := f; x := 0;
    I (i);
    TT (t);
    X ();
  END OpIT;

PROCEDURE OpX (f: Format; t: TEXT) =
  BEGIN
    fmt := f; x := 0;
    X ();
    IF (cur.breakable) THEN SetLine (); cur.breakable := FALSE; END;
    MBuf.PutText (cur.wr, t);
    X ();
  END OpX;

PROCEDURE OpZ   (f: Format;  READONLY ss: String.Stack) =
  BEGIN
    fmt := f; x := 0;
    SS (ss);
    X ();
  END OpZ;

PROCEDURE OpSZ  (f: Format;  s: String.T;  READONLY ss: String.Stack) =
  BEGIN
    fmt := f; x := 0;
    S (s);
    SS (ss);
    X ();
  END OpSZ;

PROCEDURE Zero (tt: Type.T;  READONLY ss: String.Stack) =
  VAR size := Type.Size (tt);  t := Type.Base (tt);  byteSize: INTEGER;
  BEGIN
    IF (size <= 0) THEN
      (* nothing to do *)

    ELSIF (t = Reel.T) OR (t = LReel.T) OR (t = EReel.T) THEN
      OpZ ("@ = 0.0;\n", ss);

    ELSIF (t = Int.T) OR EnumType.Is (t) THEN
      OpZ ("@ = 0;\n", ss);

    ELSIF OpaqueType.Is (t) OR RefType.Is (t) OR ObjectType.Is (t) THEN
      OpZ ("@ = _NIL;\n", ss);

    ELSIF (size MOD Target.CHARSIZE) = 0 THEN
      byteSize := size DIV Target.CHARSIZE;
      CASE byteSize OF
      |  1 => OpZ ("_ZERO1B (& @);\n", ss);
      |  2 => OpZ ("_ZERO1S (& @);\n", ss);
      |  4 => OpZ ("_ZERO1 (& @);\n", ss);
      |  8 => OpZ ("_ZERO2 (& @);\n", ss);
      | 12 => OpZ ("_ZERO3 (& @);\n", ss);
      | 16 => OpZ ("_ZERO4 (& @);\n", ss);
      | 20 => OpZ ("_ZERO5 (& @);\n", ss);
      | 24 => OpZ ("_ZERO6 (& @);\n", ss);
      | 28 => OpZ ("_ZERO7 (& @);\n", ss);
      | 32 => OpZ ("_ZERO8 (& @);\n", ss);
      ELSE    OpI ("_ZERO  (@, ", byteSize);  OpZ ("& @);\n", ss);
      END;

    ELSE (* packed bitfield => ordinal scalar*)
      OpZ ("@ = 0;\n", ss);
    END;
  END Zero;

PROCEDURE Comment (t: TEXT) =
  VAR i, j, len: INTEGER;
  BEGIN
    IF (cur.breakable) THEN SetLine (); cur.breakable := FALSE; END;
    i := 0;
    len := Text.Length (t);
    WHILE (i + 70 < len) DO
      MBuf.PutText (cur.wr, "  /** ");
      MBuf.PutText (cur.wr, Text.Sub (t, i, 60));
      MBuf.PutText (cur.wr, " **/\n");
      INC (i, 60);
      INC (cur.line);
      cur.width := 0;
    END;
    IF (i < len) THEN
      MBuf.PutText (cur.wr, "  /** ");
      MBuf.PutText (cur.wr, Text.Sub (t, i, len - i));
      IF (len > 70) THEN
        (* pad the last line *)
        j := 60 - (len - i);
        WHILE (j > 0) DO MBuf.PutChar (cur.wr, ' '); DEC (j)  END;
      END;
      MBuf.PutText (cur.wr, " **/\n");
      INC (cur.line);
      cur.width := 0;
    END;
  END Comment;

PROCEDURE Reset () =
  <*FATAL Wr.Failure, Thread.Alerted*>
  BEGIN
    (* initialize the streams *)
    FOR i := FIRST (Stream) TO LAST (Stream) DO
      WITH z = streams[i] DO
        ResetPosition (z, FALSE);
        z.wr        := NIL;
        z.shutdown  := NIL;
        z.target    := Host.output;
      END;
    END;

    (* customize a few streams *)
    streams [Stream.LinkHeader].target    := Host.linkOutput;
    streams [Stream.VersionStamps].target := Host.linkOutput;
    streams [Stream.LinkerTypes].target   := Host.linkOutput;

    (* set the current stream *)
    current := FIRST (Stream);
    cur := streams[current];
    IF (cur.wr = NIL) THEN cur.wr := MBuf.New () END;

    (* prime the real output file *)
    Wr.PutText (Host.output, "#include \"M3Runtime.h\"\n");
  END Reset;

PROCEDURE ResetPosition (VAR s: StreamState;  formatted: BOOLEAN) =
  BEGIN
    s.indent    := 0;
    s.newline   := TRUE;
    s.m3Lines   := formatted;
    s.breakable := TRUE;
    s.flushLine := FALSE;
    s.file      := NIL;
    s.line      := 0;
    s.width     := 0;
  END ResetPosition;

PROCEDURE Finalize () =
  <*FATAL Wr.Failure, Thread.Alerted*>
  VAR last: Wr.T;
  BEGIN
    (* call each of the shutdown procedures *)
    FOR i := FIRST (Stream) TO LAST (Stream) DO
      WITH p = streams[i].shutdown DO
        IF (p # NIL) THEN  EVAL Switch (i);  p(); END;
      END;
    END;

    (* write each of the streams to the output file *)
    last := NIL;
    FOR i := FIRST (Stream) TO LAST (Stream) DO
      WITH z = streams[i] DO
        IF (last = z.target)
          THEN Wr.PutText (z.target, "/*------------------*/\n");
          ELSE last := z.target;
        END;
        IF (z.wr # NIL) THEN  MBuf.Flush (z.wr, z.target);  END;
      END;
    END;

    Wr.Flush (Host.output);
    Wr.Flush (Host.linkOutput);
  END Finalize;

PROCEDURE Switch (new: Stream): Stream =
  VAR old: Stream;
  BEGIN
    old := current;
    IF (old # new) THEN
      streams[old] := cur;
      cur := streams[new];
      current := new;
    END;
    IF (cur.wr = NIL) THEN cur.wr := MBuf.New () END;
    RETURN old;
  END Switch;

CONST
  ProcBody = ARRAY [0..7] OF Stream {
    Stream.Body0, Stream.Body1, Stream.Body2, Stream.Body3,
    Stream.Body4, Stream.Body5, Stream.Body6, Stream.Body7
  };

CONST
  ProcDecl = ARRAY [0..7] OF Stream {
    Stream.Decls0, Stream.Decls1, Stream.Decls2, Stream.Decls3,
    Stream.Decls4, Stream.Decls5, Stream.Decls6, Stream.Decls7
  };

VAR procDepth: INTEGER := -1;
VAR procStack: ARRAY [0..7] OF Stream;

PROCEDURE PushProcedure (formatted: BOOLEAN := FALSE) =
  BEGIN
    INC (procDepth);
    procStack[procDepth] := Switch (ProcDecl [procDepth]);
    ResetPosition (cur, formatted);
    ResetPosition (streams [ProcBody [procDepth]], formatted);
    MBuf.PutChar (cur.wr, '\n');
  END PushProcedure;

PROCEDURE PopProcedure () =
  BEGIN
    EVAL Switch (procStack[procDepth]);
    AppendToCurrentStream (ProcDecl[procDepth]);
    AppendToCurrentStream (ProcBody[procDepth]);
    DEC (procDepth);
  END PopProcedure;

PROCEDURE SwitchToDecls (): Stream =
  BEGIN
    RETURN Switch (ProcDecl [procDepth]);
  END SwitchToDecls;

PROCEDURE SwitchToBody (): Stream =
  BEGIN
    RETURN Switch (ProcBody [procDepth]);
  END SwitchToBody;

PROCEDURE AppendToCurrentStream (s: Stream) =
  BEGIN
    IF (s = current) THEN RETURN END;
    WITH z = streams[s] DO
      IF (z.wr # NIL) THEN  MBuf.Append (z.wr, cur.wr)  END;
      z.breakable := TRUE;
      z.flushLine := FALSE;
      z.file      := NIL;
      z.width     := 0;
      z.line      := 0;
      z.indent    := 0;
    END;
  END AppendToCurrentStream;

PROCEDURE RegisterShutDown (s: Stream;  p: PROCEDURE ()) =
  BEGIN
    IF (s = current) THEN
      <* ASSERT  cur.shutdown = NIL *>
      cur.shutdown := p;
    ELSE
      <* ASSERT  streams[s].shutdown = NIL *>
      streams[s].shutdown := p;
    END;
  END RegisterShutDown;

BEGIN
END Emit.