File: m3bundle.m3 Last modified on Fri Nov 5 14:46:26 PST 1993 by kalsow

This module implements the M3Bundle command. See its manpage for details.

MODULE m3bundle EXPORTS Main;

IMPORT Rd, Wr, FileRd, FileWr, OSError, Params, Thread, Fmt, Stdio, Text;
<* FATAL Wr.Failure, Rd.Failure, Thread.Alerted, OSError.E *>

CONST
  MaxLineWidth = 75;     (* for readability *)
  MaxBlock     = 2000;   (* C limits on a TEXT constant *)
  NL           = Wr.EOL; (* line break *)
  NLNL         = NL & NL;

TYPE
  ElementList = REF ARRAY OF Element;
  Element = RECORD
    name   : TEXT;
    path   : TEXT;
    base   : TEXT;
    length : INTEGER;
    blocks : INTEGER;
  END;

VAR
  elts   := NEW (ElementList, 20);
  n_elts := 0;
  module : TEXT := NIL;
  wr     : Wr.T := NIL;
  max_blocks := 0;

PROCEDURE GetElementSizes (): BOOLEAN =
  VAR rd: Rd.T;  ok := TRUE;
  BEGIN
    FOR i := 0 TO n_elts-1 DO
      WITH z = elts[i] DO
        TRY
          rd := FileRd.Open (z.path);
          z.length := Rd.Length (rd);
          z.blocks := (z.length + MaxBlock - 1) DIV MaxBlock;
          z.base   := "E" & Fmt.Int (i);
          max_blocks := MAX (max_blocks, z.blocks);
          Rd.Close (rd);
        EXCEPT Rd.Failure, OSError.E =>
          wr := Stdio.stderr;
          Out (Params.Get(0), ": cannot read file: ", z.path, NL);
          ok := FALSE;
        END;
      END;
    END;
    RETURN ok;
  END GetElementSizes;

CONST Intf =
  "(* Generated by m3bundle; see its manpage. *)" & NLNL &
  "IMPORT Bundle;" & NLNL &
  "PROCEDURE Get(): Bundle.T;" & NLNL;

PROCEDURE WriteInterface () =
  BEGIN
    wr := FileWr.Open (module & ".i3");
    Out ("INTERFACE ", module, ";", NL);
    Out (Intf);
    Out ("END ", module, ".", NL);
    Wr.Close (wr);
  END WriteInterface;

CONST Mod_0 =
  "(* Generated by m3bundle; see its manpage. *)" & NL &
  NL &
  "IMPORT Bundle, BundleRep, Text;" & NL;

CONST Mod_1 =
  "IMPORT Thread, Wr, TextWr;" & NL;

CONST Mod_2 =
  NL &
  "TYPE T = Bundle.T OBJECT OVERRIDES" & NL &
  "           get      := LookUp;" & NL &
  "           getNames := GetNames;" & NL &
  "         END;" & NL &
  NL &
  "TYPE Texts = REF ARRAY OF TEXT;" & NL &
  NL &
  "VAR" & NL &
  "  bundle: T     := NIL;" & NL &
  "  names : Texts := NIL;" & NL &
  NL &
  "PROCEDURE Get(): Bundle.T =" & NL &
  "  BEGIN" & NL &
  "    IF (bundle = NIL) THEN bundle := NEW (T) END;" & NL &
  "    RETURN bundle;" & NL &
  "  END Get;" & NL &
  NL &
  "PROCEDURE GetNames (<*UNUSED*> self: T): Texts = " & NL &
  "  BEGIN" & NL &
  "    IF names = NIL THEN" & NL &
  "      names := NEW (Texts, NUMBER (Names));" & NL &
  "      names^ := Names;" & NL &
  "    END;" & NL &
  "    RETURN names;" & NL &
  "  END GetNames;" & NL &
  NL &
  "PROCEDURE LookUp (<*UNUSED*> self: T;  element: TEXT): TEXT = " & NL &
  "  BEGIN" & NL &
  "    FOR i := 0 TO LAST (Names)-1 DO" & NL &
  "      IF Text.Equal (Names[i], element) THEN" & NL;

CONST Mod_3 =
  "        IF Elements[i] = NIL THEN Elements[i] := GetElt (i) END;" & NL;

CONST Mod_4 =
  "        RETURN Elements[i];" & NL &
  "      END;" & NL &
  "    END;" & NL &
  "    RETURN NIL;" & NL &
  "  END LookUp;" & NL &
  NL;

CONST Mod_5 =
  "PROCEDURE GetElt (n: INTEGER): TEXT =" & NL &
  "  <*FATAL Thread.Alerted, Wr.Failure *>" & NL &
  "  VAR wr := TextWr.New ();" & NL &
  "  BEGIN" & NL &
  "    CASE n OF" & NL;

