Copyright (C) 1994, Digital Equipment Corp.
MODULE******************************** Parsing *********************; 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 GEFClass GenName (): TEXT = BEGIN INC(nameID); RETURN NamePrefix & Fmt.Int(nameID) END GenName; PROCEDUREInitT (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; PROCEDUREAddPOsToInterp (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;
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------------------------- GEFLisp utilities ----------------------POC (<* UNUSED *> po: ParseObject; <* UNUSED *> t : T; <* UNUSED *> id: INTEGER ): REFANY = BEGIN RAISE Fatal END POC; PROCEDUREPOD (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; <* UNUSED *> elem: Elem ) = BEGIN RAISE Fatal END POD; PROCEDUREPOSI (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; <* UNUSED *> elem : Elem; <* UNUSED *> field: INTEGER; <* UNUSED *> vals: Ints ) RAISES {GEFError.T} = BEGIN RAISE Fatal END POSI; PROCEDUREPOSR (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; <* UNUSED *> elem : Elem; <* UNUSED *> field: INTEGER; <* UNUSED *> vals: Reals ) RAISES {GEFError.T} = BEGIN RAISE Fatal END POSR; PROCEDUREPOSB (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; <* UNUSED *> elem : Elem; <* UNUSED *> field: INTEGER; <* UNUSED *> vals: Bools ) RAISES {GEFError.T} = BEGIN RAISE Fatal END POSB; PROCEDUREPOST (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; <* UNUSED *> elem : Elem; <* UNUSED *> field: INTEGER; <* UNUSED *> vals: Texts ) RAISES {GEFError.T} = BEGIN RAISE Fatal END POST; PROCEDUREPOSE (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; <* UNUSED *> elem : Elem; <* UNUSED *> field: INTEGER; <* UNUSED *> vals: Elems ) RAISES {GEFError.T} = BEGIN RAISE Fatal END POSE; PROCEDUREPOF (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; <* UNUSED *> elem: Elem ) RAISES {GEFError.T} = BEGIN RAISE Fatal END POF; PROCEDUREPOIT (<* UNUSED *> po: ParseObject; <* UNUSED *> elem: Elem): BOOLEAN = BEGIN RAISE Fatal END POIT; PROCEDUREPOGID (<* UNUSED *> po : ParseObject; <* UNUSED *> t : T; <* UNUSED *> elem: Elem ): INTEGER = BEGIN RAISE Fatal END POGID; PROCEDUREPOFromName (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; PROCEDUREValsFromSx ( 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; PROCEDURESetFieldFromValue ( 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; PROCEDUREListFromValues (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; PROCEDURECopyValues (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; PROCEDURELookupFields (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; PROCEDURENewId (): INTEGER = BEGIN INC(uid); RETURN uid; END NewId; PROCEDUREParse (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; PROCEDUREIncrementalParse (t: T; sx: S_exp) RAISES {Thread.Alerted} = BEGIN TRY EVAL t.interp.eval(sx); EXCEPT | SLisp.Error => RAISE Thread.Alerted; END; END IncrementalParse; PROCEDUREParseObjectFromElem (elem: Elem): ParseObject = BEGIN LOCK mu DO RETURN POFromElemInternal(elem) END; END ParseObjectFromElem; PROCEDUREPOFromElemInternal (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;
PROCEDURE*************************** Ranges ***********************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; PROCEDUREGetProp (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; PROCEDURESetProp (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; PROCEDUREDelete (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;
PROCEDURE************************ Elem to/from FormsVBT.T *****************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; PROCEDUREAdjustRange (i, start: CARDINAL; delta: INTEGER): CARDINAL = BEGIN IF i > start THEN RETURN i - delta ELSE RETURN i END; END AdjustRange; PROCEDUREUpdateRange (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;
PROCEDURE*************************** Parsing Utilities ******************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; PROCEDURESetFieldsFromObj (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; PROCEDUREGetFV (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; PROCEDURESetFVFromElem (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; PROCEDUREAddParseObjectsToMenu (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; PROCEDUREPOProc (<* 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; PROCEDUREUpdateBoolsFieldFromFV ( 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; PROCEDURESxFromBools (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; PROCEDUREUpdateIntsFieldFromFV ( 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; PROCEDURESxFromInts (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; PROCEDUREUpdateEnumsFieldFromFV ( 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; PROCEDURESxFromEnums (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; PROCEDUREUpdateRealsFieldFromFV ( 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; PROCEDURESxFromReals (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; PROCEDUREUpdateSxsFieldFromFV ( 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; PROCEDURESxFromSxs (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; PROCEDUREUpdateTextsFieldFromFV ( 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; PROCEDURESxFromTexts (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; PROCEDUREUpdateElemsFieldFromFV ( 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; PROCEDURESxFromElems (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; PROCEDURESetObjValuesFromFields (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; PROCEDURESetObjSxFromValues (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; PROCEDURESetElemFromObj (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; PROCEDURESetElemFromFV (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; PROCEDURECreateElemFromFV (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; PROCEDURESxFromElem (t: T; elem: Elem): S_exp = BEGIN LOCK mu DO RETURN ObjFromElem(t, elem).sx END; END SxFromElem; PROCEDUREGetElemField (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; PROCEDUREUpdateElemField (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; PROCEDURESetElemField (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;
PROCEDUREv is list element is one of text, name, list of reals/intsNextSx (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; PROCEDUREElemFromName (t: T; name: Text.T): Elem RAISES {GEFError.T} = BEGIN LOCK mu DO RETURN ElemFromNameInternal(t, name); END; END ElemFromName; PROCEDUREElemFromNameInternal (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; PROCEDUREAllElements (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 := ""); *) PROCEDUREObjFromElem (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; PROCEDURENameFromElem (t: T; elem: Elem): TEXT = BEGIN LOCK mu DO RETURN NameFromElemInternal(t, elem) END; END NameFromElem; PROCEDURENameFromElemInternal (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"); *) PROCEDURENarrowToList (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; PROCEDURENarrowToInt (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; PROCEDURENextName (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; PROCEDURENextInteger (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; PROCEDUREGetReal (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; PROCEDUREGetSx (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; PROCEDUREGetInt (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; PROCEDUREGetBool (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; PROCEDUREGetText (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; PROCEDUREGetName (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; PROCEDUREColorFromPaintOp (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; PROCEDUREColorFromRGB (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; PROCEDUREOKComponent (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; PROCEDUREPaintOpFromColor (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; PROCEDURERGBFromColor (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;
PROCEDUREv is list element is one of text, name, list of reals/intsGetColor (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"); *)
PROCEDUREGetFont (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; PROCEDUREGetEnum1 (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; PROCEDUREGetEnum (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; PROCEDUREGetElem (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********************** Registration *********************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"; PROCEDURENameFromFont (font: Font.T): TEXT = VAR val: REFANY; BEGIN IF fontToName.get(font.fnt, val) THEN RETURN val ELSE RETURN Builtin END; END NameFromFont; PROCEDUREFontFromName (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;
PROCEDUREentries and defaults need to be verifiedEnumsFromList (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"); *) PROCEDURENextFieldType (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; PROCEDUREVerifyEntries (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;
PROCEDURE*************************** Generating FV ************************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"); *) PROCEDURERegisterParseObject (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;
PROCEDUREIntended to cure initialization order problems.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"}; PROCEDUREPutField (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; PROCEDUREFvField (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 )"; PROCEDUREFVFromArgs (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; PROCEDUREReportError (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; PROCEDUREBuiltinFont () = 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; PROCEDURESxFromText (t: TEXT): Sx.T RAISES {Sx.ReadError} = <* FATAL Wr.Failure, Rd.EndOfFile, Thread.Alerted *> BEGIN RETURN Sx.Read(TextRd.New(t)); END SxFromText;
PROCEDUREStartup () = 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.