gef/src/GEFAlg.m3


Copyright (C) 1994, Digital Equipment Corp.

MODULE GEFAlg;

IMPORT Algorithm, Atom, Fmt, gefeventIE, GEFLisp, RefList, SLisp, SLispClass,
       Sx, Thread, ZeusCodeView, ZeusPanel;

REVEAL
  Interp = PublicInterp BRANDED OBJECT
    alg: Algorithm.T
  OVERRIDES
    init := InitInterp;
    error := ParseError;
  END;

PROCEDURE ParseError (<* UNUSED *> t: Interp; msg: TEXT): REFANY
  RAISES {SLisp.Error} =
  BEGIN
    ZeusPanel.ReportError(msg);
    RAISE SLisp.Error;
  END ParseError;

PROCEDURE InitInterp (interp: Interp; alg: Algorithm.T): Interp =
  BEGIN
    EVAL SLisp.T.init(interp);
    interp.alg := alg;
    interp.defineFun(NEW(SLisp.Builtin, name := "StartFeedback", minArgs := 0,
                         maxArgs :=0, apply := StartFeedback));
    interp.defineFun(NEW(SLisp.Builtin, name := "EndFeedback", minArgs := 0,
                         maxArgs := 0, apply := EndFeedback));
    interp.defineFun(NEW(SLisp.Builtin, name := "Event", minArgs := 1,
                         maxArgs := LAST(INTEGER), apply := Event));
    interp.defineFun(NEW(SLisp.Builtin, name := "Update", minArgs := 1,
                         maxArgs := LAST(INTEGER), apply := Update));
    interp.defineFun(NEW(SLisp.Builtin, name := "Pause", minArgs := 0,
                         maxArgs := 0, apply := Pause));
    interp.defineFun(
      NEW(SLisp.Builtin, name := "CodeViewEvent", minArgs := 1,
          maxArgs := 1, apply := CodeViewEvent));
    interp.defineFun(
      NEW(SLisp.Builtin, name := "CodeViewProc", minArgs := 1,
          maxArgs := 1, apply := CodeViewProc));
    interp.defineFun(
      NEW(SLisp.Builtin, name := "CodeViewExit", minArgs := 0,
          maxArgs := 0, apply := CodeViewExit));

    GEFLisp.ZeusifyInterp(interp);

    RETURN interp;
  END InitInterp;

PROCEDURE Update (<*UNUSED*> self: SLisp.Builtin;
                            i   : SLisp.T;
                            args: RefList.T      ): REFANY
  RAISES {SLisp.Error} =
  BEGIN
    RETURN Event1(i, args, TRUE);
  END Update;

PROCEDURE Event (<*UNUSED*> self: SLisp.Builtin;
                            i   : SLisp.T;
                            args: RefList.T      ): REFANY
  RAISES {SLisp.Error} =
 BEGIN
    RETURN Event1(i, args, FALSE);
  END Event;

PROCEDURE StartFeedback (<*UNUSED*>   self: SLisp.Builtin;
                                      i   : SLisp.T;
                         <* UNUSED *> args: RefList.T      ): REFANY
  RAISES {SLisp.Error} =
  VAR interp: Interp := i;
  BEGIN
    TRY ZeusPanel.StartFeedback(interp.alg) EXCEPT | Thread.Alerted => END;
    RETURN interp.varEval("t");
  END StartFeedback;

PROCEDURE EndFeedback (<*UNUSED*>   self: SLisp.Builtin;
                                    i   : SLisp.T;
                       <* UNUSED *> args: RefList.T      ): REFANY
  RAISES {SLisp.Error} =
  VAR interp: Interp := i;
  BEGIN
    TRY ZeusPanel.EndFeedback(interp.alg) EXCEPT | Thread.Alerted => END;
    RETURN interp.varEval("t");
  END EndFeedback;

PROCEDURE Event1 (i: SLisp.T; args: RefList.T; update: BOOLEAN): REFANY
  RAISES {SLisp.Error} =
  VAR
    interp: Interp := i;
    name           := interp.eval(args.head);
  <* FATAL Sx.PrintError *>
  BEGIN
    TRY
      TYPECASE name OF
      | NULL => RETURN interp.error("No name given for event");
      | TEXT (nm) =>
          IF update THEN
            gefeventIE.Update(
              interp.alg, nm,
              GEFLisp.QuoteList(GEFLisp.EvalList(interp, args.tail)));
          ELSE
            gefeventIE.Event(
              interp.alg, nm,
              GEFLisp.QuoteList(GEFLisp.EvalList(interp, args.tail)));
          END;
      ELSE
        RETURN interp.error(Fmt.F("Bad value given for event name: %s",
                                  SLispClass.SxToText(name)));
      END;
    EXCEPT
    | Thread.Alerted => RAISE SLisp.Error
    END;
    RETURN NIL;
  END Event1;

PROCEDURE Pause (<*UNUSED*>   self: SLisp.Builtin;
                              i   : SLisp.T;
                 <* UNUSED *> args: RefList.T         ): REFANY
  RAISES {SLisp.Error} =
  VAR interp: Interp := i;
  BEGIN
    TRY
      gefeventIE.Pause(interp.alg);
    EXCEPT
    | Thread.Alerted => RAISE SLisp.Error
    END;
    RETURN NIL;
  END Pause;

PROCEDURE CodeViewEvent (<*UNUSED*> self: SLisp.Builtin;
                                    i   : SLisp.T;
                                    args: RefList.T         ): REFANY
  RAISES {SLisp.Error} =
  VAR
    interp: Interp := i;
    line           := interp.eval(args.head);
  BEGIN
    TRY
      TYPECASE line OF
      | NULL =>
          RETURN interp.error("No value given for CodeView event line");
      | SLisp.Integer (ri) => ZeusCodeView.Event(interp.alg, ri^);
      ELSE
        RETURN interp.error("Bad value given for CodeView event line");
      END;
    EXCEPT
    | Thread.Alerted => RAISE SLisp.Error
    END;
    RETURN NIL
  END CodeViewEvent;

PROCEDURE CodeViewProc (<*UNUSED*> self: SLisp.Builtin;
                                   i   : SLisp.T;
                                   args: RefList.T         ): REFANY
  RAISES {SLisp.Error} =
  VAR
    interp: Interp := i;
    proc           := interp.eval(args.head);
  BEGIN
    TRY
      TYPECASE proc OF
      | NULL =>
          RETURN interp.error("No name given for CodeView procedure");
      | TEXT (nm) => ZeusCodeView.Event(interp.alg, procedureName := nm);
      ELSE
        RETURN interp.error("Bad value given for CodeView procedure");
      END;
    EXCEPT
    | Thread.Alerted => RAISE SLisp.Error
    END;
    RETURN NIL
  END CodeViewProc;

PROCEDURE CodeViewExit (<*UNUSED*>   self: SLisp.Builtin;
                                     i   : SLisp.T;
                        <* UNUSED *> args: RefList.T         ): REFANY
  RAISES {SLisp.Error} =
  VAR interp: Interp := i;
  BEGIN
    TRY
      ZeusCodeView.Exit(interp.alg);
      RETURN NIL
    EXCEPT
    | Thread.Alerted => RAISE SLisp.Error
    END;
  END CodeViewExit;

PROCEDURE Feedback (interp: Interp; function: TEXT; args: RefList.T) =
  <* FATAL SLisp.Error *>
  BEGIN
    WITH atom = Atom.FromText(function),
         fun  = interp.lookup(atom, SLispClass.LookupMode.LookupOnly) DO
      TRY
        IF fun # NIL AND fun.funDefined THEN
          EVAL interp.eval(RefList.Cons(atom, args));
        END;
      EXCEPT
      | SLisp.Error =>
      END;
    END;
  END Feedback;

BEGIN
END GEFAlg.