Copyright (C) 1994, Digital Equipment Corp.
MODULE GEFClass;
IMPORT Atom, Color, ColorName, Fmt, Font, FormsVBT, GEF, GEFError, GEFLisp,
GraphVBT, GraphVBTExtras, IntRefTbl, RefList, RefListUtils, PaintOp,
Rd, Scan, SLisp, SLispClass, Sx, Text, TextRd, TextWr, TextRefTbl,
Thread, VBT, Wr, Lex, FloatMode;
<* PRAGMA LL *>
<* FATAL Fatal, Sx.PrintError *>
EXCEPTION Fatal;
TYPE
Vals = REFANY; (* Ints, Bools, Reals, Texts, Elems, etc.
for calling set methods *)
Value = RECORD
sx : RefList.T; (* S_exp describing the value *)
vals: Vals;
END;
Values = REF ARRAY OF Value; (* one value per field defined for the
object *)
Obj = OBJECT
name : TEXT;
elem : Elem;
sx : RefList.T;
start, end: CARDINAL;
values : Values;
END;
CONST
Infinity = LAST(INTEGER);
VAR (* CONST *)
RInfinity: RInt; (* := Infinity *)
REVEAL
GEF.T = TPublic BRANDED OBJECT
elemToObj: IntRefTbl.T;
names: TextRefTbl.T;
OVERRIDES
init := InitT;
END;
CONST
NamePrefix = "GEF #";
NamePrefixLength = 5;
NameIDInit = 100000;
VAR
nameID: INTEGER; (* := NameIDInit; *)
PROCEDURE GenName(): TEXT =
BEGIN
INC(nameID);
RETURN NamePrefix & Fmt.Int(nameID)
END GenName;
PROCEDURE InitT(t: T; interp: SLisp.T): GEF.T =
BEGIN
t.interp := interp;
interp.defineVar("graph", t);
AddPOsToInterp(interp);
EVAL GraphVBT.T.init(t);
RETURN t;
END InitT;
PROCEDURE AddPOsToInterp (interp: SLisp.T) =
<* FATAL SLisp.Error *>
BEGIN
GEFLisp.RegisterFuns(interp);
FOR i := 0 TO LAST(parseObjects^) DO
WITH po = parseObjects[i] DO
IF po # NIL THEN
GEFLisp.RegisterPO(interp, Atom.ToText(po.name), po);
END;
END;
END;
END AddPOsToInterp;
******************************** Parsing *********************
TYPE
FieldType = {Boolean, Integer, Real, Text, Sx, Elem, ColorSpec, FontSpec, Enum};
Field = RECORD
name : Name;
index : INTEGER;
type : FieldType;
count : INTEGER;
enums : Names;
entries : Names;
fvNames : Texts;
END;
Fields = REF ARRAY OF Field;
REVEAL
ParseObject = POPublic BRANDED OBJECT
name : Name;
fields: Fields;
values: Values;
OVERRIDES
create := POC;
delete := POD;
setInt := POSI;
setReal := POSR;
setBool := POSB;
setText := POST;
setElem := POSE;
getId := POGID;
finish := POF;
isType := POIT;
END;
PROCEDURE POC (<* UNUSED *> po: ParseObject;
<* UNUSED *> t : T;
<* UNUSED *> id: INTEGER ): REFANY =
BEGIN
RAISE Fatal
END POC;
PROCEDURE POD (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
<* UNUSED *> elem: Elem ) =
BEGIN
RAISE Fatal
END POD;
PROCEDURE POSI (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
<* UNUSED *> elem : Elem;
<* UNUSED *> field: INTEGER;
<* UNUSED *> vals: Ints ) RAISES {GEFError.T} =
BEGIN
RAISE Fatal
END POSI;
PROCEDURE POSR (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
<* UNUSED *> elem : Elem;
<* UNUSED *> field: INTEGER;
<* UNUSED *> vals: Reals ) RAISES {GEFError.T} =
BEGIN
RAISE Fatal
END POSR;
PROCEDURE POSB (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
<* UNUSED *> elem : Elem;
<* UNUSED *> field: INTEGER;
<* UNUSED *> vals: Bools ) RAISES {GEFError.T} =
BEGIN
RAISE Fatal
END POSB;
PROCEDURE POST (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
<* UNUSED *> elem : Elem;
<* UNUSED *> field: INTEGER;
<* UNUSED *> vals: Texts ) RAISES {GEFError.T} =
BEGIN
RAISE Fatal
END POST;
PROCEDURE POSE (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
<* UNUSED *> elem : Elem;
<* UNUSED *> field: INTEGER;
<* UNUSED *> vals: Elems ) RAISES {GEFError.T} =
BEGIN
RAISE Fatal
END POSE;
PROCEDURE POF (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
<* UNUSED *> elem: Elem ) RAISES {GEFError.T} =
BEGIN
RAISE Fatal
END POF;
PROCEDURE POIT (<* UNUSED *> po: ParseObject; <* UNUSED *> elem: Elem):
BOOLEAN =
BEGIN
RAISE Fatal
END POIT;
PROCEDURE POGID (<* UNUSED *> po : ParseObject;
<* UNUSED *> t : T;
<* UNUSED *> elem: Elem ): INTEGER =
BEGIN
RAISE Fatal
END POGID;
PROCEDURE POFromName(name: Name): ParseObject RAISES {GEFError.T} =
BEGIN
FOR i := 0 TO LAST(parseObjects^) DO
IF parseObjects[i] # NIL AND parseObjects[i].name = name THEN
RETURN parseObjects[i]
END;
END;
RAISE GEFError.T("Expected object name, found: " & Atom.ToText(name));
END POFromName;
PROCEDURE ValsFromSx ( t : T;
READONLY field : Field;
sx : S_exp;
defaults: BOOLEAN := FALSE): Vals
RAISES {GEFError.T, Thread.Alerted} =
VAR
l : RefList.T;
len: INTEGER;
BEGIN
IF sx = NIL THEN
len := field.count;
IF len = Infinity THEN len := 0 END;
IF ((field.count # Infinity) AND NOT defaults) THEN
RAISE GEFError.T("No values given for field: " & Atom.ToText(field.name))
END;
ELSE
l := NarrowToList(sx, "Expected a value list, found: ");
len := RefList.Length(l);
(* Allow (Pos (0.2 0.3)) *)
IF len = 1 AND ISTYPE(l.head, RefList.T) THEN
l := l.head;
len := RefList.Length(l);
IF field.type = FieldType.Boolean AND len = 0 THEN
(* lisp represents FALSE = nil = () *)
l := sx;
len := 1;
ELSE
sx := l;
END;
END;
IF NOT ((field.count = Infinity) OR (field.count = len)
OR (field.type = FieldType.FontSpec)
OR ((field.type = FieldType.ColorSpec)
AND (field.count * 3 = len))) THEN
RAISE GEFError.T(
"Wrong number of values for field: " & Atom.ToText(field.name))
END;
IF field.count # Infinity THEN len := field.count; END;
END;
CASE field.type OF
| FieldType.Boolean =>
WITH a = NEW(Bools, len) DO
FOR i := 0 TO len - 1 DO a[i] := GetBool(sx, defaults); END;
RETURN a;
END;
| FieldType.Integer =>
WITH a = NEW(Ints, len) DO
FOR i := 0 TO len - 1 DO a[i] := GetInt(sx, defaults); END;
RETURN a;
END;
| FieldType.Enum =>
WITH a = NEW(Ints, len) DO
FOR i := 0 TO len - 1 DO
a[i] := GetEnum(sx, field.enums, defaults);
END;
RETURN a;
END;
| FieldType.Real =>
WITH a = NEW(Reals, len) DO
FOR i := 0 TO len - 1 DO a[i] := GetReal(sx, defaults); END;
RETURN a;
END;
| FieldType.Sx =>
WITH a = NEW(Elems, len) DO
FOR i := 0 TO len - 1 DO a[i] := GetSx(sx, defaults); END;
RETURN a;
END;
| FieldType.Text =>
WITH a = NEW(Texts, len) DO
FOR i := 0 TO len - 1 DO a[i] := GetText(sx, defaults); END;
RETURN a;
END;
| FieldType.ColorSpec =>
WITH a = NEW(Texts, len) DO
FOR i := 0 TO len - 1 DO a[i] := GetColor(sx, defaults); END;
RETURN a;
END;
| FieldType.FontSpec =>
WITH a = NEW(Texts, len) DO
FOR i := 0 TO len - 1 DO a[i] := GetFont(sx, defaults); END;
RETURN a;
END;
| FieldType.Elem =>
WITH a = NEW(Elems, len) DO
FOR i := 0 TO len - 1 DO a[i] := GetElem(t, sx, defaults); END;
RETURN a;
END;
END;
END ValsFromSx;
PROCEDURE SetFieldFromValue ( t : T;
obj : Obj;
po : ParseObject;
READONLY field: Field;
READONLY value: Value )
RAISES {GEFError.T} =
BEGIN
CASE field.type OF
| FieldType.Boolean =>
VAR a: Bools := value.vals;
BEGIN
po.setBool(t, obj.elem, field.index, a);
END;
| FieldType.Integer, FieldType.Enum =>
VAR a: Ints := value.vals;
BEGIN
po.setInt(t, obj.elem, field.index, a);
END;
| FieldType.Real =>
VAR a: Reals := value.vals;
BEGIN
po.setReal(t, obj.elem, field.index, a);
END;
| FieldType.Text, FieldType.ColorSpec, FieldType.FontSpec =>
VAR a: Texts := value.vals;
BEGIN
po.setText(t, obj.elem, field.index, a);
END;
| FieldType.Elem, FieldType.Sx =>
VAR a: Elems := value.vals;
BEGIN
po.setElem(t, obj.elem, field.index, a);
END;
END;
END SetFieldFromValue;
PROCEDURE ListFromValues (values: Vals): RefList.T =
VAR res: RefList.T;
BEGIN
TYPECASE values OF
| NULL =>
| Bools (v) =>
FOR i := LAST(v^) TO 0 BY -1 DO
WITH a = NEW(RBool) DO a^ := v[i]; RefListUtils.Push(res, a); END;
END;
| Ints (v) =>
FOR i := LAST(v^) TO 0 BY -1 DO
WITH a = NEW(RInt) DO a^ := v[i]; RefListUtils.Push(res, a); END;
END;
| Reals (v) =>
FOR i := LAST(v^) TO 0 BY -1 DO
WITH a = NEW(RReal) DO a^ := v[i]; RefListUtils.Push(res, a); END;
END;
| Texts (v) =>
FOR i := LAST(v^) TO 0 BY -1 DO RefListUtils.Push(res, v[i]); END;
| Elems (v) =>
FOR i := LAST(v^) TO 0 BY -1 DO RefListUtils.Push(res, v[i]); END;
ELSE
RAISE Fatal;
END;
RETURN res;
END ListFromValues;
PROCEDURE CopyValues (values: Values): Values =
VAR res: Values;
BEGIN
res := NEW(Values, NUMBER(values^));
FOR i := 0 TO LAST(values^) DO
res[i].sx := values[i].sx;
TYPECASE values[i].vals OF
| NULL =>
| Bools (v) =>
VAR r: Bools := NEW(Bools, NUMBER(v^));
BEGIN
r^ := v^;
res[i].vals := r;
END;
| Ints (v) =>
VAR r: Ints := NEW(Ints, NUMBER(v^));
BEGIN
r^ := v^;
res[i].vals := r;
END;
| Reals (v) =>
VAR r: Reals := NEW(Reals, NUMBER(v^));
BEGIN
r^ := v^;
res[i].vals := r;
END;
| Texts (v) =>
VAR r: Texts := NEW(Texts, NUMBER(v^));
BEGIN
r^ := v^;
res[i].vals := r;
END;
| Elems (v) =>
VAR r: Elems := NEW(Elems, NUMBER(v^));
BEGIN
r^ := v^;
res[i].vals := r;
END;
ELSE
RAISE Fatal;
END;
END;
RETURN res;
END CopyValues;
PROCEDURE LookupFields (t: T; obj: Obj; po: ParseObject)
RAISES {GEFError.T, Thread.Alerted, SLisp.Error} =
VAR sx: S_exp;
BEGIN
sx := t.interp.varEval("Name");
IF sx # NIL THEN
t.interp.defineVar("Name", NIL); (* don't reuse names in environment *)
obj.name := GetText(sx);
IF sx # NIL THEN
RAISE GEFError.T(
"Unexpected stuff found in name field: " & SLispClass.SxToText(sx));
END;
ELSE
obj.name := GenName();
END;
obj.values := CopyValues(po.values);
FOR i := 0 TO LAST(po.fields^) DO
WITH field = po.fields[i] DO
IF field.name # NIL THEN
WITH value = t.interp.varEval(Atom.ToText(field.name)) DO
IF value = NIL THEN
obj.values[i] := po.values[i];
ELSE
TYPECASE value OF
| RefList.T =>
obj.values[i].sx := value;
ELSE
obj.values[i].sx := RefList.List1(value);
END;
obj.values[i].vals := ValsFromSx(t, field, obj.values[i].sx);
END;
SetFieldFromValue(t, obj, po, field, obj.values[i]);
END;
END;
END;
END
END LookupFields;
VAR
uid: INTEGER;
PROCEDURE NewId (): INTEGER =
BEGIN
INC(uid);
RETURN uid;
END NewId;
PROCEDURE Parse (t : T;
sx : S_exp;
showAllElements: BOOLEAN ) RAISES {Thread.Alerted} =
BEGIN
LOCK mu DO
nameID := NameIDInit;
t.elemToObj := NEW(IntRefTbl.Default).init();
t.names := NEW(TextRefTbl.Default).init();
t.showAllElements := showAllElements;
t.clear();
EVAL t.interp.init();
t.interp.defineVar("graph", t);
AddPOsToInterp(t.interp);
END;
TRY
TRY
IF NOT t = CreateElemFromPO(t, ParseObjectFromElem(t)) THEN
RAISE Fatal
END;
EXCEPT
| GEFError.T (msg) => EVAL t.interp.error(msg);
END;
EVAL t.interp.eval(sx);
VBT.Mark(t);
EXCEPT
| SLisp.Error => RAISE Thread.Alerted;
END;
END Parse;
PROCEDURE IncrementalParse (t: T; sx: S_exp) RAISES {Thread.Alerted} =
BEGIN
TRY
EVAL t.interp.eval(sx);
EXCEPT
| SLisp.Error => RAISE Thread.Alerted;
END;
END IncrementalParse;
PROCEDURE ParseObjectFromElem (elem: Elem): ParseObject =
BEGIN
LOCK mu DO RETURN POFromElemInternal(elem) END;
END ParseObjectFromElem;
PROCEDURE POFromElemInternal (elem: Elem): ParseObject =
BEGIN
IF elem = NIL THEN RAISE Fatal END;
FOR i := 0 TO LAST(parseObjects^) DO
IF parseObjects[i] # NIL AND parseObjects[i].isType(elem) THEN
RETURN parseObjects[i]
END;
END;
RAISE Fatal;
END POFromElemInternal;
------------------------- GEFLisp utilities ----------------------
PROCEDURE CreateElemFromPO (t: T; po: ParseObject): Elem
RAISES {GEFError.T, Thread.Alerted} =
VAR
obj := NEW(Obj);
ra : REFANY;
BEGIN
TRY
obj.elem := po.create(t, NewId());
LookupFields(t, obj, po);
po.finish(t, obj.elem);
LOCK mu DO
IF t.names.get(obj.name, ra) THEN
RAISE
GEFError.T("There is already an element named: " & obj.name)
END;
EVAL t.names.put(obj.name, obj);
EVAL t.elemToObj.put(po.getId(t, obj.elem), obj);
END;
RETURN obj.elem;
EXCEPT
| SLisp.Error => RAISE Thread.Alerted;
END;
END CreateElemFromPO;
PROCEDURE GetProp (t: T; elem: Elem; prop: S_exp): RefList.T
RAISES {GEFError.T} =
VAR
elem2: Elem;
obj : Obj;
po : ParseObject;
name : Name;
<* FATAL Thread.Alerted *>
BEGIN
LOCK mu DO
elem2 := GetElem(t, elem);
obj := ObjFromElem(t, elem2);
po := POFromElemInternal(elem2);
name := GetName(prop);
IF name = sxName THEN
RETURN RefList.List1(obj.name);
ELSE
FOR i := 0 TO LAST(po.fields^) DO
WITH field = po.fields[i] DO
IF name = field.name THEN
RETURN ListFromValues(obj.values[i].vals);
END;
END;
END;
END;
END;
RAISE
GEFError.T(Fmt.F("No property of element with name: %s", Atom.ToText(name)));
END GetProp;
PROCEDURE SetProp (t: T; elem: Elem; prop: S_exp; value: RefList.T)
RAISES {GEFError.T, Thread.Alerted} =
VAR
elem2: Elem;
obj : Obj;
po : ParseObject;
name : Name;
BEGIN
LOCK mu DO
elem2 := GetElem(t, elem);
obj := ObjFromElem(t, elem2);
po := POFromElemInternal(elem2);
name := GetName(prop);
FOR i := 0 TO LAST(po.fields^) DO
WITH field = po.fields[i] DO
IF prop = field.name THEN
obj.values[i].sx := value;
obj.values[i].vals := ValsFromSx(t, field, value);
SetFieldFromValue(t, obj, po, field, obj.values[i]);
RETURN
END;
END;
END;
END;
RAISE
GEFError.T(Fmt.F("No property of element with name: %s", Atom.ToText(name)));
END SetProp;
PROCEDURE Delete (t: T; elem: Elem) RAISES {GEFError.T, Thread.Alerted} =
VAR
val : REFANY;
elem2: Elem;
po : ParseObject;
obj : Obj;
BEGIN
LOCK mu DO
elem2 := GetElem(t, elem);
po := POFromElemInternal(elem2);
obj := ObjFromElem(t, elem2);
EVAL t.elemToObj.delete(po.getId(t, elem2), val);
EVAL t.names.delete(obj.name, val);
po.delete(t, elem2);
END;
END Delete;
*************************** Ranges ***********************
PROCEDURE GetRange (t: T; elem: Elem; VAR (* OUT *) start, end: CARDINAL) =
BEGIN
LOCK mu DO
WITH obj = ObjFromElem(t, elem) DO
start := obj.start;
end := obj.end;
END;
END;
END GetRange;
PROCEDURE AdjustRange (i, start: CARDINAL; delta: INTEGER): CARDINAL =
BEGIN
IF i > start THEN RETURN i - delta ELSE RETURN i END;
END AdjustRange;
PROCEDURE UpdateRange (t: T; elem: Elem; start, end, length: CARDINAL) =
VAR
delta := (end - start) - length;
value: REFANY;
key : INTEGER;
iter : IntRefTbl.Iterator;
BEGIN
LOCK mu DO
iter := t.elemToObj.iterate();
WHILE iter.next(key, value) DO
WITH obj = NARROW(value, Obj) DO
obj.start := AdjustRange(obj.start, start, delta);
obj.end := AdjustRange(obj.end, start, delta);
END
END;
WITH obj = ObjFromElem(t, elem) DO obj.end := start + length; END;
END;
END UpdateRange;
************************ Elem to/from FormsVBT.T *****************
PROCEDURE FieldFVName(READONLY field: Field; i: INTEGER): TEXT =
BEGIN
IF field.count = Infinity THEN
RETURN field.fvNames[0];
ELSE
RETURN field.fvNames[i]
END;
END FieldFVName;
PROCEDURE SetFieldsFromObj (t: T; po: ParseObject; obj: Obj; fv: FormsVBT.T) =
<* FATAL GEFError.T, FormsVBT.Error, FormsVBT.Unimplemented,
Wr.Failure, Thread.Alerted *>
VAR
count: INTEGER;
wr : Wr.T;
BEGIN
FOR i := 0 TO LAST(po.fields^) DO
WITH field = po.fields[i] DO
IF field.name # NIL THEN
count := field.count;
CASE field.type OF
| FieldType.Boolean =>
VAR values: Bools := obj.values[i].vals;
BEGIN
<* ASSERT count # Infinity *>
FOR j := 0 TO count - 1 DO
FormsVBT.PutBoolean(fv, FieldFVName(field, j), values[j]);
END;
END;
| FieldType.Integer =>
VAR values: Ints := obj.values[i].vals;
BEGIN
<* ASSERT count # Infinity *>
FOR j := 0 TO count - 1 DO
FormsVBT.PutInteger(fv, FieldFVName(field, j), values[j]);
END;
END;
| FieldType.Real =>
VAR values: Reals := obj.values[i].vals;
BEGIN
<* ASSERT count # Infinity *>
FOR j := 0 TO count - 1 DO
FormsVBT.PutText(
fv, FieldFVName(field, j), Fmt.Real(values[j]));
END;
END;
| FieldType.Text, FieldType.ColorSpec, FieldType.FontSpec =>
VAR values: Texts := obj.values[i].vals;
BEGIN
IF count = Infinity THEN
wr := TextWr.New();
FOR j := 0 TO LAST(values^) DO
Wr.PutText(wr, Fmt.F("\"%s\" ", values[i]));
END;
FormsVBT.PutText(
fv, FieldFVName(field, 0), TextWr.ToText(wr));
ELSE
FOR j := 0 TO count - 1 DO
FormsVBT.PutText(fv, FieldFVName(field, j), values[j]);
END;
END;
END;
| FieldType.Sx =>
VAR values: Elems := obj.values[i].vals;
<* FATAL Sx.PrintError *>
BEGIN
IF count = Infinity THEN
wr := TextWr.New();
FOR j := 0 TO LAST(values^) DO
Wr.PutText(wr, Fmt.F("\"%s\" ", SLispClass.SxToText(values[j])));
END;
FormsVBT.PutText(
fv, FieldFVName(field, 0), TextWr.ToText(wr));
ELSE
FOR j := 0 TO count - 1 DO
FormsVBT.PutText(
fv, FieldFVName(field, j), SLispClass.SxToText(values[j]));
END;
END;
END;
| FieldType.Elem =>
VAR values: Elems := obj.values[i].vals;
BEGIN
IF count = Infinity THEN
wr := TextWr.New();
FOR j := 0 TO LAST(values^) DO
Wr.PutText(
wr, Fmt.F("\"%s\" ", NameFromElemInternal(t, values[j])));
END;
FormsVBT.PutText(
fv, FieldFVName(field, 0), TextWr.ToText(wr));
ELSE
FOR j := 0 TO count - 1 DO
FormsVBT.PutText(fv, FieldFVName(field, j),
NameFromElemInternal(t, values[j]));
END;
END;
END;
| FieldType.Enum =>
VAR values: Ints := obj.values[i].vals;
BEGIN
<* ASSERT count # Infinity *>
FOR j := 0 TO count - 1 DO
FormsVBT.PutChoice(
fv, FieldFVName(field, j),
FieldFVName(field, j) & Atom.ToText(field.enums[values[j]]));
END;
END;
END;
END;
END;
END;
END SetFieldsFromObj;
PROCEDURE GetFV(t: T; elem: Elem): FormsVBT.T =
VAR
fv: FormsVBT.T;
po: ParseObject;
obj: Obj;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented *>
BEGIN
LOCK mu DO
po := POFromElemInternal(elem);
IF po.fv = NIL THEN
po.fv := FVFromArgs(po);
END;
fv := NEW(FormsVBT.T).init(po.fv);
obj := ObjFromElem(t, elem);
FormsVBT.PutText(fv, "ElemType", Atom.ToText(po.name));
FormsVBT.PutText(fv, "Name", obj.name);
SetFieldsFromObj(t, po, obj, fv);
END;
RETURN fv;
END GetFV;
PROCEDURE SetFVFromElem(t: T; elem: Elem; fv: FormsVBT.T) =
VAR
po: ParseObject;
obj: Obj;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented *>
BEGIN
LOCK mu DO
po := POFromElemInternal(elem);
obj := ObjFromElem(t, elem);
FormsVBT.PutText(fv, "ElemType", Atom.ToText(po.name));
FormsVBT.PutText(fv, "Name", obj.name);
SetFieldsFromObj(t, po, obj, fv);
END;
END SetFVFromElem;
PROCEDURE AddParseObjectsToMenu (fv : FormsVBT.T;
menu : TEXT;
closure: InstallClosure) =
<* FATAL FormsVBT.Error *>
BEGIN
FOR i := 0 TO LAST(parseObjects^) DO
IF parseObjects[i] # NIL THEN
WITH nm = Atom.ToText(parseObjects[i].name) DO
EVAL FormsVBT.Insert(fv, menu, Fmt.F("(MButton %%s \"%s\")", nm, nm));
FormsVBT.AttachProc(fv, nm, POProc, closure);
END;
END;
END;
END AddParseObjectsToMenu;
PROCEDURE POProc (<* UNUSED *> fv : FormsVBT.T;
name: TEXT;
ra : REFANY;
<* UNUSED *> time: VBT.TimeStamp) =
VAR
cl: InstallClosure := ra;
nm := Atom.FromText(name);
po: ParseObject;
fv2: FormsVBT.T;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented, GEFError.T *>
BEGIN
LOCK mu DO
po := POFromName(nm);
IF po.fv = NIL THEN po.fv := FVFromArgs(po); END;
END;
fv2 := NEW(FormsVBT.T).init(po.fv);
FormsVBT.PutText(fv2, "ElemType", Atom.ToText(po.name));
cl.install(fv2);
END POProc;
PROCEDURE UpdateBoolsFieldFromFV ( fv : FormsVBT.T;
READONLY field: Field;
vals : Bools ): BOOLEAN =
VAR
val : BOOLEAN;
changed := FALSE;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented *>
BEGIN
<* ASSERT field.count # Infinity *>
FOR j := 0 TO field.count - 1 DO
val := FormsVBT.GetBoolean(fv, FieldFVName(field, j));
IF val # vals[j] THEN vals[j] := val; changed := TRUE; END;
END;
RETURN changed;
END UpdateBoolsFieldFromFV;
PROCEDURE SxFromBools (vals, defaults: Bools): S_exp =
VAR
l: RefList.T;
r: RBool;
BEGIN
IF NUMBER(vals^) = NUMBER(defaults^) AND vals^ = defaults^ THEN
RETURN NIL
ELSE
FOR i := LAST(vals^) TO 0 BY -1 DO
r := NEW(RBool);
r^ := vals[i];
RefListUtils.Push(l, r);
END;
RETURN l;
END;
END SxFromBools;
PROCEDURE UpdateIntsFieldFromFV ( fv : FormsVBT.T;
READONLY field: Field;
vals : Ints ): BOOLEAN =
VAR
val : INTEGER;
changed := FALSE;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented *>
BEGIN
<* ASSERT field.count # Infinity *>
FOR j := 0 TO field.count - 1 DO
val := FormsVBT.GetInteger(fv, FieldFVName(field, j));
IF val # vals[j] THEN vals[j] := val; changed := TRUE; END;
END;
RETURN changed;
END UpdateIntsFieldFromFV;
PROCEDURE SxFromInts (vals, defaults: Ints): S_exp =
VAR
l: RefList.T;
r: RInt;
BEGIN
IF NUMBER(vals^) = NUMBER(defaults^) AND vals^ = defaults^ THEN
RETURN NIL
ELSE
FOR i := LAST(vals^) TO 0 BY -1 DO
r := NEW(RInt);
r^ := vals[i];
RefListUtils.Push(l, r);
END;
RETURN l;
END;
END SxFromInts;
PROCEDURE UpdateEnumsFieldFromFV ( fv : FormsVBT.T;
READONLY field: Field;
vals : Ints ): BOOLEAN =
VAR
val : INTEGER;
changed := FALSE;
txt : TEXT;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented, GEFError.T *>
BEGIN
<* ASSERT field.count # Infinity *>
FOR j := 0 TO field.count - 1 DO
txt := FormsVBT.GetChoice(fv, FVName(field.name, field.entries, j));
(* choiceName is a concatenation of fieldName and the enumName;
return the enumName *)
txt := Text.Sub(txt, Text.Length(Atom.ToText(field.name)), LAST(CARDINAL));
val := GetEnum1(Atom.FromText(txt), field.enums);
IF val # vals[j] THEN vals[j] := val; changed := TRUE; END;
END;
RETURN changed;
END UpdateEnumsFieldFromFV;
PROCEDURE SxFromEnums (vals, defaults: Ints; enums: Names): S_exp =
VAR l: RefList.T;
BEGIN
IF NUMBER(vals^) = NUMBER(defaults^) AND vals^ = defaults^ THEN
RETURN NIL
ELSE
FOR i := LAST(vals^) TO 0 BY -1 DO RefListUtils.Push(l, enums[vals[i]]); END;
RETURN l;
END;
END SxFromEnums;
PROCEDURE UpdateRealsFieldFromFV ( fv : FormsVBT.T;
READONLY field: Field;
vals : Reals ): BOOLEAN =
VAR
val : REAL;
changed := FALSE;
text : TEXT;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented *>
BEGIN
<* ASSERT field.count # Infinity *>
TRY
FOR j := 0 TO field.count - 1 DO
text := FormsVBT.GetText(fv, FieldFVName(field, j));
val := Scan.Real(text);
IF val # vals[j] THEN vals[j] := val; changed := TRUE; END;
END;
EXCEPT
| Lex.Error, FloatMode.Trap => ReportError(fv, "Bad real value: " & text);
END;
RETURN changed;
END UpdateRealsFieldFromFV;
PROCEDURE SxFromReals (vals, defaults: Reals): S_exp =
VAR
l: RefList.T;
r: RReal;
BEGIN
IF NUMBER(vals^) = NUMBER(defaults^) AND vals^ = defaults^ THEN
RETURN NIL
ELSE
FOR i := LAST(vals^) TO 0 BY -1 DO
r := NEW(RReal);
r^ := vals[i];
RefListUtils.Push(l, r);
END;
RETURN l;
END;
END SxFromReals;
PROCEDURE UpdateSxsFieldFromFV ( fv : FormsVBT.T;
READONLY field: Field;
vals : Elems ): BOOLEAN
RAISES {GEFError.T} =
VAR
changed := FALSE;
text, sxOld, sxNew: TEXT;
new : Elems;
list : RefList.T;
sx : S_exp;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented, Thread.Alerted *>
BEGIN
IF field.count = Infinity THEN
text := FormsVBT.GetText(fv, FieldFVName(field, 0));
TRY
list := SxFromText(Fmt.F("(%s)", text));
EXCEPT
Sx.ReadError, Rd.EndOfFile =>
RAISE GEFError.T("Bad format for Sx expressions: " & text);
END;
new := NEW(Elems, RefList.Length(list));
changed := NUMBER(new^) # NUMBER(vals^);
FOR j := 0 TO LAST(new^) DO
sx := RefListUtils.Pop(list);
sxNew := SLispClass.SxToText(sx);
sxOld := SLispClass.SxToText(vals[j]);
IF NOT Text.Equal(sxOld, sxNew) THEN
new[j] := sx;
changed := TRUE;
END;
END;
IF changed THEN vals := new END;
ELSE
FOR j := 0 TO field.count - 1 DO
text := FormsVBT.GetText(fv, FieldFVName(field, j));
sxOld := SLispClass.SxToText(vals[j]);
IF NOT Text.Equal(text, sxOld) THEN
TRY
vals[j] := SxFromText(text);
EXCEPT
| Sx.ReadError, Rd.EndOfFile =>
RAISE GEFError.T("Bad value for Sx expression: " & text);
END;
changed := TRUE;
END;
END;
END;
RETURN changed;
END UpdateSxsFieldFromFV;
PROCEDURE SxFromSxs (vals, defaults: Elems): S_exp =
VAR
l: RefList.T;
BEGIN
IF NUMBER(vals^) = NUMBER(defaults^) AND vals^ = defaults^ THEN
RETURN NIL
ELSE
FOR i := LAST(vals^) TO 0 BY -1 DO RefListUtils.Push(l, vals[i]); END;
RETURN l;
END;
END SxFromSxs;
PROCEDURE UpdateTextsFieldFromFV ( fv : FormsVBT.T;
READONLY field: Field;
VAR (* in/out *) vals : Texts ):
BOOLEAN RAISES {GEFError.T} =
VAR
val : TEXT;
changed := FALSE;
new : Texts;
list : RefList.T;
sx : S_exp;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented, Rd.EndOfFile, Thread.Alerted *>
BEGIN
IF field.count = Infinity THEN
val := FormsVBT.GetText(fv, FieldFVName(field, 0));
TRY
list := SxFromText(Fmt.F("(%s)", val));
EXCEPT
Sx.ReadError =>
RAISE GEFError.T("Bad format for texts expression: " & val);
END;
new := NEW(Texts, RefList.Length(list));
changed := NUMBER(new^) # NUMBER(vals^);
sx := list;
FOR j := 0 TO LAST(new^) DO
new[j] := GetText(sx);
changed := changed OR NOT Text.Equal(new[j], vals[j]);
END;
IF changed THEN vals := new END;
ELSE
FOR j := 0 TO field.count - 1 DO
val := FormsVBT.GetText(fv, FieldFVName(field, j));
IF val # vals[j] THEN vals[j] := val; changed := TRUE; END;
END;
END;
RETURN changed;
END UpdateTextsFieldFromFV;
PROCEDURE SxFromTexts (vals, defaults: Texts): S_exp =
VAR l: RefList.T;
BEGIN
IF NUMBER(vals^) = NUMBER(defaults^) AND vals^ = defaults^ THEN
RETURN NIL
ELSE
FOR i := LAST(vals^) TO 0 BY -1 DO RefListUtils.Push(l, vals[i]); END;
RETURN l;
END;
END SxFromTexts;
PROCEDURE UpdateElemsFieldFromFV ( t : T;
fv : FormsVBT.T;
READONLY field: Field;
VAR (* in/out *) vals : Elems ):
BOOLEAN RAISES {GEFError.T} =
VAR
val : Elem;
changed := FALSE;
new : Elems;
list : RefList.T;
sx : S_exp;
text : TEXT;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented, Rd.EndOfFile, Thread.Alerted *>
BEGIN
IF field.count = Infinity THEN
text := FormsVBT.GetText(fv, FieldFVName(field, 0));
TRY
list := SxFromText(Fmt.F("(%s)", text));
EXCEPT
Sx.ReadError =>
RAISE GEFError.T("Bad format for elements expression: " & text);
END;
new := NEW(Elems, RefList.Length(list));
changed := NUMBER(new^) # NUMBER(vals^);
sx := list;
FOR j := 0 TO LAST(new^) DO
new[j] := ElemFromNameInternal(t, GetText(sx), TRUE);
changed := changed OR new[j] # vals[j];
END;
IF changed THEN vals := new END;
ELSE
FOR j := 0 TO field.count - 1 DO
val := ElemFromNameInternal(
t, FormsVBT.GetText(fv, FieldFVName(field, j)), TRUE);
IF val # vals[j] THEN vals[j] := val; changed := TRUE; END;
END;
END;
RETURN changed;
END UpdateElemsFieldFromFV;
PROCEDURE SxFromElems (t: T; vals, defaults: Elems; forceFullSx: BOOLEAN):
S_exp =
VAR
l : RefList.T;
obj: Obj;
name: TEXT;
BEGIN
IF NUMBER(vals^) = NUMBER(defaults^) AND vals^ = defaults^ THEN
RETURN NIL
ELSE
FOR i := LAST(vals^) TO 0 BY -1 DO
obj := ObjFromElem(t, vals[i]);
name := obj.name;
IF forceFullSx
OR (Text.Equal(
NamePrefix, Text.Sub(name, 0, NamePrefixLength))) THEN
RefListUtils.Push(l, obj.sx)
ELSE
RefListUtils.Push(l, name);
END;
END;
RETURN l;
END;
END SxFromElems;
PROCEDURE SetObjValuesFromFields (t: T; po: ParseObject; obj: Obj; fv: FormsVBT.T)
RAISES {GEFError.T} =
VAR
elems: Elems;
texts: Texts;
BEGIN
FOR i := 0 TO LAST(po.fields^) DO
WITH field = po.fields[i],
value = obj.values[i],
defaults = po.values[i].vals DO
IF field.name # NIL THEN
TRY
CASE field.type OF
| FieldType.Boolean =>
IF UpdateBoolsFieldFromFV(fv, field, value.vals) THEN
value.sx := SxFromBools(value.vals, defaults);
END;
| FieldType.Integer =>
IF UpdateIntsFieldFromFV(fv, field, value.vals) THEN
value.sx := SxFromInts(value.vals, defaults);
END;
| FieldType.Real =>
IF UpdateRealsFieldFromFV(fv, field, value.vals) THEN
value.sx := SxFromReals(value.vals, defaults);
END;
| FieldType.Text =>
texts := value.vals;
IF UpdateTextsFieldFromFV(fv, field, texts) THEN
value.vals := texts;
value.sx := SxFromTexts(texts, defaults);
END;
| FieldType.Sx =>
elems := value.vals;
IF UpdateSxsFieldFromFV(fv, field, elems) THEN
value.vals := elems;
value.sx := SxFromSxs(value.vals, defaults);
END;
| FieldType.Elem =>
elems := value.vals;
IF UpdateElemsFieldFromFV(t, fv, field, elems) THEN
value.vals := elems;
value.sx := SxFromElems(t, elems, defaults, obj.elem = t);
END;
| FieldType.ColorSpec, FieldType.FontSpec =>
<* ASSERT field.count # Infinity *>
texts := value.vals;
IF UpdateTextsFieldFromFV(fv, field, texts) THEN
value.vals := texts;
value.sx := SxFromTexts(texts, defaults);
END;
| FieldType.Enum =>
IF UpdateEnumsFieldFromFV(fv, field, value.vals) THEN
value.sx := SxFromEnums(value.vals, defaults, field.enums);
END;
END; (* CASE *)
EXCEPT
| GEFError.T (msg) => ReportError(fv, msg);
END;
END; (* IF *)
END; (* WITH *)
END; (* FOR fields *)
END SetObjValuesFromFields;
PROCEDURE SetObjSxFromValues (po: ParseObject; obj: Obj) =
VAR
list: RefList.T;
name: TEXT;
BEGIN
FOR i := LAST(obj.values^) TO 0 BY -1 DO
WITH name = po.fields[i].name,
sx = obj.values[i].sx DO
IF name # NIL AND sx # NIL THEN
RefListUtils.Push(list, RefList.Cons(name, sx))
END;
END;
END;
name := obj.name;
IF NOT Text.Equal(NamePrefix, Text.Sub(name, 0, NamePrefixLength)) THEN
RefListUtils.Push(list, RefList.List2(sxName, name));
END;
RefListUtils.Push(list, po.name);
obj.sx := list;
END SetObjSxFromValues;
PROCEDURE SetElemFromObj (t: T; po: ParseObject; obj: Obj) RAISES {GEFError.T} =
BEGIN
FOR i := 0 TO LAST(po.fields^) DO
WITH field = po.fields[i] DO
IF field.name # NIL THEN
SetFieldFromValue(t, obj, po, field, obj.values[i]);
END;
END;
END;
END SetElemFromObj;
PROCEDURE SetElemFromFV (t: T; elem: Elem; fv: FormsVBT.T)
RAISES {GEFError.T} =
VAR
po : ParseObject;
obj: Obj;
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented *>
BEGIN
LOCK mu DO
po := POFromElemInternal(elem);
WITH formTypeName = Atom.FromText(
FormsVBT.GetText(fv, "ElemType")) DO
IF po.name # formTypeName THEN
RAISE GEFError.T(Fmt.F("Element named is a %s and form is for a %s",
Atom.ToText(po.name), Atom.ToText(formTypeName)));
END;
END;
obj := ObjFromElem(t, elem);
SetObjValuesFromFields(t, po, obj, fv);
SetObjSxFromValues(po, obj);
SetElemFromObj(t, po, obj);
END;
END SetElemFromFV;
PROCEDURE CreateElemFromFV (t: T; fv: FormsVBT.T): REFANY
RAISES {GEFError.T, Thread.Alerted} =
<* FATAL FormsVBT.Error, FormsVBT.Unimplemented *>
VAR
po : ParseObject;
obj := NEW(Obj);
nm := FormsVBT.GetText(fv, "Name");
ra : REFANY;
BEGIN
IF Text.Length(nm) = 0
OR Text.Equal(NamePrefix, Text.Sub(nm, 0, NamePrefixLength)) THEN
RAISE GEFError.T(
"Must give a unique non-\"GEF #\" name to a new element");
END;
LOCK mu DO
po :=
POFromName(Atom.FromText(FormsVBT.GetText(fv, "ElemType")));
END;
obj.elem := po.create(t, NewId());
obj.values := CopyValues(po.values);
SetObjValuesFromFields(t, po, obj, fv);
SetObjSxFromValues(po, obj);
SetElemFromObj(t, po, obj);
po.finish(t, obj.elem);
IF t.names.get(obj.name, ra) THEN
RAISE GEFError.T("There is already an element named: " & obj.name)
END;
EVAL t.names.put(obj.name, obj);
EVAL t.elemToObj.put(po.getId(t, obj.elem), obj);
RETURN obj.elem
END CreateElemFromFV;
PROCEDURE SxFromElem(t: T; elem: Elem): S_exp =
BEGIN
LOCK mu DO
RETURN ObjFromElem(t, elem).sx
END;
END SxFromElem;
PROCEDURE GetElemField (t: T; elem: Elem; field: TEXT): REFANY RAISES{GEFError.T} =
VAR
name := Atom.FromText(field);
obj := ObjFromElem(t, elem);
po : ParseObject;
BEGIN
LOCK mu DO po := POFromElemInternal(elem); END;
FOR i := 0 TO LAST(po.fields^) DO
IF name = po.fields[i].name THEN RETURN obj.values[i].vals END;
END;
RAISE GEFError.T(
Fmt.F("No field named %s for %s element", field, Atom.ToText(po.name)));
END GetElemField;
PROCEDURE UpdateElemField (t: T; elem: Elem; fname: TEXT; vals: REFANY)
RAISES {GEFError.T} =
VAR
name := Atom.FromText(fname);
obj := ObjFromElem(t, elem);
po : ParseObject;
sx : S_exp;
BEGIN
LOCK mu DO po := POFromElemInternal(elem); END;
FOR i := 0 TO LAST(po.fields^) DO
WITH field = po.fields[i],
defaults = po.values[i].vals DO
IF name = field.name THEN
TYPECASE vals OF
| Bools =>
IF field.type # FieldType.Boolean THEN
RAISE GEFError.T(
Fmt.F("Wrong type of values for field %s", fname));
END;
sx := SxFromBools(vals, defaults);
| Ints =>
IF field.type # FieldType.Integer
AND field.type # FieldType.Enum THEN
RAISE GEFError.T(
Fmt.F("Wrong type of values for field %s", fname));
END;
sx := SxFromInts(vals, defaults);
| Reals =>
IF field.type # FieldType.Real THEN
RAISE GEFError.T(
Fmt.F("Wrong type of values for field %s", fname));
END;
sx := SxFromReals(vals, defaults);
| Texts =>
IF field.type # FieldType.Text
AND field.type # FieldType.ColorSpec
AND field.type # FieldType.FontSpec THEN
RAISE GEFError.T(
Fmt.F("Wrong type of values for field %s", fname));
END;
sx := SxFromTexts(vals, defaults);
| Elems =>
IF field.type # FieldType.Elem OR field.type # FieldType.Sx THEN
RAISE GEFError.T(
Fmt.F("Wrong type of values for field %s", fname));
END;
sx := SxFromElems(t, vals, defaults, t = elem);
ELSE
RAISE Fatal;
END;
obj.values[i].vals := vals;
obj.values[i].sx := sx;
RETURN;
END; (* if *)
END; (* with *)
END;
RAISE
GEFError.T(
Fmt.F("No field named %s for %s element", fname, Atom.ToText(po.name)));
END UpdateElemField;
PROCEDURE SetElemField (t: T; elem: Elem; fname: TEXT; vals: REFANY)
RAISES {GEFError.T} =
VAR
obj := ObjFromElem(t, elem);
po : ParseObject;
BEGIN
LOCK mu DO po := POFromElemInternal(elem); END;
UpdateElemField(t, elem, fname, vals);
SetElemFromObj(t, po, obj);
END SetElemField;
*************************** Parsing Utilities ******************
PROCEDURE NextSx (VAR sx: S_exp): S_exp RAISES {GEFError.T} =
VAR
l := NarrowToList(sx, "Expected list, found: ");
entry := RefListUtils.Pop(l);
BEGIN
sx := l;
RETURN entry;
END NextSx;
PROCEDURE ElemFromName (t: T; name: Text.T): Elem RAISES {GEFError.T} =
BEGIN
LOCK mu DO RETURN ElemFromNameInternal(t, name); END;
END ElemFromName;
PROCEDURE ElemFromNameInternal (t: T; name: Text.T; allowNil := FALSE):
Elem RAISES {GEFError.T} =
VAR val: REFANY;
BEGIN
IF t.names.get(name, val) THEN
RETURN NARROW(val, Obj).elem
ELSE
IF allowNil AND Text.Length(name) = 0 THEN
RETURN NIL
ELSE
RAISE GEFError.T("Could not find an element named: " & name)
END;
END;
END ElemFromNameInternal;
PROCEDURE AllElements (t: T): ElementList =
TYPE Counts = REF ARRAY OF RECORD cnt: INTEGER := 0 END;
VAR
counts := NEW(Counts, NUMBER(parseObjects^));
types : INTEGER := 0;
res : ElementList;
key : INTEGER;
value : REFANY;
iter : IntRefTbl.Iterator;
PROCEDURE E1 (obj: Obj) =
BEGIN
FOR i := 0 TO types - 1 DO
IF parseObjects[i].isType(obj.elem) THEN
INC(counts[i].cnt);
END;
END;
RAISE Fatal;
END E1;
PROCEDURE E2 (obj: Obj) =
VAR elem := obj.elem;
BEGIN
FOR i := 0 TO types - 1 DO
IF parseObjects[i].isType(elem) THEN
res[i].names[counts[i].cnt] := obj.name;
INC(counts[i].cnt);
END;
END;
END E2;
BEGIN
(* Get the exact number of ParseObjects, initialize res *)
types := NUMBER(parseObjects^);
FOR i := 0 TO LAST(parseObjects^) DO
IF parseObjects^[i] = NIL THEN types := i; EXIT; END;
END;
res := NEW(ElementList, types);
FOR i := 0 TO types - 1 DO
res[i].type := Atom.ToText(parseObjects[i].name)
END;
(* get counts of each type, and initialize each type's names *)
iter := t.elemToObj.iterate();
WHILE iter.next(key, value) DO E1(value) END;
FOR i := 0 TO types - 1 DO
res[i].names := NEW(REF ARRAY OF TEXT, counts[i].cnt);
counts[i].cnt := 0;
END;
(* Fill in the names of each element *)
iter := t.elemToObj.iterate();
WHILE iter.next(key, value) DO E2(value); END;
RETURN res
END AllElements;
VAR
NullObj: Obj; (* := NEW(Obj, name := ""); *)
PROCEDURE ObjFromElem (t: T; elem: Elem): Obj =
VAR po: ParseObject; val: REFANY;
BEGIN
IF elem = NIL THEN
RETURN NullObj
ELSE
po := POFromElemInternal(elem);
IF NOT t.elemToObj.get(po.getId(t, elem), val) THEN RAISE Fatal END;
RETURN val
END;
END ObjFromElem;
PROCEDURE NameFromElem (t: T; elem: Elem): TEXT =
BEGIN
LOCK mu DO RETURN NameFromElemInternal(t, elem) END;
END NameFromElem;
PROCEDURE NameFromElemInternal (t: T; elem: Elem): TEXT =
BEGIN
RETURN ObjFromElem(t, elem).name
END NameFromElemInternal;
VAR
Bg: Atom.T; (* := Atom.FromText("Bg"); *)
Fg: Atom.T; (* := Atom.FromText("Fg"); *)
PROCEDURE NarrowToList (sx: S_exp; msg: TEXT): RefList.T RAISES {GEFError.T} =
<* FATAL Thread.Alerted *>
BEGIN
TYPECASE sx OF
| NULL => RAISE GEFError.T(msg & "()");
| RefList.T (l) => RETURN l
ELSE
RAISE GEFError.T(msg & SLispClass.SxToText(sx));
END;
END NarrowToList;
PROCEDURE NarrowToInt (sx: S_exp; msg: TEXT): RInt RAISES {GEFError.T} =
<* FATAL Thread.Alerted *>
BEGIN
TYPECASE sx OF
| NULL => RAISE GEFError.T(msg & "()");
| RInt (r) => RETURN r
ELSE
RAISE GEFError.T(msg & SLispClass.SxToText(sx));
END;
END NarrowToInt;
PROCEDURE NextName (VAR (* IN/OUT *) sx: S_exp): Name
RAISES {GEFError.T} =
VAR
l := NarrowToList(sx, "Expected list, found: ");
entry := RefListUtils.Pop(l);
BEGIN
sx := l;
RETURN GetName(entry);
END NextName;
PROCEDURE NextInteger (VAR (* IN/OUT *) sx: S_exp): RInt
RAISES {GEFError.T} =
<* FATAL Thread.Alerted *>
VAR
l := NarrowToList(sx, "Expected list, found: ");
ra := RefListUtils.Pop(l);
BEGIN
sx := l;
TYPECASE ra OF
| NULL => RAISE GEFError.T("Expected an integer, found: ()");
| RInt (ri) => RETURN ri
| Atom.T (sym) =>
IF Text.Equal(Atom.ToText(sym), "Infinity") THEN
RETURN RInfinity
ELSE
RAISE GEFError.T("Expected an integer, found: " & Atom.ToText(sym))
END;
ELSE
RAISE GEFError.T("Expected an integer, found: " & SLispClass.SxToText(ra))
END;
END NextInteger;
PROCEDURE GetReal (VAR v: S_exp; defaults: BOOLEAN := FALSE): REAL
RAISES {GEFError.T} =
<* FATAL Thread.Alerted *>
BEGIN
TYPECASE v OF
| NULL =>
IF defaults THEN
RETURN 0.0
ELSE
RAISE GEFError.T("Expected a real, found: ()");
END;
| RefList.T (l) =>
WITH r = RefListUtils.Pop(l) DO
v := l;
TYPECASE r OF
| NULL => RAISE GEFError.T("Expected a real, found: ()");
| RReal (rr) => RETURN rr^
| RInt (ri) => RETURN FLOAT(ri^)
ELSE
RAISE GEFError.T("Expected real, found: " & SLispClass.SxToText(r));
END;
END;
| RReal (r) => RETURN r^;
| RInt (ri) => RETURN FLOAT(ri^);
ELSE
RAISE GEFError.T("Expected a real, found: " & SLispClass.SxToText(v));
END;
END GetReal;
PROCEDURE GetSx (VAR v: S_exp; defaults: BOOLEAN := FALSE): S_exp
RAISES {GEFError.T} =
BEGIN
TYPECASE v OF
| NULL =>
IF defaults THEN
RETURN NIL
ELSE
RAISE GEFError.T("Expected a list, found: ()");
END;
ELSE
RETURN NextSx(v);
END;
END GetSx;
PROCEDURE GetInt (VAR v: S_exp; defaults: BOOLEAN := FALSE): INTEGER
RAISES {GEFError.T} =
<* FATAL Thread.Alerted *>
BEGIN
TYPECASE v OF
| NULL =>
IF defaults THEN
RETURN 0
ELSE
RAISE GEFError.T("Expected an integer, found: ()");
END;
| RefList.T (l) =>
WITH r = NarrowToInt(RefListUtils.Pop(l), "Expected an integer, found: ")^ DO
v := l;
RETURN r
END;
| RInt (r) => RETURN r^
ELSE
RAISE GEFError.T("Expected an integer, found: " & SLispClass.SxToText(v));
END;
END GetInt;
PROCEDURE GetBool (VAR v: S_exp; defaults: BOOLEAN := FALSE): BOOLEAN
RAISES {GEFError.T} =
<* FATAL Thread.Alerted *>
VAR tmp: S_exp;
BEGIN
TYPECASE v OF
| NULL =>
IF defaults THEN
RETURN FALSE
ELSE
RAISE GEFError.T("Expected a boolean, found: ()");
END;
| RefList.T (l) =>
tmp := RefListUtils.Pop(l);
v := l;
TYPECASE tmp OF
| NULL => RETURN FALSE
| RBool (r) => RETURN r^
| Atom.T (atm) =>
IF atm = Sx.False THEN
RETURN FALSE
ELSE
RETURN TRUE
END;
ELSE
RAISE GEFError.T("Expected a boolean, found: " & SLispClass.SxToText(tmp));
END;
| RBool (r) => RETURN r^
ELSE
RAISE GEFError.T("Expected a boolean, found: " & SLispClass.SxToText(v));
END;
END GetBool;
PROCEDURE GetText (VAR v: S_exp; defaults: BOOLEAN := FALSE): TEXT
RAISES {GEFError.T} =
<* FATAL Thread.Alerted *>
BEGIN
TYPECASE v OF
| NULL =>
IF defaults THEN
RETURN ""
ELSE
RAISE GEFError.T("Expected a text, found: ()");
END;
| RefList.T (l) =>
v := RefListUtils.Pop(l);
WITH r = GetText(v) DO
v := l;
RETURN r
END;
| TEXT => RETURN v
| Atom.T (sym) => RETURN Atom.ToText(sym)
| RInt (i) => RETURN Fmt.Int(i^);
| RReal (r) => RETURN Fmt.Real(r^);
ELSE
RAISE GEFError.T("Expected a text, found: " & SLispClass.SxToText(v));
END;
END GetText;
PROCEDURE GetName (VAR v: S_exp): Name RAISES {GEFError.T} =
<* FATAL Thread.Alerted *>
BEGIN
TYPECASE v OF
| NULL => RAISE GEFError.T("Expected a name, found: ()");
| Atom.T (sym) => RETURN sym
| TEXT (t) => RETURN Atom.FromText(t);
| RInt (i) => RETURN Atom.FromText(Fmt.Int(i^));
ELSE
RAISE GEFError.T("Expected a name, found: " & SLispClass.SxToText(v));
END;
END GetName;
VAR
opToColor: IntRefTbl.T; (* := IntRefTbl.New(); *)
colorToOp: TextRefTbl.T; (* := TextRefTbl.New(); *)
CONST
NoOp = PaintOp.T{-123456};
NoRGB = Color.T{-1.0, -2.0, -3.0};
TYPE
ColorEntry = REF RECORD
op: PaintOp.T := NoOp;
rgb: Color.T := NoRGB;
END;
PROCEDURE ColorFromPaintOp (op: PaintOp.T): TEXT RAISES {GEFError.T} =
VAR value: REFANY;
BEGIN
CASE op.op OF
| PaintOp.Bg.op => RETURN "Bg"
| PaintOp.Fg.op => RETURN "Fg"
ELSE
IF opToColor.get(op.op, value) THEN
RETURN value
ELSE
RAISE
GEFError.T("paint op given is not one gotten from a color text");
END;
END;
END ColorFromPaintOp;
PROCEDURE ColorFromRGB (rgb: Color.T): TEXT RAISES {GEFError.T} =
BEGIN
RETURN Fmt.F("%s %s %s", Fmt.Real(rgb.r), Fmt.Real(rgb.g),
Fmt.Real(rgb.b));
END ColorFromRGB;
PROCEDURE OKComponent (r: REAL; color: TEXT) RAISES {GEFError.T} =
BEGIN
IF r < 0.0 OR r > 1.0 THEN
RAISE
GEFError.T(
"Bad color specification (need 0.0 <= rgb <= 1.0): " & color);
END;
END OKComponent;
PROCEDURE PaintOpFromColor (color: TEXT): PaintOp.T
RAISES {GEFError.T, Thread.Alerted} =
VAR
entry: ColorEntry;
sx : S_exp;
value: REFANY;
BEGIN
IF colorToOp.get(color, value) THEN
entry := value;
IF entry.op = NoOp THEN
OKComponent(entry.rgb.r, color);
OKComponent(entry.rgb.g, color);
OKComponent(entry.rgb.b, color);
entry.op := PaintOp.FromRGB(entry.rgb.r, entry.rgb.g, entry.rgb.b,
mode := PaintOp.Mode.Accurate);
EVAL opToColor.put(entry.op.op, color);
END;
RETURN entry.op
ELSE
TRY
sx := SxFromText(Fmt.F("(%s)", color));
color := GetColor(sx);
RETURN PaintOpFromColor(color); (* should work *)
EXCEPT
| Sx.ReadError, Rd.EndOfFile =>
RAISE GEFError.T("Bad color name: " & color);
END;
END
END PaintOpFromColor;
PROCEDURE RGBFromColor (color: TEXT): Color.T RAISES {GEFError.T, Thread.Alerted} =
VAR
entry: ColorEntry;
sx : S_exp;
value: REFANY;
BEGIN
IF colorToOp.get(color, value) THEN
entry := value;
RETURN entry.rgb
ELSE
TRY
sx := SxFromText(color);
color := GetColor(sx);
RETURN RGBFromColor(color); (* should work *)
EXCEPT
| Sx.ReadError, Rd.EndOfFile =>
RAISE GEFError.T("Bad color name: " & color);
END;
END
END RGBFromColor;
v is list element is one of text, name, list of reals/ints
PROCEDURE GetColor (VAR v: S_exp; default := FALSE): TEXT
RAISES {GEFError.T} =
<* FATAL Thread.Alerted *>
VAR
l : RefList.T;
entry: S_exp;
res : TEXT;
rgb : Color.T;
op := NoOp;
BEGIN
IF v = NIL AND default THEN RETURN "Fg" END;
l := NarrowToList(v, "Expected list, found: ");
entry := RefListUtils.Pop(l);
v := l;
TRY
TYPECASE entry OF
| NULL =>
IF default THEN
RETURN "Fg"
ELSE
RAISE GEFError.T("Expected a color specification, found: ()");
END;
| TEXT (t) =>
res := t;
IF Text.Equal(t, "Bg") THEN
rgb := Color.T{1.0, 1.0, 1.0};
op := PaintOp.Bg;
ELSIF Text.Equal(t, "Fg") THEN
rgb := Color.T{0.0, 0.0, 0.0};
op := PaintOp.Fg;
ELSE
rgb := ColorName.ToRGB(res);
END;
| Atom.T (sym) =>
res := Atom.ToText(sym);
IF sym = Bg THEN
rgb := Color.T{1.0, 1.0, 1.0};
op := PaintOp.Bg;
ELSIF sym = Fg THEN
rgb := Color.T{0.0, 0.0, 0.0};
op := PaintOp.Fg;
ELSE
rgb := ColorName.ToRGB(res);
END;
| RefList.T (l) =>
IF RefList.Length(l) = 3 THEN
rgb := Color.T{GetReal(entry), GetReal(entry), GetReal(entry)};
res := ColorFromRGB(rgb);
ELSE
RAISE GEFError.T("Expected a color specification, found: "
& SLispClass.SxToText(l));
END;
| RReal, RInt =>
VAR r: REAL;
BEGIN
IF RefList.Length(l) = 2 THEN
TYPECASE entry OF
| RReal (rr) => r := rr^;
| RInt (ri) => r := FLOAT(ri^);
ELSE
RAISE Fatal
END;
entry := l;
rgb := Color.T{r, GetReal(entry), GetReal(entry)};
res := ColorFromRGB(rgb);
v := NIL;
ELSE
RAISE GEFError.T(
Fmt.F("Expected a color specification, found: %s %s",
Fmt.Real(r), SLispClass.SxToText(l)));
END;
END;
ELSE
RAISE GEFError.T(
"Expected a color specification, found: " & SLispClass.SxToText(v));
END;
EVAL colorToOp.put(res, NEW(ColorEntry, rgb := rgb, op := op));
RETURN res;
EXCEPT
ColorName.NotFound => RAISE GEFError.T("Bad color name: " & res)
END;
END GetColor;
VAR
sxFoundry: Atom.T; (* := Atom.FromText("Foundry"); *)
sxFamily: Atom.T; (* := Atom.FromText("Family"); *)
sxWeight: Atom.T; (* := Atom.FromText("Weight"); *)
sxSlant: Atom.T; (* := Atom.FromText("Slant"); *)
sxSize: Atom.T; (* := Atom.FromText("Size"); *)
v is list element is one of text, name, list of reals/ints
PROCEDURE GetFont (VAR v: S_exp; default := FALSE): TEXT
RAISES {GEFError.T} =
<* FATAL Thread.Alerted *>
VAR
l : RefList.T;
entry: S_exp;
BEGIN
IF v = NIL AND default THEN RETURN Builtin END;
l := NarrowToList(v, "Expected list, found: ");
entry := RefListUtils.Pop(l);
v := l;
TYPECASE entry OF
| NULL =>
IF default THEN
RETURN Builtin
ELSE
RAISE GEFError.T("Expected a font specification, found: ()");
END;
| TEXT (t) =>
RETURN t;
| Atom.T (sym) =>
RETURN Atom.ToText(sym);
| RefList.T =>
VAR foundry := "*";
family := "Helvetica";
weight := "Medium";
slant := "R";
size := 0.0353;
sx, sx2: S_exp;
name: Name;
BEGIN
RefListUtils.Push(l, entry); (* reassemble the list for convenience...*)
WHILE l # NIL DO
sx := RefListUtils.Pop(l);
TYPECASE sx OF
RefList.T(prop) =>
IF RefList.Length(prop) # 2 THEN
RAISE GEFError.T("Expected property list for font, found: "
& SLispClass.SxToText(sx));
END;
sx2 := RefListUtils.Pop(prop);
sx := prop;
name := GetName(sx2);
IF name = sxFoundry THEN
foundry := GetText(sx);
ELSIF name = sxFamily THEN
family := GetText(sx);
ELSIF name = sxWeight THEN
weight := GetText(sx);
ELSIF name = sxSlant THEN
slant := GetText(sx);
ELSIF name = sxSize THEN
size := GetReal(sx);
ELSE
RAISE GEFError.T("Unexpected font property: "
& SLispClass.SxToText(name));
END;
ELSE
RAISE GEFError.T("Expected property list for font, found: "
& SLispClass.SxToText(sx));
END;
END;
RETURN Fmt.F("-%s-%s-%s-%s-*-*-*-%s-*-*-*-*-*-*", foundry, family,
weight, slant, Fmt.Real(size));
END;
ELSE
RAISE GEFError.T(
"Expected a font specification, found: " & SLispClass.SxToText(v));
END;
END GetFont;
PROCEDURE GetEnum1 (name: Name; enums: Names): INTEGER RAISES {GEFError.T} =
BEGIN
FOR i := 0 TO LAST(enums^) DO
IF name = enums[i] THEN RETURN i END;
END;
RAISE
GEFError.T("Expected the name of an enumerated, found: " & Atom.ToText(name));
END GetEnum1;
PROCEDURE GetEnum (VAR sx: S_exp; enums: Names; default := FALSE): INTEGER
RAISES {GEFError.T} =
<* FATAL Thread.Alerted *>
VAR
l : RefList.T;
entry: S_exp;
BEGIN
IF sx = NIL AND default THEN RETURN 0 END;
l := NarrowToList(sx, "Expected list, found: ");
entry := RefListUtils.Pop(l);
sx := l;
TYPECASE entry OF
| NULL =>
IF default THEN
RETURN 0
ELSE
RAISE GEFError.T("Expected the name of an enumerated, found: ()");
END;
| Atom.T (sym) => RETURN GetEnum1(sym, enums);
| Text.T (t) => RETURN GetEnum1(Atom.FromText(t), enums);
ELSE
RAISE GEFError.T("Expected the name of an enumerated, found: "
& SLispClass.SxToText(entry));
END;
END GetEnum;
PROCEDURE GetElem (t: T; VAR sx: S_exp; default := FALSE): Elem
RAISES {GEFError.T, Thread.Alerted} =
VAR
entry: S_exp;
BEGIN
TYPECASE sx OF
| NULL =>
IF default THEN
RETURN NIL
ELSE
RAISE GEFError.T("Expected an element, found: ()");
END;
| RefList.T (l) =>
entry := RefListUtils.Pop(l);
sx := l;
RETURN entry;
SCG July 9 RETURN GetElem(t, entry);
| RInt (i) => RETURN ElemFromNameInternal(t, Fmt.Int(i^));
| Atom.T (sym) => RETURN ElemFromNameInternal(t, Atom.ToText(sym));
| TEXT (txt) => RETURN ElemFromNameInternal(t, txt);
ELSE
RETURN CheckElem(sx);
END;
END GetElem;
PROCEDURE CheckElem (elem: Elem): Elem RAISES {GEFError.T, Thread.Alerted} =
BEGIN
IF elem = NIL THEN RAISE GEFError.T("Expected an element, found: ()") END;
FOR i := 0 TO LAST(parseObjects^) DO
IF parseObjects[i] # NIL AND parseObjects[i].isType(elem) THEN
RETURN elem
END;
END;
RAISE GEFError.T("Expected an element, found: " & SLispClass.SxToText(elem));
END CheckElem;
VAR
fontToName: IntRefTbl.T; (* := IntRefTbl.New(); *)
nameToFont: TextRefTbl.T; (* := TextRefTbl.New(); *)
CONST
Builtin = "BuiltIn";
PROCEDURE NameFromFont (font: Font.T): TEXT =
VAR val: REFANY;
BEGIN
IF fontToName.get(font.fnt, val) THEN
RETURN val
ELSE
RETURN Builtin
END;
END NameFromFont;
PROCEDURE FontFromName (name: TEXT): Font.T =
VAR
val: REFANY;
rf : REF Font.T;
wf : GraphVBT.WorldFont;
BEGIN
IF nameToFont.get(name, val) THEN
RETURN NARROW(val, REF Font.T)^
ELSE
wf := GraphVBTExtras.WorldFontFromText(name);
rf := NEW(REF Font.T);
rf^ := GraphVBTExtras.FontFromWorldFont(wf);
EVAL fontToName.put(rf^.fnt, name);
EVAL nameToFont.put(name, rf);
RETURN rf^
END;
END FontFromName;
********************** Registration *********************
PROCEDURE EnumsFromList (list: RefList.T): Names RAISES {GEFError.T} =
VAR
enums := NEW(Names, RefList.Length(list));
l : S_exp := list;
BEGIN
FOR i := 0 TO LAST(enums^) DO
enums[i] := NextName(l);
END;
RETURN enums;
END EnumsFromList;
VAR
sxBoolean: Atom.T; (* := Atom.FromText("Boolean"); *)
sxInteger: Atom.T; (* := Atom.FromText("Integer"); *)
sxReal: Atom.T; (* := Atom.FromText("Real"); *)
sxText: Atom.T; (* := Atom.FromText("Text"); *)
sxName: Atom.T; (* := Atom.FromText("Name"); *)
sxElem: Atom.T; (* := Atom.FromText("Elem"); *)
sxColorSpec: Atom.T; (* := Atom.FromText("ColorSpec"); *)
sxFontSpec: Atom.T; (* := Atom.FromText("FontSpec"); *)
sxSx: Atom.T; (* := Atom.FromText("Sx"); *)
PROCEDURE NextFieldType (VAR (* IN/OUT *) sx : S_exp;
VAR (* OUT *) enums: Names ): FieldType
RAISES {GEFError.T} =
VAR
l := NarrowToList(sx, "Expected list, found: ");
ra := RefListUtils.Pop(l);
BEGIN
sx := l;
TYPECASE ra OF
| NULL => RAISE Fatal;
| Atom.T (sym) =>
IF sym = sxBoolean THEN
RETURN FieldType.Boolean
ELSIF sym = sxInteger THEN
RETURN FieldType.Integer
ELSIF sym = sxReal THEN
RETURN FieldType.Real
ELSIF sym = sxText THEN
RETURN FieldType.Text
ELSIF sym = sxElem THEN
RETURN FieldType.Elem
ELSIF sym = sxColorSpec THEN
RETURN FieldType.ColorSpec
ELSIF sym = sxFontSpec THEN
RETURN FieldType.FontSpec
ELSIF sym = sxSx THEN
RETURN FieldType.Sx
ELSE
RAISE Fatal
END;
| RefList.T (list) => enums := EnumsFromList(list); RETURN FieldType.Enum;
ELSE
RAISE Fatal;
END;
END NextFieldType;
PROCEDURE VerifyEntries (READONLY field: Field; entries: S_exp): Names
RAISES {GEFError.T} =
VAR
res : Names;
list: RefList.T;
BEGIN
IF entries # NIL THEN
list := NarrowToList(entries, "Entry names list expected, found:");
IF field.count # RefList.Length(list) THEN
RAISE GEFError.T("Wrong number of entries names for field: "
& Atom.ToText(field.name))
END;
res := NEW(Names, RefList.Length(list));
FOR i := 0 TO LAST(res^) DO res[i] := NextName(entries) END;
END;
RETURN res;
END VerifyEntries;
entries and defaults need to be verified
PROCEDURE AddField (po : ParseObject;
index : INTEGER;
name : Name;
type : FieldType;
enums : Names;
cnt : INTEGER;
entries : S_exp;
defaults: S_exp ) RAISES {GEFError.T, Thread.Alerted} =
VAR empty := -1;
BEGIN
FOR i := 0 TO LAST(po.fields^) DO
IF po.fields[i].name = NIL THEN empty := i; EXIT END;
END;
IF empty = -1 THEN
empty := NUMBER(po.fields^);
WITH new = NEW(Fields, empty + empty) DO
SUBARRAY(new^, 0, empty) := po.fields^;
po.fields := new;
END;
WITH new = NEW(Values, empty + empty) DO
SUBARRAY(new^, 0, empty) := po.values^;
po.values := new;
END;
END;
CASE type OF
| FieldType.Boolean, FieldType.Integer, FieldType.Real,
FieldType.Enum =>
IF cnt = Infinity THEN
RAISE Fatal; (* cannot handle (yet?) infinite number of
these *)
END;
ELSE
END;
WITH f = po.fields[empty] DO
f.name := name;
f.index := index;
f.type := type;
f.enums := enums;
f.count := cnt;
f.entries := VerifyEntries(f, entries);
po.values[empty].sx := NIL;
po.values[empty].vals := ValsFromSx(NIL, f, defaults, TRUE);
END;
END AddField;
VAR
parseObjects: REF ARRAY OF ParseObject; (* := NEW(REF ARRAY OF ParseObject, 5); *)
sxField: Atom.T; (* := Atom.FromText("Field"); *)
PROCEDURE RegisterParseObject (po: ParseObject) =
VAR
list := NarrowToList(SxFromText(po.args), "Expected list, found: ");
entry: S_exp;
enums: Names;
name : Name;
<* FATAL Rd.EndOfFile, Sx.ReadError, Thread.Alerted, GEFError.T *>
BEGIN
Startup();
po.fields := NEW(Fields, 4);
po.values := NEW(Values, 4);
WHILE list # NIL DO
entry := RefListUtils.Pop(list);
name := NextName(entry);
IF name = sxName THEN
IF po.name # NIL THEN RAISE Fatal END;
po.name := NextName(entry);
ELSIF name = sxField THEN
AddField(po, NextInteger(entry)^, NextName(entry),
NextFieldType(entry, enums), enums, NextInteger(entry)^,
NextSx(entry), NextSx(entry));
ELSE
RAISE Fatal;
END;
IF entry # NIL THEN RAISE Fatal END;
END;
IF po.name = NIL THEN RAISE Fatal END;
LOCK mu DO
FOR i := 0 TO LAST(parseObjects^) DO
IF parseObjects[i] = NIL THEN parseObjects[i] := po; RETURN END;
END;
WITH new = NEW(REF ARRAY OF ParseObject, 2 * NUMBER(parseObjects^)) DO
SUBARRAY(new^, 0, NUMBER(parseObjects^)) := parseObjects^;
new[NUMBER(parseObjects^)] := po;
parseObjects := new;
END;
END
END RegisterParseObject;
*************************** Generating FV ************************
PROCEDURE FVName (name: Name; names: Names; i: INTEGER): TEXT =
BEGIN
IF names = NIL THEN
RETURN Atom.ToText(name)
ELSE
RETURN Atom.ToText(name) & Atom.ToText(names[i])
END;
END FVName;
CONST TF = ARRAY BOOLEAN OF TEXT{"TRUE", "FALSE"};
PROCEDURE PutField (wr : Wr.T;
type : FieldType;
label, fvName: TEXT;
vals : Vals;
ival : INTEGER;
enums : Names ) =
<* FATAL Wr.Failure, Thread.Alerted *>
BEGIN
IF label = NIL THEN label := "" END;
IF fvName = NIL THEN fvName := "" END;
CASE type OF
| FieldType.Boolean =>
Wr.PutText(wr, Fmt.F("(Boolean %%s =#%s \"%s\")", fvName,
TF[NARROW(vals, Bools)[ival]], label));
| FieldType.Integer =>
Wr.PutText(
wr, Fmt.F("(Shape (Width + 0) \"%s: \") (Numeric %%s =%s)",
label, fvName, Fmt.Int(NARROW(vals, Ints)[ival])));
| FieldType.Real =>
Wr.PutText(
wr, Fmt.F("(Shape (Width + 0) \"%s: \") (TextArea %%s =\"%s\")",
label, fvName, Fmt.Real(NARROW(vals, Reals)[ival])));
| FieldType.Text, FieldType.ColorSpec, FieldType.FontSpec =>
Wr.PutText(
wr, Fmt.F("(Shape (Width + 0) \"%s: \") (TextArea %%s =\"%s\")",
label, fvName, NARROW(vals, Texts)[ival]));
| FieldType.Elem, FieldType.Sx =>
Wr.PutText(
wr, Fmt.F("(Shape (Width + 0) \"%s: \") (TextArea %%s )", label,
fvName));
| FieldType.Enum =>
Wr.PutText(wr, Fmt.F("(Radio %%s (HBox ", fvName));
FOR i := 0 TO LAST(enums^) DO
Wr.PutText(wr, Fmt.F("(Choice %%s%s \"%s\")", fvName,
Atom.ToText(enums[i]), Atom.ToText(enums[i])));
END;
Wr.PutText(wr, " Fill) ) ");
END;
END PutField;
PROCEDURE FvField (wr: Wr.T; VAR (* in/out *) field: Field; vals: Vals) =
VAR
fvName, label: TEXT;
count : INTEGER;
<* FATAL Wr.Failure, Thread.Alerted *>
BEGIN
IF field.name # NIL THEN
Wr.PutText(
wr, Fmt.F("(HBox (Shape (Width + 0) \"%s: \")", Atom.ToText(field.name)));
IF field.count = Infinity THEN
count := 1;
ELSE
count := field.count;
END;
field.fvNames := NEW(Texts, count);
FOR i := 0 TO count - 1 DO
IF field.entries # NIL THEN
label := Atom.ToText(field.entries[i])
ELSE
label := NIL;
END;
fvName := FVName(field.name, field.entries, i);
field.fvNames[i] := fvName;
PutField(wr, field.type, label, fvName, vals, i, field.enums);
END;
Wr.PutText(wr, " Fill )");
END;
END FvField;
CONST
FvHead = "(VBox (HBox (Shape (Width + 0) (Text %ElemType \"\")) (Glue 2) (TextArea %Name) Fill )";
FvTail = " Fill )";
PROCEDURE FVFromArgs (po: ParseObject): TEXT =
VAR wr := TextWr.New(); <* FATAL Wr.Failure, Thread.Alerted *>
BEGIN
Wr.PutText(wr, FvHead);
FOR i := 0 TO LAST(po.fields^) DO
FvField(wr, po.fields[i], po.values[i].vals);
END;
Wr.PutText(wr, FvTail);
RETURN TextWr.ToText(wr);
END FVFromArgs;
PROCEDURE ReportError (fv: FormsVBT.T; msg: TEXT) =
VAR v: VBT.T;
<* FATAL FormsVBT.Unimplemented *>
BEGIN
TRY
FormsVBT.PutText(fv, "stderr", msg);
FormsVBT.PopUp(fv, "errorPopup");
EXCEPT
| FormsVBT.Error =>
(* search up parent tree for a parent fv. This is need for
reporting error on generated forms ... *)
v := VBT.Parent(fv);
LOOP
TYPECASE v OF
| FormsVBT.T (fv2) => ReportError(fv2, msg); RETURN;
ELSE
v := VBT.Parent(v);
END;
END;
END;
END ReportError;
PROCEDURE BuiltinFont () =
VAR rf := NEW(REF Font.T);
<* FATAL Wr.Failure, Thread.Alerted *>
BEGIN
rf^ := GraphVBTExtras.FontFromWorldFont(GraphVBT.DefaultFont);
EVAL fontToName.put(rf^.fnt, Builtin);
EVAL nameToFont.put(Builtin, rf);
END BuiltinFont;
PROCEDURE SxFromText(t: TEXT): Sx.T RAISES {Sx.ReadError} =
<* FATAL Wr.Failure, Rd.EndOfFile, Thread.Alerted *>
BEGIN
RETURN Sx.Read(TextRd.New(t));
END SxFromText;
Intended to cure initialization order problems.
PROCEDURE Startup () =
BEGIN
IF RInfinity = NIL THEN
RInfinity := NEW(RInt);
uid := 1;
nameID := NameIDInit;
NullObj := NEW(Obj);
Bg := Atom.FromText("Bg");
Fg := Atom.FromText("Fg");
opToColor := NEW(IntRefTbl.Default).init();
colorToOp := NEW(TextRefTbl.Default).init();
fontToName := NEW(IntRefTbl.Default).init();
nameToFont := NEW(TextRefTbl.Default).init();
sxFoundry := Atom.FromText("Foundry");
sxFamily := Atom.FromText("Family");
sxWeight := Atom.FromText("Weight");
sxSlant := Atom.FromText("Slant");
sxSize := Atom.FromText("Size");
sxBoolean := Atom.FromText("Boolean");
sxInteger := Atom.FromText("Integer");
sxReal := Atom.FromText("Real");
sxText := Atom.FromText("Text");
sxName := Atom.FromText("Name");
sxElem := Atom.FromText("Elem");
sxSx := Atom.FromText("Sx");
sxColorSpec := Atom.FromText("ColorSpec");
sxFontSpec := Atom.FromText("FontSpec");
parseObjects := NEW(REF ARRAY OF ParseObject, 5);
sxField := Atom.FromText("Field");
RInfinity^ := Infinity;
mu := NEW(MUTEX);
BuiltinFont();
END;
END Startup;
BEGIN
Startup();
END GEFClass.