gef/src/GEFLisp.m3


Copyright (C) 1994, Digital Equipment Corp.

MODULE GEFLisp EXPORTS GEFLisp, GEF (* InvokeEvent, EventData *);

<* PRAGMA LL *>

IMPORT Atom, Fmt, GEF, GEFClass, GEFError, Rd, RefList, RefListUtils, SLisp,
       SLispClass, Sx, Text, TextRd, TextWr, Thread, Wr, ZeusPanel;

PROCEDURE RegisterPO (interp: SLisp.T; name: TEXT; po: GEFClass.ParseObject) =
  BEGIN
    interp.defineFun(NEW(LispBuiltin, name := name, minArgs := 0,
                         maxArgs := LAST(INTEGER), po := po));
  END RegisterPO;

PROCEDURE RegisterFuns(interp: SLisp.T) =
  <* FATAL SLisp.Error *>
  BEGIN
    interp.defineFun(NEW(SLisp.Builtin, name := "get", minArgs := 2,
                         maxArgs := 2, apply := Get));
    interp.defineFun(NEW(SLisp.Builtin, name := "set", minArgs := 1,
                         maxArgs := LAST(INTEGER), apply := Set));
    interp.defineFun(NEW(SLisp.Builtin, name := "delete", minArgs := 1,
                         maxArgs := LAST(INTEGER), apply := Delete));

    ZeusifyInterp(interp);
  END RegisterFuns;

PROCEDURE ZeusifyInterp(interp: SLisp.T) =
  <* FATAL SLisp.Error *>
  BEGIN
    (* override the standard slisp printing procedures with ones that write to
       Zeus *)
    interp.defineFun (NEW (SLisp.Builtin, name := "print", apply := Print,
                         minArgs := 0, maxArgs := LAST (INTEGER)));
    interp.defineFun (NEW (SLisp.Builtin, name := "backtrace", apply := Backtrace,
                         minArgs := 0, maxArgs := 0));

    interp.defineVar("true", interp.varEval("t"));
    interp.defineVar("false", NIL);
    interp.defineVar("TRUE", interp.varEval("t"));
    interp.defineVar("FALSE", NIL);
  END ZeusifyInterp;

TYPE
  LispBuiltin = SLisp.Builtin OBJECT
                  po: GEFClass.ParseObject;
                OVERRIDES
                  apply := ParseLisp;
                END;

PROCEDURE EvalList (interp: SLisp.T; args: RefList.T): RefList.T
  RAISES {SLisp.Error} =
  VAR res, last: RefList.T := NIL;
  BEGIN
    WHILE args # NIL DO
      IF last = NIL THEN
        last := RefList.Cons(interp.eval(args.head), NIL);
        res := last;
      ELSE
        last.tail := RefList.Cons(interp.eval(args.head), NIL);
        last := last.tail;
      END;
      args := args.tail;
    END;
    RETURN res;
  END EvalList;

VAR
  quote := Atom.FromText("quote");

PROCEDURE QuoteList (args: RefList.T): RefList.T =
  VAR a, l: RefList.T := NIL;
  BEGIN
    WHILE args # NIL DO
      IF l = NIL THEN
        l := RefList.List1(RefList.List2(quote, args.head));
        a := l;
      ELSE
        l.tail := RefList.List1(RefList.List2(quote, args.head));
        l := l.tail;
      END;
      args := args.tail;
    END;
    RETURN a
  END QuoteList;

PROCEDURE ParseLisp (self: LispBuiltin; interp: SLisp.T; args: RefList.T):
  GEFClass.S_exp RAISES {SLisp.Error} = <* LL < GEFClass.mu *>
  <* FATAL Sx.PrintError *>
  VAR
    graph         : GEF.T          := interp.varEval("graph");
    arg, name, res: GEFClass.S_exp;
  BEGIN
    TRY
      interp.pushScope();
      WHILE args # NIL DO
        arg := RefListUtils.Pop(args);
        TYPECASE arg OF
        | NULL => RETURN interp.error("Bad binding: NIL name");
        | RefList.T (bind) =>
            name := RefListUtils.Pop(bind);
            TYPECASE name OF
            | NULL => RETURN interp.error("Bad binding name: ()");
            | SLisp.String (str) =>
                EVAL
                  interp.lookup(
                    Atom.FromText(str), SLispClass.LookupMode.CreateLocal);
                interp.defineVar(str, EvalList(interp, bind));
            | SLisp.Symbol (sym) =>
                EVAL
                  interp.lookup(sym, SLispClass.LookupMode.CreateLocal);
                interp.defineVar(Atom.ToText(sym), EvalList(interp, bind));
            ELSE
              RETURN interp.error(
                       "Bad binding name: " & SLispClass.SxToText(name));
            END;
        ELSE
          RETURN interp.error("Bad binding: " & SLispClass.SxToText(arg));
        END;
      END;
      res := GEFClass.CreateElemFromPO(graph, self.po);
      interp.popScope();
      RETURN res;
    EXCEPT
    | GEFError.T (msg) =>
        RETURN interp.error(msg); (* raises SLisp.Error *)
    | Thread.Alerted => RAISE SLisp.Error;
    END;
  END ParseLisp;

PROCEDURE Set (<* UNUSED *> self  : SLisp.Builtin;
                            interp: SLisp.T;
                            args  : RefList.T         ): GEFClass.S_exp
  RAISES {SLisp.Error} =
  <* FATAL Sx.PrintError *>
  VAR
    elem, res: GEFClass.S_exp;
    graph    : GEFClass.T;
  BEGIN
    TRY
      graph := interp.varEval("graph");
      elem := interp.eval(args.head);
      args := args.tail;
      WHILE args # NIL DO
        TYPECASE args.head OF
        | NULL => RETURN interp.error("empty binding given to \"set\"");
        | RefList.T (l) =>
            IF RefList.Length(l) >= 2 THEN
              res := EvalList(interp, l.tail);
              GEFClass.SetProp(graph, elem, l.head, res)
            ELSE
              RETURN
                interp.error(
                  "not enough items in a \"name\\values\" binding to \"set\"");
            END;
        ELSE
          RETURN interp.error(
                   "all items to \"set\" must be \"name\\values\" bindings");
        END;
        args := args.tail;
      END;
      RETURN res
    EXCEPT
    | Thread.Alerted => RAISE SLisp.Error
    | GEFError.T (msg) =>
        RETURN interp.error(msg); (* raises SLisp.Error *)
    END;
  END Set;

PROCEDURE Get (<* UNUSED *> self  : SLisp.Builtin;
                            interp: SLisp.T;
                            args  : RefList.T         ): GEFClass.S_exp
  RAISES {SLisp.Error} =
  <* FATAL Sx.PrintError *>
  BEGIN
    TRY
      (* evaluate the first argument to get an element *)
      RETURN GEFClass.GetProp(interp.varEval("graph"), interp.eval(args.head),
                          args.tail.head);
    EXCEPT
    | Thread.Alerted => RAISE SLisp.Error
    | GEFError.T (msg) =>
        RETURN interp.error(msg); (* raises SLisp.Error *)
    END;
  END Get;

PROCEDURE Delete (<* UNUSED *> self  : SLisp.Builtin;
                               interp: SLisp.T;
                               args  : RefList.T         ): GEFClass.S_exp
  RAISES {SLisp.Error} =
  VAR graph: GEFClass.T;
  <* FATAL Sx.PrintError *>
  BEGIN
    TRY
      graph := interp.varEval("graph");
      WHILE args # NIL DO
        GEFClass.Delete(graph, interp.eval(args.head));
        args := args.tail;
      END;
      RETURN NIL
    EXCEPT
    | Thread.Alerted => RAISE SLisp.Error
    | GEFError.T (msg) =>
        RETURN interp.error(msg); (* raises SLisp.Error *)
    END;
  END Delete;

PROCEDURE InvokeEvent (t          : T;
                       event      : TEXT;
                       args       : RefList.T;
                       nonEventsOK              := TRUE)
  RAISES {GEFError.T, Thread.Alerted} =
  <* FATAL SLisp.Error *>
  BEGIN
    WITH atom = Atom.FromText(event),
         fun  = t.interp.lookup(atom, SLispClass.LookupMode.LookupOnly) DO
      TRY
        IF fun # NIL AND fun.funDefined THEN
          EVAL t.interp.eval(RefList.Cons(atom, args));
        ELSIF NOT nonEventsOK THEN
          EVAL t.interp.error(Fmt.F("Event \"%s\" undefined in view", event));
        END;
      EXCEPT
      | SLisp.Error => RAISE Thread.Alerted;
      END;
    END;
  END InvokeEvent;
Convert Atom.Ts back into TEXTs
PROCEDURE DeAtom (l: RefList.T): RefList.T =
  VAR ll := l;
  BEGIN
    WHILE ll # NIL DO
      TYPECASE ll.head OF
      | Atom.T (at) => ll.head := Atom.ToText(at)
      ELSE
      END;
      ll := ll.tail;
    END;
    RETURN l;
  END DeAtom;

PROCEDURE EventData (t1, t2, t3, t4, t5, t6, t7, t8, t9, t10: TEXT := ""):
  RefList.T =
  <* FATAL Sx.ReadError, Rd.EndOfFile, Thread.Alerted *>
  BEGIN
    RETURN
      DeAtom(Sx.Read(TextRd.New(Fmt.F("(%s %s %s %s %s ", t1, t2, t3, t4, t5)
                           & Fmt.F("%s %s %s %s %s)", t6, t7, t8, t9, t10))));
  END EventData;

PROCEDURE Print (<*UNUSED*> self  : SLisp.Builtin;
                            interp: SLisp.T;
                            args  : SLisp.List     ): SLisp.Sexp
  RAISES {SLisp.Error} =
  VAR
    wr  := TextWr.New();
    res := args;
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    WHILE args # NIL DO
      SLisp.Write(wr, interp.eval(args.head));
      args := args.tail;
    END;
    ZeusPanel.ReportError(TextWr.ToText(wr));
    RETURN res;
  END Print;

PROCEDURE Backtrace (<*UNUSED*> self  : SLisp.Builtin;
                                interp: SLisp.T;
                                args  : SLisp.List     ): SLisp.Sexp
  RAISES {SLisp.Error} =
  VAR
    frame  := interp.frame;
    stdout := TextWr.New();
  <* FATAL Wr.Failure, Thread.Alerted *>
  BEGIN
    IF interp.depth > 0 THEN
      SLisp.Write(stdout, interp.underEval.tail.head);
      Wr.PutText(stdout, ")\n");
    END;
    WHILE frame # interp.topFrame DO
      IF frame.procName = NIL OR Text.Length(frame.procName) = 0 THEN
        Wr.PutText(stdout, "  (let");
      ELSE
        Wr.PutText(stdout, "  (" & frame.procName);
      END;
      FOR i := 0 TO frame.size - 1 DO
        Wr.PutText(stdout, " ");
        WITH atom = frame.table[i].atom,
             sym  = frame.table[i].symbol DO
          IF sym # NIL THEN
            Wr.PutText(stdout, Atom.ToText(sym));
            Wr.PutText(stdout, ": ");
          END;
          SLisp.Write(stdout, atom.val);
        END;
      END;
      Wr.PutText(stdout, ")\n");
      Wr.Flush(stdout);
      frame := frame.next;
    END;
    ZeusPanel.ReportError(TextWr.ToText(stdout));
    RETURN args;
  END Backtrace;

BEGIN
END GEFLisp.