CONST Mod_6 =
  "    ELSE (*skip*)" & NL &
  "    END;" & NL &
  "    RETURN TextWr.ToText (wr);" & NL &
  "  END GetElt;" & NL &
  NL;

CONST Mod_7 =
  NL &
  "BEGIN" & NL &
  "END ";

PROCEDURE WriteModule () =
  BEGIN
    wr := FileWr.Open (module & ".m3");
    Out ("MODULE ", module, ";", NL);
    Out (Mod_0);
    IF (max_blocks > 1) THEN Out (Mod_1) END;
    Out (Mod_2);
    IF (max_blocks > 1) THEN Out (Mod_3) END;
    Out (Mod_4);
    WriteNames ();
    WriteElements ();
    IF (max_blocks > 1) THEN
      Out (Mod_5);
      WriteGetElt ();
      Out (Mod_6);
    END;
    WriteLiterals ();
    Out (Mod_7, module, ".", NL);
    Wr.Close (wr)
  END WriteModule;

PROCEDURE WriteGetElt () =
  BEGIN
    FOR i := 0 TO n_elts-1 DO
      WITH z = elts[i] DO
        IF (z.blocks > 1) THEN
          Out ("    | ", Fmt.Int (i), " =>", NL);
          FOR j := 0 TO z.blocks-1 DO
            Out ("        Wr.PutText (wr, ", BlockName (z.base, j), ");", NL);
          END;
        END;
      END;
    END;
  END WriteGetElt;

PROCEDURE WriteNames () =
  VAR name: TEXT;
  BEGIN
    Out ("CONST Names = ARRAY [0..", Fmt.Int (n_elts), "] OF TEXT {", NL);
    FOR i := 0 TO n_elts-1 DO
      IF (i > 0) THEN Out (",", NL) END;
      name := elts[i].name;
      Out ("  \"");
      FOR j := 0 TO Text.Length (name) - 1 DO
        EVAL OutChar (Text.GetChar (name, j));
      END;
      Out ("\"");
    END;
    IF (n_elts > 0) THEN Out (",", NL) END;
    Out ("  NIL", NL, "};", NLNL);
  END WriteNames;

PROCEDURE WriteElements () =
  BEGIN
    IF (max_blocks > 1)
      THEN Out ("VAR Elements :=");
      ELSE Out ("CONST Elements =");
    END;
    Out (" ARRAY [0..", Fmt.Int (n_elts), "] OF TEXT {", NL);
    FOR i := 0 TO n_elts-1 DO
      IF (i > 0) THEN Out (",", NL) END;
      WITH z = elts[i] DO
        IF (z.length <= 0) THEN
          Out ("  \"\"");
        ELSIF (z.blocks <= 1) THEN
          Out ("  ", BlockName (z.base, 0));
        ELSE (* fill it in at runtime by calling GetElt *)
          Out ("  NIL (* ", BlockName (z.base, 0), " .. ");
          Out (BlockName (z.base, z.blocks-1), " *)");
        END;
      END;
    END;
    IF (n_elts > 0) THEN Out (",", NL) END;
    Out ("  NIL", NL, "};", NLNL);
  END WriteElements;

PROCEDURE WriteLiterals () =
  VAR rd: Rd.T;
  BEGIN
    FOR i := 0 TO n_elts-1 DO
      WITH z = elts[i] DO
        rd := FileRd.Open (z.path);
        WriteLiteral (rd, z.base);
        Rd.Close (rd);
      END;
    END;
  END WriteLiterals;

PROCEDURE WriteLiteral (rd: Rd.T;  base: TEXT) =
  <*FATAL Rd.EndOfFile*>
  VAR width, bytes, blocks := 0;  ch: CHAR;
  BEGIN
    WHILE NOT Rd.EOF (rd) DO
      IF (bytes = 0) THEN
        (* start a new block *)
        Out ("CONST ", BlockName (base, blocks), " = \n   \"");
        INC (blocks);
        width := 4;
      ELSIF (width = 0) THEN
        (* start a new line *)
        Out (" & \"");
        width := 4;
      END;

      (* write a character *)
      ch := Rd.GetChar (rd);
      INC (width, OutChar (ch));
      INC (bytes);

      IF (bytes >= MaxBlock) THEN
        (* finish this block *)
        Out ("\";", NLNL);
        bytes := 0;
        width := 0;
      ELSIF (width >= MaxLineWidth) THEN
        (* finish this line *)
        Out ("\"", NL);
        width := 0;
      END;
    END;

    IF (width > 0) THEN (* finish the last string *) Out ("\"") END;
    IF (bytes > 0) THEN (* finish the last block *)  Out (";", NLNL) END;
  END WriteLiteral;

PROCEDURE BlockName (base: TEXT;  block: INTEGER): TEXT =
  BEGIN
    IF (block = 0) THEN RETURN base END;
    RETURN base & "_" & Fmt.Int (block - 1);
  END BlockName;

PROCEDURE ParseCommandLine (): BOOLEAN =
  VAR next := 0;
  PROCEDURE NextParam (): TEXT =
    BEGIN
      INC (next);
      IF (next >= Params.Count) THEN RETURN NIL END;
      RETURN Params.Get (next);
    END NextParam;
  BEGIN
    IF ParseOptions (NextParam) THEN RETURN TRUE END;
    wr := Stdio.stderr;
    Out ("usage: ", Params.Get (0), " -name n [-element e path] ...", NL);
    RETURN FALSE;
  END ParseCommandLine;

PROCEDURE ParseOptions (next_arg: PROCEDURE (): TEXT): BOOLEAN =
  VAR arg: TEXT;
  BEGIN
    LOOP
      arg := next_arg ();
      IF (arg = NIL) THEN
        RETURN module # NIL;
      ELSIF Text.Equal (arg, "-name") THEN
        module  := next_arg ();
        IF (module = NIL) THEN RETURN FALSE END;
      ELSIF Text.Equal (arg, "-element") THEN
        IF (n_elts > LAST (elts^)) THEN ExpandElts () END;
        WITH z = elts[n_elts] DO
          z.name := next_arg ();
          z.path := next_arg ();
          IF (z.name = NIL) OR (z.path = NIL) THEN RETURN FALSE END;
        END;
        INC (n_elts);
      ELSIF Text.Equal (Text.Sub (arg, 0, 2), "-F") THEN
        IF NOT ParseOptionFile (Text.Sub (arg, 2, LAST (CARDINAL))) THEN
          RETURN FALSE;
        END;
      ELSE
        RETURN FALSE;
      END;
    END;
  END ParseOptions;

PROCEDURE ParseOptionFile (name: TEXT): BOOLEAN =
  <* FATAL Rd.EndOfFile *>
  VAR f := FileRd.Open (name);  b: BOOLEAN;
  PROCEDURE NextLine (): TEXT =
    BEGIN
      IF Rd.EOF (f) THEN RETURN NIL END;
      RETURN Rd.GetLine (f);
    END NextLine;
  BEGIN
    b := ParseOptions (NextLine);
    Rd.Close(f);
    RETURN b;
  END ParseOptionFile;

PROCEDURE ExpandElts () =
  VAR new := NEW (ElementList, 2 * NUMBER (elts^));
  BEGIN
    FOR i := 0 TO LAST (elts^) DO new[i] := elts[i] END;
    elts := new;
  END ExpandElts;

PROCEDURE Out (a, b, c, d: TEXT := NIL) =
  BEGIN
    IF (a # NIL) THEN Wr.PutText (wr, a) END;
    IF (b # NIL) THEN Wr.PutText (wr, b) END;
    IF (c # NIL) THEN Wr.PutText (wr, c) END;
    IF (d # NIL) THEN Wr.PutText (wr, d) END;
  END Out;

PROCEDURE OutChar (ch: CHAR): INTEGER =
  (* writes 'ch' as a literal and returns the output width *)
  BEGIN
    IF (ch = '\\') THEN
      Wr.PutText (wr, "\\\\");
      RETURN 2;
    ELSIF (ch = '\n') THEN
      Wr.PutText (wr, "\\n");
      RETURN 2;
    ELSIF (ch = '\r') THEN
      Wr.PutText (wr, "\\r");
      RETURN 2;
    ELSIF (ch = '\t') THEN
      Wr.PutText (wr, "\\t");
      RETURN 2;
    ELSIF (ch = '\f') THEN
      Wr.PutText (wr, "\\f");
      RETURN 2;
    ELSIF (ch = '\'') THEN
      Wr.PutText (wr, "\\\'");
      RETURN 2;
    ELSIF (ch = '\"') THEN
      Wr.PutText (wr, "\\\"");
      RETURN 2;
    ELSIF (ch < ' ') OR (ch > '~') THEN
      Wr.PutChar (wr, '\\');
      PutC (ORD(ch) DIV 64);
      PutC (ORD(ch) MOD 64 DIV 8);
      PutC (ORD(ch) MOD 8);
      RETURN 4;
    ELSE
      Wr.PutChar (wr, ch);
      RETURN 1;
    END;
  END OutChar;

PROCEDURE PutC (i: INTEGER) =
  BEGIN
    Wr.PutChar (wr, VAL(ORD('0') + i, CHAR));
  END PutC;

BEGIN
  IF ParseCommandLine () AND GetElementSizes () THEN
    WriteInterface ();
    WriteModule ();
  END;
END m3bundle.