codeview/src/CodeView.m3


 --------------------------------------------------------------------- 
 07-JUN-96  JK  Modified ParseAlg to replace @number tags with spaces. 
 --------------------------------------------------------------------- 
 Copyright (C) 1992, Digital Equipment Corporation 
 All rights reserved. 
 See the file COPYRIGHT for a full description. 
 Last modified on Fri Jun 28 00:44:29 PDT 1996 by mhb    
      modified on Wed Feb 23 08:08:08 PST 1994 by kalsow 
      modified on Wed Jun 23 14:24:07 PDT 1993 by steveg 
      modified on Tue Jan  5 20:04:15 PST 1993 by johnh 
      modified on Wed Aug 19 16:34:43 PDT 1992 by sclafani
<*PRAGMA LL*>

MODULE CodeView;

IMPORT Axis, BorderedVBT, ASCII, ColorName, Fmt, FloatMode, Font, IntRef,
       IntRefSort, IntRefTbl, Lex, RefList, PaintOp, Pixmap, Point, Rd,
       RefListUtils, Rect, Split, Stdio, TextPort, TextRefTbl, Text,
       TextRef, TextRefSort, TextRd, TextWr, TextureVBT, Thread, VBT,
       VText, VTDef, Wr, ZSplit;

<* FATAL Rd.Failure, Wr.Failure, Thread.Alerted, Rd.EndOfFile *>
<* FATAL Lex.Error, FloatMode.Trap *>
<* FATAL VTDef.Error, Split.NotAChild *>

TYPE
  ProcInfo = REF RECORD
                   source : TEXT;
                   offsets: IntRefTbl.T;
                 END;
  Position = REF RECORD start, end: CARDINAL;  END;

REVEAL
  T = Public BRANDED OBJECT
        procTable   : TextRefTbl.T;
        font        : Font.T;
        delta       : CARDINAL;
      OVERRIDES
        shape       := ZShape;
        enter       := Enter;
        exit        := Exit;
        at          := At;
        event       := Event;
        exitAll     := ExitAll;
        listNames   := ListNames;
        listRegions := ListRegions;
        init        := Init;
      END;

TYPE
  AlgVBT = TextPort.T OBJECT
             interval: VText.Interval;
             proc    : ProcInfo;
           OVERRIDES
             shape := Shape;
           END;

<* FATAL ColorName.NotFound *>
VAR
  replaceTags: BOOLEAN := FALSE;       (* JK, 07-JUN-96 *)

  highlightStyle := VText.MakeIntervalOptions (
                      VText.IntervalStyle.InverseStyle,
                      PaintOp.MakeColorScheme (
                        PaintOp.Fg, PaintOp.FromRGB (
                                        ColorName.ToRGB ("LightGreen").r,
                                        ColorName.ToRGB ("LightGreen").g,
                                        ColorName.ToRGB ("LightGreen").b)),
                      PaintOp.bgFg, PaintOp.Bg);

PROCEDURE ZShape (v: VBT.T; ax: Axis.T; n: CARDINAL): VBT.SizeRange =
  VAR res := ZSplit.T.shape (v, ax, n);
  BEGIN
    IF res.pref < 100 THEN
      IF ax = Axis.T.Ver THEN res.pref := 200 ELSE res.pref := 400 END;
      IF res.pref >= res.hi THEN res.hi := res.pref + 1; END;
    END;
    RETURN res;
  END ZShape;

PROCEDURE Shape (<*UNUSED*> v : VBT.T;
                 <*UNUSED*> ax: Axis.T;
                 <*UNUSED*> n : CARDINAL): VBT.SizeRange =
  VAR res: VBT.SizeRange;
  BEGIN
    res.pref := 2000;
    res.lo := res.pref;
    res.hi := res.lo + 1;
    RETURN res;
  END Shape;

PROCEDURE Enter (t: T; procedureName: TEXT; pauseTime := -1) =
  VAR
    algVBT: AlgVBT;
    point : Point.T;
    depth : INTEGER;
    pos   : Position;
    refany: REFANY;
  BEGIN
    IF NOT t.procTable.get (procedureName, refany) THEN RETURN; END;
    algVBT := NewAlgVBT (t, refany);
    depth := Split.NumChildren (t) - 1;
    point := Point.Add (
               Rect.NorthWest (ZSplit.GetParentDomain (t)),
               Point.FromCoords (t.delta * depth, t.delta * depth));
    ZSplit.InsertAt (t, BorderedVBT.New (algVBT, 0.5), point);
    IF algVBT.proc.offsets.get (0, refany) THEN
      pos := refany;
      VText.MoveInterval (algVBT.interval, pos.start, pos.end);
      VBT.Mark (algVBT);
      IF pauseTime < 0 THEN pauseTime := t.pauseTime; END;
      Thread.Pause (FLOAT(pauseTime, LONGREAL));
    END;
  END Enter;

