gef/src/GEFClass.m3


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.

interface FloatMode is in: