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.