PROCEDURE Exit (t: T; pauseTime := -1) =
  BEGIN
    IF Split.NumChildren (t) < 2 THEN RETURN; END;
    Split.Delete (t, Split.Succ (t, NIL));
    IF pauseTime < 0 THEN pauseTime := t.pauseTime; END;
    Thread.Pause (FLOAT(pauseTime, LONGREAL));
  END Exit;

PROCEDURE At (t: T; highlight: CARDINAL; pauseTime := -1) =
  VAR
    algVBT: AlgVBT;
    pos   : Position;
    refany: REFANY;
  BEGIN
    IF Split.NumChildren (t) < 2 THEN RETURN; END;
    algVBT := Split.Succ (Split.Succ (t, NIL), NIL);
    IF algVBT.proc.offsets.get (highlight, refany) THEN
      pos := refany;
      VText.MoveInterval (algVBT.interval, pos.start, pos.end);
      VBT.Mark (algVBT);
      IF pauseTime < 0 THEN pauseTime := t.pauseTime; END;
      Thread.Pause (FLOAT(pauseTime, LONGREAL));
    END;
  END At;

PROCEDURE Event (t            : T;
                 highlight           := 0;
                 pauseTime           := -1;
                 procedureName: TEXT := NIL ) =
  BEGIN
    IF procedureName # NIL THEN
      t.enter (procedureName, pauseTime);
    ELSIF highlight < 0 THEN
      t.exit (pauseTime);
    ELSE
      t.at (highlight, pauseTime);
    END;
  END Event;

PROCEDURE ExitAll (t: T) =
  VAR
    bg := Split.Pred (t, NIL);
    ch := Split.Pred (t, bg);
  BEGIN
    WHILE ch # NIL DO Split.Delete (t, ch); ch := Split.Pred (t, bg); END;
  END ExitAll;

PROCEDURE NewAlgVBT (t: T; proc: ProcInfo): AlgVBT =
  VAR
    vbt: AlgVBT;
    vt : VText.T;
  BEGIN
    vbt := NEW (AlgVBT).init (wrap := FALSE, font := t.font);
    TextPort.SetText (vbt, proc.source);
    vbt.setReadOnly(TRUE);  (* replaces TextPort.SetReadOnly (vbt, TRUE);*)
    vt := TextPort.GetVText (vbt);
    vbt.interval := VText.CreateInterval (vt, 0, 0, highlightStyle);
    VText.SwitchInterval (vbt.interval, VText.OnOffState.On);
    vbt.proc := proc;
    RETURN vbt;
  END NewAlgVBT;

PROCEDURE Dump (source: Rd.T; wr: Wr.T; errorWr: Wr.T := NIL) =
  VAR
    procList: RefList.T;
    assoc   : RefList.T;
    name    : TEXT;
    proc    : ProcInfo;
    posList : RefList.T;
    pos     : Position;
    line    : REF INTEGER;
  BEGIN
    procList := SortTextRefTbl(ParseAlg (source, errorWr));
    WHILE procList # NIL DO
      assoc := RefListUtils.Pop (procList);
      name := RefListUtils.Pop (assoc);
      proc := RefListUtils.Pop (assoc);
      Wr.PutText (wr, name & "\n");
      posList := SortIntRefTbl(proc.offsets);
      WHILE posList # NIL DO
        assoc := RefListUtils.Pop (posList);
        line := RefListUtils.Pop (assoc);
        pos := RefListUtils.Pop (assoc);
        Wr.PutText (wr, Fmt.F ("%5s  %s\n", Fmt.Int (line^),
                               Text.Sub (proc.source, pos.start,
                                         pos.end - pos.start)));
      END;
      Wr.PutChar (wr, '\n');
    END;
  END Dump;

PROCEDURE ParseAlg (rd: Rd.T; errorWr: Wr.T): TextRefTbl.T =
  TYPE
    State = {Top, TopAt, TopTag, InProc, ProcAt, ProcTag, StatTag, InStat,
             StatAt};
  VAR
    procTable           := NEW(TextRefTbl.Default).init();
    procWr              := TextWr.New ();
    tagWr               := TextWr.New ();
    state               := State.Top;
    c        : CHAR;
    name     : TEXT;
    tag      : TEXT;
    id       : CARDINAL;
    any      : REFANY;
    proc     : ProcInfo;
    pos      : Position;
  BEGIN
    IF errorWr = NIL THEN errorWr := Stdio.stderr; END;
    WHILE NOT Rd.EOF (rd) DO
      c := Rd.GetChar (rd);
      CASE state OF
      | State.Top => IF c = '@' THEN state := State.TopAt; END;
      | State.TopAt =>
          IF c IN ASCII.AlphaNumerics THEN
            Wr.PutChar (tagWr, c);
            state := State.TopTag;
          ELSE
            state := State.Top;
          END;
      | State.TopTag =>
          IF c IN ASCII.Punctuation + ASCII.Spaces THEN
            name := TextWr.ToText (tagWr);
            proc := NEW (ProcInfo);
            proc.offsets := NEW(IntRefTbl.Default).init(4);
            pos := NEW (Position);
            tag := "0";
            id := 0;
            pos.start := Wr.Index (procWr);
            state := State.InStat;
          ELSE
            Wr.PutChar (tagWr, c);
          END;
      | State.InProc =>
          IF c = '@' THEN
            IF replaceTags THEN
              pos := NEW (Position);            (* JK, 11-JUN-96 *)
              pos.start := Wr.Index (procWr);   (* JK, 11-JUN-96 *)
              Wr.PutChar (procWr, ' ');	        (* JK, 07-JUN-96 *)
            END;
            state := State.ProcAt;
          ELSE
            Wr.PutChar (procWr, c);
          END;
      | State.ProcAt =>
          IF c IN ASCII.Letters THEN
            Wr.PutChar (tagWr, c);
            state := State.ProcTag;
          ELSIF c IN ASCII.Digits THEN
            Wr.PutChar (tagWr, c);
            IF replaceTags THEN
              Wr.PutChar (procWr, ' ');	        (* JK, 07-JUN-96 *)
            END;
            state := State.StatTag;
          ELSE
            state := State.InProc;
          END;
      | State.ProcTag =>
          IF c IN ASCII.Punctuation + ASCII.Spaces THEN
            tag := TextWr.ToText (tagWr);
            IF NOT Text.Equal (tag, name) THEN
              Wr.PutText (
                errorWr,
                Fmt.F (
                  "procedure trailer for '%s' does not match header\n",
                  name));
            END;
            proc.source := TextWr.ToText (procWr);
            EVAL procTable.put (name, proc);
            state := State.Top;
          ELSE
            Wr.PutChar (tagWr, c);
          END;
      | State.StatTag =>
          IF c IN ASCII.Digits THEN
            IF replaceTags THEN
              Wr.PutChar (procWr, ' ');         (* JK, 07-JUN-96 *)
            END;
            Wr.PutChar (tagWr, c);
          ELSE
            IF replaceTags THEN
              Wr.PutChar (procWr, ' ');         (* JK, 07-JUN-96 *)
            END;
            tag := TextWr.ToText (tagWr);
            id := Lex.Int (TextRd.New (tag));
            IF proc.offsets.get (id, any) THEN
              Wr.PutText (
                errorWr,
                Fmt.F (
                  "duplicate statement tag '@%s' at offsets %s and %s\n",
                  tag, Fmt.Int (pos.start), Fmt.Int (Rd.Index (rd))));
            END;
            IF NOT replaceTags THEN
              pos := NEW (Position);             (* JK, 11-JUN-96 *)
              pos.start := Wr.Index (procWr);    (* JK, 11-JUN-96 *)
            END;
            state := State.InStat;
          END;
      | State.InStat =>
          IF c = '@' THEN
            state := State.StatAt;
          ELSE
            Wr.PutChar (procWr, c);
          END;
      | State.StatAt =>
          IF c = '@' THEN
            Wr.PutChar (procWr, c);
            state := State.InStat;
          ELSE
            pos.end := Wr.Index (procWr);
            EVAL proc.offsets.put (id, pos);
            Wr.PutChar (procWr, c);
            state := State.InProc;
          END;
      END;
    END;

    CASE state OF
    | State.TopTag =>
        Wr.PutText (
          errorWr, "unterminated procedure header (@name) at end-of-file\n");
    | State.InProc, State.ProcAt =>
        Wr.PutText (errorWr,
                    Fmt.F (
                      "unmatched procedure header (@%s) at end-of-file\n",
                      name));
    | State.ProcTag =>
        Wr.PutText (
          errorWr,
          Fmt.F (
            "unterminated procedure trailer for '%s' at end-of-file\n",
            name));
    | State.StatTag =>
        Wr.PutText (
          errorWr,
          Fmt.F ("unterminated statement tag for '%s' at end-of-file\n",
                 name));
    | State.InStat =>
        Wr.PutText (
          errorWr,
          Fmt.F ("unterminated statement marker ('@%s') at end-of-file\n",
                 tag));
        Wr.PutText (errorWr,
                    Fmt.F (
                      "unmatched procedure header (@%s) at end-of-file\n",
                      name));
    | State.StatAt =>
        pos.end := Wr.Index (procWr);
        EVAL proc.offsets.put (Lex.Int (TextRd.New (tag)), pos);
        Wr.PutText (errorWr,
                    Fmt.F (
                      "unmatched procedure header (@%s) at end-of-file\n",
                      name));
    ELSE
    END;
    Wr.Flush (errorWr);
    RETURN procTable;
  END ParseAlg;

PROCEDURE ListNames (t: T): RefList.T =
  VAR
    iter            := t.procTable.iterate();
    k   : TEXT;
    val : REFANY;
    res : RefList.T := NIL;
  BEGIN
    WHILE iter.next(k, val) DO res := RefList.Cons(k, res); END;
    RETURN res
  END ListNames;

PROCEDURE ListRegions (t: T; procedureName: TEXT): RefList.T =
  VAR
    refany: REFANY;
    proc  : ProcInfo;
    k     : INTEGER;
    ri    : REF INTEGER;
    val   : REFANY;
    res   : RefList.T   := NIL;
  BEGIN
    IF t.procTable.get(procedureName, refany) THEN
      proc := refany;
      WITH iter = proc.offsets.iterate() DO
        WHILE iter.next(k, val) DO
          ri := NEW(REF INTEGER);
          ri^ := k;
          res := RefList.Cons(ri, res);
        END;
      END;
      RETURN res
    ELSE
      RETURN NIL;
    END;
  END ListRegions;

PROCEDURE Init (         t          : T;
                         source     : Rd.T;
                         errorWr    : Wr.T     := NIL;
                READONLY fontName              := DefaultFont;
                         paneOffset : CARDINAL := 20;
                         background : VBT.T    := NIL ): T =
  BEGIN
    IF background = NIL THEN
      background :=
        BorderedVBT.New(TextureVBT.New(txt := Pixmap.Gray), 0.5);
    END;
    EVAL ZSplit.T.init(t, background);
    t.procTable := ParseAlg(source, errorWr);
    t.font := Font.FromName(fontName);
    t.delta := paneOffset;
    RETURN t;
  END Init;

PROCEDURE New (         source     : Rd.T;
                        errorWr    : Wr.T     := NIL;
               READONLY fontName              := DefaultFont;
                        paneOffset : CARDINAL := 20;
                        background : VBT.T    := NIL ): T =
  BEGIN
    RETURN Init(NEW(T), source, errorWr, fontName, paneOffset,
                background);
  END New;

PROCEDURE SortTextRefTbl(tbl: TextRefTbl.T): RefList.T =
  VAR arr  := NEW(REF ARRAY OF TextRef.T, tbl.size());
      iter := tbl.iterate();
      k: TEXT;
      val: REFANY;
      res: RefList.T := NIL;
  BEGIN
    FOR i := 0 TO LAST(arr^) DO
      EVAL iter.next(k, val);
      arr[i] := TextRef.T{k, val};
    END;
    TextRefSort.Sort(arr^);
    FOR i := 0 TO LAST(arr^) DO
      res := RefList.Cons(RefList.List2(arr[i].key, arr[i].value), res);
    END;
    res := RefList.ReverseD(res);
    RETURN res;
  END SortTextRefTbl;

PROCEDURE SortIntRefTbl (tbl: IntRefTbl.T): RefList.T =
  VAR
    arr               := NEW(REF ARRAY OF IntRef.T, tbl.size());
    iter              := tbl.iterate();
    k   : INTEGER;
    ri  : REF INTEGER;
    val : REFANY;
    res : RefList.T   := NIL;
  BEGIN
    FOR i := 0 TO LAST(arr^) DO
      EVAL iter.next(k, val);
      arr[i] := IntRef.T{k, val};
    END;
    IntRefSort.Sort(arr^);
    FOR i := 0 TO LAST(arr^) DO
      ri := NEW(REF INTEGER);
      ri^ := arr[i].key;
      res := RefList.Cons(RefList.List2(ri, arr[i].value), res);
    END;
    res := RefList.ReverseD(res);
    RETURN res;
  END SortIntRefTbl;

PROCEDURE DoReplaceTags( replace: BOOLEAN := TRUE ) =
  BEGIN
    replaceTags := replace;
  END DoReplaceTags;

BEGIN
END CodeView.

interface IntRef is in: