<* PRAGMA LL *> MODULEThis module contains the code to construct (parse) FV-expressions.FormsVBT EXPORTSFVRuntime ,FormsVBT ,FVTypes ;
IMPORT FVRuntime; IMPORT Atom, AtomIntTbl, Axis, BiFeedbackVBT, BooleanVBT, ButtonVBT, ChoiceVBT, Color, ColorName, Cursor, FeedbackVBT, FileBrowserVBT, Filter, FlexVBT, Fmt, HVSplit, Image, Jva, JVSink, ListVBT, Macro, MarginFeedbackVBT, MenuSwitchVBT, MultiSplit, MultiFilter, NumericVBT, OSError, PaintOp, Pixmap, Pts, Rd, RdUtils, ReactivityVBT, RefList, Rsrc, ScaleFilter, ScrollerVBT, Shadow, ShadowedFeedbackVBT, ShadowedVBT, SourceVBT, Split, SplitterVBT, SwitchVBT, Sx, Text, TextEditVBT, TextPort, TextPortClass, TextureVBT, TextVBT, TextWr, Thread, TSplit, TypescriptVBT, VBT, ViewportVBT, Wr, ZChildVBT, ZSplit;IMPORT StubImageRd AS ImageRd;
FROM RefListUtils IMPORT Pop, Push, AssocQ; <* FATAL Thread.Alerted *> TYPE ParseClosure = Thread.SizedClosure OBJECT description: Sx.T; fv : T; fixupList : FixupLink := NIL; state : State OVERRIDES apply := Apply END; FixupLink = REF RECORD targetName: TEXT; sourceVBT : VBT.T; next : FixupLink END; VAR (* CONST *) qBar := Atom.FromText ("Bar"); qChisel := Atom.FromText ("Chisel"); qFill := Atom.FromText ("Fill"); qGlue := Atom.FromText ("Glue"); qInsert := Atom.FromText ("Insert"); qMain := Atom.FromText ("Main"); qMinus := Atom.FromText ("-"); qPlus := Atom.FromText ("+"); qReset := Atom.FromText ("Reset"); qRidge := Atom.FromText ("Ridge"); PROCEDUREParse (t: T; description: Sx.T; READONLY state: State): VBT.T RAISES {Error} = BEGIN TYPECASE Thread.Join (Thread.Fork (NEW (ParseClosure, stackSize := 10000, description := description, fv := t, state := state))) OF | TEXT (msg) => RAISE Error (msg) | VBT.T (ch) => RETURN ch ELSE <* ASSERT FALSE *> END END Parse; PROCEDUREApply (cl: ParseClosure): REFANY = <* LL = 0 *> VAR ch: VBT.T; BEGIN TRY ch := Item (cl, cl.description, cl.state); Pass2 (cl); RETURN ch EXCEPT | Error (msg) => RETURN msg END END Apply; EXCEPTION Narrow;
NARROW-faults are checked runtime errors, but implementations are not required to map them into exceptions, so you can't catch them with TRY EXCEPT ELSE. That would have been handy in the following procedure. (So would multi-methods!)
PROCEDURE************************** Parser ******************************Pass2 (cl: ParseClosure) RAISES {Error} = (* Find targets of (For xxx) and (TabTo xxx) forms. *) BEGIN WHILE cl.fixupList # NIL DO TRY WITH target = GetVBT (cl.fv, cl.fixupList.targetName), source = cl.fixupList.sourceVBT DO TYPECASE source OF | FVHelper (fbh) => TYPECASE target OF | FVFileBrowser (x) => FileBrowserVBT.SetHelper (x, fbh) | TextPort.T (target) => fbh.tabNext := target | NumericVBT.T (target) => fbh.tabNext := target.typein | TextEditVBT.T (target) => fbh.tabNext := target.tp ELSE RAISE Narrow END | FVDirMenu (dm) => TYPECASE target OF | FVFileBrowser (x) => FileBrowserVBT.SetDirMenu (x, dm) ELSE RAISE Narrow END | FVPageButton, FVPageMButton => TYPECASE target OF | FVTSplit (x) => FVRuntime.SetPageTarget (source, x) ELSE RAISE Narrow END | FVLinkButton, FVLinkMButton => FVRuntime.SetLinkTarget ( source, FindTChild (target, cl.fixupList.targetName)) | FVCloseButton (cb) => TYPECASE target OF | ZChildVBT.T (x) => cb.target := x ELSE RAISE Narrow END | FVPopButton, FVPopMButton => TYPECASE target OF | ZChildVBT.T (x) => FVRuntime.SetPopTarget (source, x) ELSE RAISE Narrow END | FVTypeIn (source) => TYPECASE target OF | TextPort.T (target) => source.tabNext := target | NumericVBT.T (target) => source.tabNext := target.typein | TextEditVBT.T (target) => source.tabNext := target.tp ELSE RAISE Narrow END | FVNumeric (source) => TYPECASE target OF | TextPort.T (target) => source.typein.tabNext := target | NumericVBT.T (target) => source.typein.tabNext := target.typein | TextEditVBT.T (target) => source.typein.tabNext := target.tp ELSE RAISE Narrow END ELSE Gripe ("Internal error [Pass2]: ", source) END (* TYPECASE source *) END (* WITH *) EXCEPT | FileBrowserVBT.Error (e) => Gripe (Fmt.F ("Error in FileBrowser %s: %s %s", cl.fixupList.targetName, e.path, e.text)) | Error (msg) => RAISE Error (msg) ELSE (* NARROW fault, NIL, etc. *) Gripe (Fmt.F ("The form named %s is of the wrong type", cl.fixupList.targetName)) END; cl.fixupList := cl.fixupList.next END (* WHILE *) END Pass2; PROCEDUREFindTChild (vbt: VBT.T; vbtName: TEXT): VBT.T RAISES {Error} = BEGIN (* "The named component must be either a TSplit child, or a descendant of something that is. In the latter case the TSplit child is the true target." *) LOOP TYPECASE VBT.Parent (vbt) OF | NULL => RAISE Error (vbtName & " is not in a TSplit") | FVTSplit => RETURN vbt | VBT.Split (parent) => vbt := parent END END END FindTChild;
TYPE ComponentProc = PROCEDURE (cl: ParseClosure; VAR list: RefList.T; READONLY s: State): VBT.T RAISES {Error}; RealizeProc = PROCEDURE (): VBT.T RAISES {Error}; StateProc = PROCEDURE (list: RefList.T; VAR state: State) RAISES {Error}; MetricsProc = PROCEDURE (sym: Atom.T; arglist: RefList.T; VAR metrics: RefList.T) RAISES {Error};The
state
data structure, about 132 bytes, could be made
much more efficient. Currently, a copy of the data structure is
made each time that a component is encountered. (Further, a copy from
the heap is made on each component that has a name, so that the
inheritable props can be changed at runtime.)
For instance, a copy of the entire data structure isn't needed, just those variables that have actually changed. Other (more) efficient schemes are possible. --mhb 1/24/94
PROCEDURE====================================================================== Parsing routines for components ======================================================================Item (cl: ParseClosure; exp: Sx.T; READONLY state: State): VBT.T RAISES {Error} = (* This routine interprets an S-expression as a component (VBT). - NIL is illegal. - The symbol Fill is parsed as (Fill). - The symbol Bar is parsed as (Bar 2). - The symbol Chisel is parsed as (Chisel 2). - The symbol Ridge is parsed as (Ridge 2). - The symbol Glue is parsed as (Glue 2). - A text "abc" is parsed as (Text "abc"). - Lists whose first element names a component are parsed by specific routines, stored in "componentProcTable". Nothing else is legal. *) VAR list: RefList.T; res : VBT.T; BEGIN Push (cl.fv.formstack, exp); (* For debugging *) TYPECASE exp OF | NULL => | Atom.T (s) => res := ParseSymbolComponent (cl, s, state); cl.fv.formstack := cl.fv.formstack.tail; RETURN res | TEXT (text) => list := RefList.List1 (text); res := pText (cl, list, state); cl.fv.formstack := cl.fv.formstack.tail; RETURN res | RefList.T (list) => TYPECASE list.head OF | NULL => | Atom.T (sym) => list := list.tail; WITH p = FindComponentProc (sym) DO IF p # NIL THEN res := p (cl, list, state) ELSE WITH m = MacroFunction (sym, state) DO IF m # NIL THEN res := Item (cl, m.apply (list), state) ELSIF sym = qInsert THEN res := OneChild ( cl, InsertFile (OneText (list), cl.fv.path, cl.fv.baseURL), state) ELSE Gripe ("Unknown component: ", sym) END END END END; cl.fv.formstack := cl.fv.formstack.tail; RETURN res ELSE END ELSE END; Gripe ("Syntax error: ", exp); <* ASSERT FALSE *> END Item; PROCEDUREMacroFunction (sym: Atom.T; READONLY state: State): Macro.T = BEGIN WITH pair = AssocQ (state.macros, sym) DO IF pair # NIL THEN RETURN pair.tail.head ELSE RETURN NIL END END END MacroFunction; PROCEDUREParseSymbolComponent (cl: ParseClosure; sym: Atom.T; READONLY state: State): VBT.T RAISES {Error} = BEGIN IF sym = qBar OR sym = qGlue OR sym = qRidge OR sym = qChisel OR sym = qFill THEN RETURN Item (cl, RefList.List1 (sym), state) ELSE Gripe ("Unknown Symbol-component: ", sym); <* ASSERT FALSE *> END END ParseSymbolComponent; PROCEDUREGripe (msg: TEXT; form: REFANY := NIL) RAISES {Error} = BEGIN IF form # NIL THEN msg := msg & ToText (form) END; RAISE Error (msg) END Gripe;
VAR Unnamed := Atom.FromText (""); PROCEDURE======================= Realizing VBTs ==========================NamePP (): SymbolPP = BEGIN RETURN NEW (SymbolPP, val := Unnamed, valname := "", name := "Name") END NamePP; PROCEDURENamed (n: SymbolPP): BOOLEAN = BEGIN RETURN n.val # Unnamed END Named;
REVEAL T <: Private; Private = SemiPublic BRANDED OBJECT OVERRIDES realize := Realize END; PROCEDURE========================= Any, AnyFilter, AnySplit =============================Realize (<* UNUSED *> fv : Private; type: TEXT; <* UNUSED *> name: TEXT ): VBT.T RAISES {Error} = BEGIN RETURN FindRealizeProc (Atom.FromText (type)) () END Realize; PROCEDURErAny (): VBT.T = BEGIN RETURN NEW(FVAny) END rAny; PROCEDURErAnyFilter (): VBT.T = BEGIN RETURN NEW(FVAnyFilter) END rAnyFilter; PROCEDURErAnySplit (): VBT.T = BEGIN RETURN NEW(FVAnySplit) END rAnySplit; PROCEDURErAudio (): VBT.T = BEGIN RETURN NEW(FVAudio) END rAudio; PROCEDURErBar (): VBT.T = BEGIN RETURN NEW (FVBar) END rBar; PROCEDURErBoolean (): VBT.T = BEGIN RETURN NEW (FVBoolean) END rBoolean; PROCEDURErBorder (): VBT.T = BEGIN RETURN NEW (FVBorder) END rBorder; PROCEDURErBrowser (): VBT.T = BEGIN RETURN NEW (FVBrowser) END rBrowser; PROCEDURErButton (): VBT.T = BEGIN RETURN NEW (FVButton) END rButton; PROCEDURErChisel (): VBT.T = BEGIN RETURN NEW (FVChisel) END rChisel; PROCEDURErChoice (): VBT.T = BEGIN RETURN NEW (FVChoice) END rChoice; PROCEDURErCloseButton (): VBT.T = BEGIN RETURN NEW (FVCloseButton) END rCloseButton; PROCEDURErDirMenu (): VBT.T = BEGIN RETURN NEW (FVDirMenu) END rDirMenu; PROCEDURErFileBrowser (): VBT.T = BEGIN RETURN NEW (FVFileBrowser) END rFileBrowser; PROCEDURErFill (): VBT.T = BEGIN RETURN NEW (FVFill) END rFill; PROCEDURErFilter (): VBT.T = BEGIN RETURN NEW (FVFilter) END rFilter; PROCEDURErFrame (): VBT.T = BEGIN RETURN NEW (FVFrame) END rFrame; PROCEDURErGeneric (): VBT.T = BEGIN RETURN NEW (FVGeneric) END rGeneric; PROCEDURErGlue (): VBT.T = BEGIN RETURN NEW (FVGlue) END rGlue; PROCEDURErGuard (): VBT.T = BEGIN RETURN NEW (FVGuard) END rGuard; PROCEDURErHBox (): VBT.T = BEGIN RETURN NEW (FVHBox) END rHBox; PROCEDURErHPackSplit (): VBT.T = BEGIN RETURN NEW (FVHPackSplit) END rHPackSplit; PROCEDURErHTile (): VBT.T = BEGIN RETURN NEW (FVHTile) END rHTile; PROCEDURErHelp (): VBT.T = BEGIN RETURN NEW (FVHelp) END rHelp; PROCEDURErHelper (): VBT.T = BEGIN RETURN NEW (FVHelper) END rHelper; PROCEDURErImage (): VBT.T = BEGIN RETURN NEW (FVImage) END rImage; PROCEDURErIntApply (): VBT.T = BEGIN RETURN NEW(FVIntApply) END rIntApply; PROCEDURErLinkButton (): VBT.T = BEGIN RETURN NEW (FVLinkButton) END rLinkButton; PROCEDURErLinkMButton (): VBT.T = BEGIN RETURN NEW (FVLinkMButton) END rLinkMButton; PROCEDURErMButton (): VBT.T = BEGIN RETURN NEW (FVMButton) END rMButton; PROCEDURErMenu (): VBT.T = BEGIN RETURN NEW (FVMenu) END rMenu; PROCEDURErMultiBrowser (): VBT.T = BEGIN RETURN NEW (FVMultiBrowser) END rMultiBrowser; PROCEDURErNumeric (): VBT.T = BEGIN RETURN NEW (FVNumeric) END rNumeric; PROCEDURErPageButton (): VBT.T = BEGIN RETURN NEW (FVPageButton) END rPageButton; PROCEDURErPageMButton (): VBT.T = BEGIN RETURN NEW (FVPageMButton) END rPageMButton; PROCEDURErPixmap (): VBT.T = BEGIN RETURN NEW (FVPixmap) END rPixmap; PROCEDURErPopButton (): VBT.T = BEGIN RETURN NEW (FVPopButton) END rPopButton; PROCEDURErPopMButton (): VBT.T = BEGIN RETURN NEW (FVPopMButton) END rPopMButton; PROCEDURErRadio (): VBT.T = BEGIN RETURN NEW (FVRadio) END rRadio; PROCEDURErRidge (): VBT.T = BEGIN RETURN NEW (FVRidge) END rRidge; PROCEDURErRim (): VBT.T = BEGIN RETURN NEW (FVRim) END rRim; PROCEDURErScale (): VBT.T = BEGIN RETURN NEW (FVScale) END rScale; PROCEDURErScroller (): VBT.T = BEGIN RETURN NEW (FVScroller) END rScroller; PROCEDURErShape (): VBT.T = BEGIN RETURN NEW (FVShape) END rShape; PROCEDURErSource (): VBT.T = BEGIN RETURN NEW (FVSource) END rSource; PROCEDURErStable (): VBT.T = BEGIN RETURN NEW (FVStable) END rStable; PROCEDURErTSplit (): VBT.T = BEGIN RETURN NEW (FVTSplit) END rTSplit; PROCEDURErTarget (): VBT.T = BEGIN RETURN NEW (FVTarget) END rTarget; PROCEDURErText (): VBT.T = BEGIN RETURN NEW (FVText) END rText; PROCEDURErTextEdit (): VBT.T = BEGIN RETURN NEW (FVTextEdit) END rTextEdit; PROCEDURErTexture (): VBT.T = BEGIN RETURN NEW (FVTexture) END rTexture; PROCEDURErTrillButton (): VBT.T = BEGIN RETURN NEW (FVTrillButton) END rTrillButton; PROCEDURErTypeIn (): VBT.T = BEGIN RETURN NEW (FVTypeIn) END rTypeIn; PROCEDURErTypescript (): VBT.T = BEGIN RETURN NEW (FVTypescript) END rTypescript; PROCEDURErVBox (): VBT.T = BEGIN RETURN NEW (FVVBox) END rVBox; PROCEDURErVTile (): VBT.T = BEGIN RETURN NEW (FVVTile) END rVTile; PROCEDURErVideo (): VBT.T = BEGIN RETURN NEW(FVVideo) END rVideo; PROCEDURErViewport (): VBT.T = BEGIN RETURN NEW (FVViewport) END rViewport; PROCEDURErVPackSplit (): VBT.T = BEGIN RETURN NEW (FVHPackSplit) END rVPackSplit; PROCEDURErZBackground (): VBT.T = BEGIN RETURN NEW (FVZBackground) END rZBackground; PROCEDURErZChassis (): VBT.T = BEGIN RETURN NEW (FVZChassis) END rZChassis; PROCEDURErZChild (): VBT.T = BEGIN RETURN NEW (FVZChild) END rZChild; PROCEDURErZGrow (): VBT.T = BEGIN RETURN NEW (FVZGrow) END rZGrow; PROCEDURErZMove (): VBT.T = BEGIN RETURN NEW (FVZMove) END rZMove; PROCEDURErZSplit (): VBT.T = BEGIN RETURN NEW (FVZSplit) END rZSplit;
PROCEDURE========================= Bar & Glue =============================pAny ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR name := NamePP(); state := s; res : FVAny; BEGIN ParseProps(cl, list, state, PP1{name}); res := cl.fv.realize("Any", name.valname); AddNameProp(cl, res, name, state); RETURN res END pAny; PROCEDUREpAnyFilter ( cl:ParseClosure; VAR list:RefList.T; READONLY s:State): VBT.T RAISES {Error} = VAR name := NamePP(); state := s; VAR res: FVAnyFilter; BEGIN ParseProps(cl, list, state, PP1{name}); res := cl.fv.realize("AnyFilter", name.valname); res := res.init(OneChild(cl, list, state)); AddNameProp(cl, res, name, state); RETURN res END pAnyFilter; PROCEDUREpAnySplit ( cl:ParseClosure; VAR list:RefList.T; READONLY s:State): VBT.T RAISES {Error} = VAR name := NamePP(); state := s; VAR res: FVAnySplit; BEGIN ParseProps(cl, list, state, PP1{name}); res := cl.fv.realize("AnySplit", name.valname); AddChildren(cl, res, list, state); AddNameProp(cl, res, name, state); RETURN res END pAnySplit;
Bar uses the current Color. Glue uses the current BgColor.
CONST FlexOne = FlexVBT.SizeRange{ 1.0 * Pts.MMPerInch / Pts.PtsPerInch, 0.0, 0.0};
FlexOnePointFive = FlexVBT.SizeRange{ 1.5 * Pts.MMPerInch / Pts.PtsPerInch, 0.0, 0.0};
PROCEDURE========================= Border & Rim =============================pBar ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR name := NamePP(); main := NEW(SizeRangePP, val := FlexOne, found := TRUE); state := s; res: FVBar; BEGIN IF state.hvsplit = NIL THEN RAISE Error("Bar must appear inside an HBox or VBox.") END; ParseProps(cl, list, state, PP2{name, main}, main := main); res := cl.fv.realize("Bar", name.valname); res := res.init(TextureVBT.New(state.fgOp), ShapefromSpec(main.val, state)); AddNameProp(cl, res, name, state); RETURN res END pBar; PROCEDUREpGlue ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR name := NamePP(); main := NEW(SizeRangePP, val := FlexOne, found := TRUE); state := s; res: FVGlue; BEGIN IF state.hvsplit = NIL THEN RAISE Error("Glue must appear inside an HBox or VBox.") END; ParseProps(cl, list, state, PP2{name, main}, main := main); res := cl.fv.realize("Glue", name.valname); res := res.init(TextureVBT.New(state.bgOp), ShapefromSpec(main.val, state)); AddNameProp(cl, res, name, state); RETURN res END pGlue; PROCEDUREShapefromSpec ( f : FlexVBT.SizeRange; READONLY state: State ): FlexVBT.Shape = VAR sh := FlexVBT.Default; BEGIN sh [state.glueAxis] := f; RETURN sh END ShapefromSpec;
PROCEDURE========================= Frame & Ridge =============================pBorder ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); pen := NEW(RealPP, name := "Pen", val := 1.0); texture := NEW(TextPP, name := "Pattern"); txt := Pixmap.Solid; VAR res: FVBorder; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP3{name, pen, texture}); ch := OneChild(cl, list, state); res := cl.fv.realize("Border", name.valname); IF texture.val # NIL THEN txt := GetPixmap(texture.val, cl.fv.path, cl.fv.baseURL) END; res := res.init(ch, Pts.ToMM(pen.val), state.shadow.bgFg, txt); AddNameProp(cl, res, name, state); RETURN res END pBorder; PROCEDUREpRim (cl: ParseClosure; VAR list: RefList.T; READONLY s: State): VBT.T RAISES {Error} = VAR state := s; name := NamePP (); pen := NEW (RealPP, name := "Pen", val := 1.0); texture := NEW (TextPP, name := "Pattern"); txt := Pixmap.Solid; VAR res: FVRim; ch : VBT.T; BEGIN ParseProps (cl, list, state, PP3 {name, pen, texture}); ch := OneChild (cl, list, state); res := cl.fv.realize ("Rim", name.valname); IF texture.val # NIL THEN txt := GetPixmap (texture.val, cl.fv.path, cl.fv.baseURL) END; res := res.init (ch, Pts.ToMM (pen.val), state.shadow.fgBg, txt); AddNameProp (cl, res, name, state); RETURN res END pRim; PROCEDUREGetPixmap (name: TEXT; path: Rsrc.Path; baseURL: TEXT): Pixmap.T RAISES {Error} = BEGIN WITH image = GetRawImage(name, path, baseURL) DO RETURN Image.Scaled(image) END END GetPixmap; PROCEDUREGetRawImage (name: TEXT; path: Rsrc.Path; baseURL: TEXT): Image.Raw RAISES {Error} = VAR rd: Rd.T; BEGIN TRY rd := Open(name, path, baseURL); TRY RETURN Image.FromRd(rd) FINALLY Rd.Close(rd) END; EXCEPT | Image.Error => RAISE Error("Format error in pixmap for " & name) | Rd.Failure (ref) => RAISE Error(RdUtils.FailureText(ref)) END END GetRawImage;
PROCEDURE=========================== Fill & Shape ===========================pFrame ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); shadowStyle := NewShadowStyle(Shadow.Style.Raised); VAR res: FVFrame; ch : VBT.T; BEGIN ParseProps( cl, list, state, PP1{name}, enums := EP1{shadowStyle}); ch := OneChild(cl, list, state); res := cl.fv.realize("Frame", name.valname); res := res.init(ch, state.shadow, VAL(shadowStyle.chosen, Shadow.Style)); AddNameProp(cl, res, name, state); RETURN res END pFrame; PROCEDUREpRidge ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); main := NEW( RealPP, val := DefaultShadowSizePts, found := TRUE); VAR res : FVRidge; shadow: Shadow.T; BEGIN ParseProps(cl, list, state, PP2{name, main}, main := main); res := cl.fv.realize("Ridge", name.valname); shadow := Shadow.New(Pts.ToMM(main.val), state.bgOp, state.fgOp, state.lightOp, state.darkOp); res := res.init(state.glueAxis, shadow, Shadow.Style.Ridged); AddNameProp(cl, res, name, state); RETURN res END pRidge; PROCEDUREpChisel ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); main := NEW( RealPP, val := DefaultShadowSizePts, found := TRUE); VAR res : FVChisel; shadow: Shadow.T; BEGIN ParseProps(cl, list, state, PP2{name, main}, main := main); res := cl.fv.realize("Chisel", name.valname); shadow := Shadow.New(Pts.ToMM(main.val), state.bgOp, state.fgOp, state.lightOp, state.darkOp); res := res.init(state.glueAxis, shadow, Shadow.Style.Chiseled); AddNameProp(cl, res, name, state); RETURN res END pChisel;
PROCEDURE=========================== Buttons ===============================pFill ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = CONST INFINITESTRETCH = FlexVBT.SizeRange{ natural := 0.0, shrink := 0.0, stretch := FlexVBT.Infinity}; VAR state := s; name := NamePP(); shape := FlexVBT.Default; res : FVFill; BEGIN IF state.hvsplit = NIL THEN RAISE Error("Fill must appear inside an HBox or VBox.") END; ParseProps(cl, list, state, PP1{name}); AssertEmpty(list); shape[state.glueAxis] := INFINITESTRETCH; res := cl.fv.realize("Fill", name.valname); res := res.init(TextureVBT.New(state.bgOp), shape); AddNameProp(cl, res, name, state); RETURN res END pFill; PROCEDUREpShape ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); height := NEW(SizeRangePP, name := "Height"); width := NEW(SizeRangePP, name := "Width"); res : FVShape; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP3{name, height, width}); ch := OneChild(cl, list, state); res := cl.fv.realize("Shape", name.valname); res := res.init(ch, FlexVBT.Shape{width.val, height.val}); AddNameProp(cl, res, name, state); RETURN res END pShape;
PROCEDURE====================== Boolean, Choice, Radio =======================pButton ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVButton; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP1{name}); ch := OneChild(cl, list, state); res := cl.fv.realize("Button", name.valname); res := res.init( NEW(ShadowedFeedbackVBT.T).init(ch, state.shadow)); AddNameProp(cl, res, name, state); RETURN res END pButton; PROCEDUREpMButton ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVMButton; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP1{name}); ch := OneChild(cl, list, state); res := cl.fv.realize("MButton", name.valname); res := res.init(ShadowedFeedbackVBT.NewMenu(ch, state.shadow)); AddNameProp(cl, res, name, state); RETURN res END pMButton; PROCEDUREpPopButton ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); forName := NEW(SymbolPP, name := "For"); res : FVPopButton; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP2{name, forName}); ch := OneChild(cl, list, state); res := cl.fv.realize("PopButton", name.valname); res := res.init( NEW(ShadowedFeedbackVBT.T).init(ch, state.shadow)); AddForProp(cl, res, forName); AddNameProp(cl, res, name, state); RETURN res END pPopButton; PROCEDUREpPopMButton ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); forName := NEW(SymbolPP, name := "For"); res : FVPopMButton; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP2{name, forName}); ch := OneChild(cl, list, state); res := cl.fv.realize("PopMButton", name.valname); res := res.init(ShadowedFeedbackVBT.NewMenu(ch, state.shadow)); AddForProp(cl, res, forName); AddNameProp(cl, res, name, state); RETURN res END pPopMButton; PROCEDUREpGuard ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVGuard; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP1{name}); ch := OneChild(cl, list, state); res := cl.fv.realize("Guard", name.valname); res := res.init(ch, state.shadow); AddNameProp(cl, res, name, state); RETURN res END pGuard; PROCEDUREpTrillButton ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVTrillButton; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP1{name}); ch := OneChild(cl, list, state); res := cl.fv.realize("TrillButton", name.valname); res := res.init( NEW(ShadowedFeedbackVBT.T).init(ch, state.shadow)); AddNameProp(cl, res, name, state); RETURN res END pTrillButton; PROCEDUREpPageButton ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); forName := NEW(SymbolPP, name := "For"); backwards := NEW(BooleanPP, name := "Back"); res : FVPageButton; ch : VBT.T; BEGIN ParseProps( cl, list, state, PP2{name, forName}, KP1{backwards}); ch := OneChild(cl, list, state); res := cl.fv.realize("PageButton", name.valname); IF forName.val # NIL THEN AddForProp(cl, res, forName) ELSIF state.tsplit = NIL THEN RAISE Error("This PageButton is not included in a TSplit and " & "it has no (For ...) property.") END; res := res.init(ch, state.shadow, backwards.val, state.tsplit); AddNameProp(cl, res, name, state); RETURN res END pPageButton; PROCEDUREpPageMButton ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); forName := NEW(SymbolPP, name := "For"); backwards := NEW(BooleanPP, name := "Back"); res : FVPageMButton; ch : VBT.T; BEGIN ParseProps( cl, list, state, PP2{name, forName}, KP1{backwards}); ch := OneChild(cl, list, state); res := cl.fv.realize("PageMButton", name.valname); IF forName.val # NIL THEN AddForProp(cl, res, forName) ELSIF state.tsplit = NIL THEN RAISE Error("This PageMButton is not included in a TSplit and " & "it has no (For ...) property.") END; res := res.init(ch, state.shadow, backwards.val, state.tsplit); AddNameProp(cl, res, name, state); RETURN res END pPageMButton; PROCEDUREpLinkButton ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); toName := NEW(SymbolPP, name := "For"); res : FVLinkButton; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP2{name, toName}); ch := OneChild(cl, list, state); res := cl.fv.realize("LinkButton", name.valname); IF toName.val = NIL THEN RAISE Error("LinkButton must include (To <name>)") END; AddForProp(cl, res, toName); res := res.init( NEW(ShadowedFeedbackVBT.T).init(ch, state.shadow)); AddNameProp(cl, res, name, state); RETURN res END pLinkButton; PROCEDUREpLinkMButton ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); toName := NEW(SymbolPP, name := "For"); res : FVLinkMButton; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP2{name, toName}); ch := OneChild(cl, list, state); res := cl.fv.realize("LinkMButton", name.valname); IF toName.val = NIL THEN RAISE Error("LinkMButton must include (To <name>)") END; AddForProp(cl, res, toName); res := res.init(ShadowedFeedbackVBT.NewMenu(ch, state.shadow)); AddNameProp(cl, res, name, state); RETURN res END pLinkMButton; PROCEDUREpCloseButton ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); forName := NEW(SymbolPP, name := "For"); res : FVCloseButton; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP2{name, forName}); ch := OneChild(cl, list, state); res := cl.fv.realize("CloseButton", name.valname); IF forName.val # NIL THEN AddForProp(cl, res, forName) ELSIF state.zchild # NIL THEN res.target := state.zchild ELSE RAISE Error( "This CloseButton is not included in a ZChild or ZChassis " & "and it has no (For ...) property.") END; res := res.init(ch, state.shadow); AddNameProp(cl, res, name, state); RETURN res END pCloseButton;
PROCEDURE=========================== Splits ===============================pBoolean ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); value := NEW(BooleanPP, name := "Value"); checkbox := NEW(BooleanPP, name := "CheckBox"); checkmark := NEW(BooleanPP, name := "CheckMark"); inverting := NEW(BooleanPP, name := "Inverting"); menustyle := NEW(BooleanPP, name := "MenuStyle"); enum := NEW(EnumPP).init( KP3{checkbox, checkmark, inverting}, 0); child, feedback: VBT.T; switch : ButtonVBT.T; res : FVBoolean; BEGIN ParseProps(cl, list, state, PP2{name, value}, KP1{menustyle}, enums := EP1{enum}); child := OneChild(cl, list, state); IF inverting.val THEN feedback := NEW(ShadowedFeedbackVBT.T).init(child, state.shadow) ELSIF checkmark.val THEN feedback := MarginFeedbackVBT.NewCheck(child, state.shadow) ELSE feedback := MarginFeedbackVBT.NewBox(child, state.shadow) END; IF menustyle.val THEN switch := NEW(MenuSwitchVBT.T).init( MenuStyle(feedback, state.shadow)) ELSE switch := NEW(SwitchVBT.T).init(feedback) END; res := cl.fv.realize("Boolean", name.valname); res := res.init(switch); BooleanVBT.Put(res, value.val); AddNameProp(cl, res, name, state); RETURN res END pBoolean; PROCEDUREpChoice ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); value := NEW(BooleanPP, name := "Value"); checkmark := NEW(BooleanPP, name := "CheckMark"); checkbox := NEW(BooleanPP, name := "CheckBox"); inverting := NEW(BooleanPP, name := "Inverting"); enum := NEW(EnumPP).init( KP3{checkbox, checkmark, inverting}, 0); menustyle := NEW(BooleanPP, name := "MenuStyle"); child, feedback: VBT.T; switch : ButtonVBT.T; res : FVChoice; BEGIN IF state.radio = NIL THEN RAISE Error("Choice must be contained within Radio") END; ParseProps(cl, list, state, PP2{name, value}, KP1{menustyle}, enums := EP1{enum}); IF name.val = NIL THEN RAISE Error("Choices must be named.") END; child := OneChild(cl, list, state); IF inverting.val THEN feedback := NEW(ShadowedFeedbackVBT.T).init(child, state.shadow) ELSIF checkmark.val THEN feedback := MarginFeedbackVBT.NewCheck(child, state.shadow) ELSE feedback := MarginFeedbackVBT.NewBullet(child, state.shadow) END; IF menustyle.val THEN switch := NEW(MenuSwitchVBT.T).init( MenuStyle(feedback, state.shadow)) ELSE switch := NEW(SwitchVBT.T).init(feedback) END; res := cl.fv.realize("Choice", name.valname); res := res.init(switch, state.radio.radio); res.radio := state.radio; res.name := name.valname; IF value.val THEN ChoiceVBT.Put(res) END; AddNameProp(cl, res, name, state); RETURN res END pChoice; PROCEDUREpRadio ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); value := NEW(SymbolPP, name := "Value"); res : FVRadio; BEGIN ParseProps(cl, list, state, PP2{name, value}); res := cl.fv.realize("Radio", name.valname); res.radio := NEW(ChoiceVBT.Group); state.radio := res; EVAL Filter.T.init(res, OneChild(cl, list, state)); (* Did the client select a choice via (Radio ... =<symbol> ...)? *) IF value.val # NIL THEN ChoiceVBT.Put(GetVBT(cl.fv, value.valname)) END; AddNameProp(cl, res, name, state); RETURN res END pRadio; PROCEDUREMenuStyle (feedback: FeedbackVBT.T; shadow: Shadow.T): FeedbackVBT.T = BEGIN WITH ch = MultiFilter.Replace(feedback, NIL), sh = ShadowedFeedbackVBT.NewMenu(NIL, shadow) DO RETURN NEW(BiFeedbackVBT.T).init(sh, feedback, ch) END END MenuStyle;
PROCEDURE========================== TSplits ============================pHBox (cl: ParseClosure; VAR list : RefList.T; READONLY s: State): VBT.T RAISES {Error} = BEGIN RETURN pHVBox(cl, list, s, Axis.T.Hor) END pHBox; PROCEDUREpVBox (cl: ParseClosure; VAR list : RefList.T; READONLY s: State): VBT.T RAISES {Error} = BEGIN RETURN pHVBox(cl, list, s, Axis.T.Ver) END pVBox; PROCEDUREpHVBox ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State; axis: Axis.T ): VBT.T RAISES {Error} = CONST TypeNames = ARRAY Axis.T OF TEXT{"HBox", "VBox"}; VAR state := s; name := NamePP(); res : HVSplit.T; BEGIN ParseProps(cl, list, state, PP1{name}); res := cl.fv.realize(TypeNames[axis], name.valname); res := res.init(axis, adjustable := FALSE); state.glueAxis := axis; state.hvsplit := res; AddChildren(cl, res, list, state); AddNameProp(cl, res, name, state); RETURN res END pHVBox; PROCEDUREpHTile (cl: ParseClosure; VAR list: RefList.T; READONLY s: State): VBT.T RAISES {Error} = BEGIN RETURN pHVTile (cl, list, s, Axis.T.Hor) END pHTile; PROCEDUREpVTile (cl: ParseClosure; VAR list: RefList.T; READONLY s: State): VBT.T RAISES {Error} = BEGIN RETURN pHVTile (cl, list, s, Axis.T.Ver) END pVTile; PROCEDUREpHVTile ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State; axis: Axis.T ): VBT.T RAISES {Error} = CONST TypeNames = ARRAY Axis.T OF TEXT{"HTile", "VTile"}; VAR state := s; name := NamePP(); (* asTargets := NEW (BooleanPP, name := "Targets"); *) res: SplitterVBT.T; BEGIN ParseProps( cl, list, state, PP1{name} (* , KP1 {asTargets} *)); res := cl.fv.realize(TypeNames[axis], name.valname); res := res.init(axis, op := state.shadow.bgFg); state.glueAxis := axis; AddChildren(cl, res, list, state); AddNameProp(cl, res, name, state); RETURN res END pHVTile; PROCEDUREpHPackSplit (cl: ParseClosure; VAR list: RefList.T; READONLY state: State): VBT.T RAISES {Error} = BEGIN RETURN pHVPackSplit (cl, list, state, Axis.T.Hor) END pHPackSplit; PROCEDUREpVPackSplit (cl: ParseClosure; VAR list: RefList.T; READONLY state: State): VBT.T RAISES {Error} = BEGIN RETURN pHVPackSplit (cl, list, state, Axis.T.Ver) END pVPackSplit; PROCEDUREpHVPackSplit ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State; axis: Axis.T ): VBT.T RAISES {Error} = CONST TypeNames = ARRAY Axis.T OF TEXT{"HPackSplit", "VPackSplit"}; VAR state := s; name := NamePP(); hgap := NEW(RealPP, name := "HGap", val := 2.0); vgap := NEW(RealPP, name := "VGap", val := 2.0); background := NEW(TextPP, name := "Background"); txt := Pixmap.Solid; VAR res: FVHPackSplit; BEGIN ParseProps( cl, list, state, PP4{name, hgap, vgap, background}); res := cl.fv.realize(TypeNames[axis], name.valname); IF background.val # NIL THEN txt := GetPixmap(background.val, cl.fv.path, cl.fv.baseURL) END; res := res.init(hv := axis, hgap := Pts.ToMM(hgap.val), vgap := Pts.ToMM(vgap.val), txt := txt, op := state.bgOp); AddChildren(cl, res, list, state); AddNameProp(cl, res, name, state); RETURN res END pHVPackSplit;
PROCEDURE===================== FileBrowser & Helper ====================pTSplit ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); value := NEW(CardinalPP, name := "Value", val := LAST(CARDINAL)); which := NEW(SymbolPP, name := "Which"); circular := NEW(BooleanPP, name := "Circular"); flexible := NEW(BooleanPP, name := "Flex"); res : FVTSplit; n : CARDINAL; namedChild, numberedChild: VBT.T := NIL; BEGIN ParseProps(cl, list, state, PP3{name, value, which}, KP2{circular, flexible}); res := cl.fv.realize("TSplit", name.valname); res := res.init(fickle := flexible.val); res.circular := circular.val; state.tsplit := res; AddChildren(cl, res, list, state); (* Check validity and consistency of (Which n) and (Value name). *) n := Split.NumChildren(res); IF which.val # NIL THEN namedChild := GetVBT(cl.fv, which.valname) END; TRY IF value.val = LAST(CARDINAL) THEN IF namedChild # NIL THEN TSplit.SetCurrent(res, namedChild) ELSE TSplit.SetCurrent(res, Split.Nth(res, 0)) END ELSIF value.val < n THEN numberedChild := Split.Nth(res, value.val); IF namedChild = NIL OR namedChild = numberedChild THEN TSplit.SetCurrent(res, numberedChild) ELSE RAISE Error( Fmt.F( "(Which %s) is not the same child as (Value %s)", Atom.ToText(which.val), Fmt.Int(value.val))) END ELSIF value.val = 1 THEN RAISE Error("TSplit has no children.") ELSE RAISE Error( Fmt.F("TSplit has only %s children.", Fmt.Int(n))) END EXCEPT Split.NotAChild => RAISE Error( Atom.ToText(which.val) & " is not the name of a child of this TSplit.") END; AddNameProp(cl, res, name, state); RETURN res END pTSplit;
PROCEDURE=========================== Insert ===========================pFileBrowser ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); value := NEW(TextPP, name := "Value", val := "."); suffixes := NEW(TextListPP, name := "Suffixes"); readOnly := NEW(BooleanPP, name := "ReadOnly"); res: FVFileBrowser; BEGIN ParseProps( cl, list, state, PP3{name, value, suffixes}, KP1{readOnly}); AssertEmpty(list); res := cl.fv.realize("FileBrowser", name.valname); res := res.init(state.font, state.shadow); TRY IF value.found THEN FileBrowserVBT.Set(res, value.val) END; FileBrowserVBT.SetReadOnly(res, readOnly.val); IF suffixes.val # NIL THEN FileBrowserVBT.SetSuffixes( res, SuffixesFromList(suffixes.val)) END EXCEPT | FileBrowserVBT.Error (e) => RAISE Error(Fmt.F("Error for %s: %s", e.path, e.text)) END; AddNameProp(cl, res, name, state); RETURN res END pFileBrowser; PROCEDURESuffixesFromList (list: RefList.T): TEXT = VAR wr := TextWr.New (); <* FATAL Wr.Failure, Thread.Alerted *> BEGIN LOOP IF Text.Empty (list.head) THEN Wr.PutChar (wr, '$') ELSE Wr.PutText (wr, list.head) END; list := list.tail; IF list = NIL THEN RETURN TextWr.ToText (wr) END; Wr.PutChar (wr, ' ') END END SuffixesFromList; PROCEDUREpHelper ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); forName := NEW(SymbolPP, name := "For"); firstFocus := NEW(BooleanPP, name := "FirstFocus"); expandOnDemand := NEW(BooleanPP, name := "ExpandOnDemand"); tabTo := NEW(SymbolPP, name := "TabTo"); VAR res: FVHelper; BEGIN ParseProps(cl, list, state, PP3{name, forName, tabTo}, KP2{firstFocus, expandOnDemand}); IF forName.val = NIL THEN RAISE Error("Helper must include (For <name>)") END; AssertEmpty(list); res := cl.fv.realize("Helper", name.valname); res := res.init(expandOnDemand.val, font := state.font, colorScheme := state.shadow); AddForProp(cl, res, forName); IF tabTo.val # NIL THEN AddForProp(cl, res, tabTo) END; CheckFirstFocus(firstFocus, res); AddNameProp(cl, res, name, state); RETURN res END pHelper; PROCEDURECheckFirstFocus (firstFocus: BooleanPP; widget: VBT.T) = BEGIN IF firstFocus.val THEN FVRuntime.SetFirstFocus(widget) END END CheckFirstFocus; PROCEDUREpDirMenu ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); forName := NEW(SymbolPP, name := "For"); res : FVDirMenu; BEGIN ParseProps(cl, list, state, PP2{name, forName}); IF forName.val = NIL THEN RAISE Error("DirMenu must include (For <name>)") END; AssertEmpty(list); res := cl.fv.realize("DirMenu", name.valname); res := res.init(font := state.font, shadow := state.shadow); AddForProp(cl, res, forName); AddNameProp(cl, res, name, state); RETURN res END pDirMenu; PROCEDUREpBrowser ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); value := NEW(IntegerPP, name := "Value", val := -1); select := NEW(TextPP, name := "Select"); items := NEW(TextListPP, name := "Items"); from := NEW(TextPP, name := "From"); quick := NEW(BooleanPP, name := "Quick"); colors: Shadow.T; res : FVBrowser; u : UniSelector; BEGIN ParseProps(cl, list, state, PP5{name, value, select, items, from}, KP1{quick}); AssertEmpty(list); res := cl.fv.realize("Browser", name.valname); colors := state.shadow; TYPECASE res.painter OF | NULL => res.painter := NEW(ListVBT.TextPainter).init( colors.bg, colors.fg, colors.fg, colors.bg, state.font) | ListVBT.TextPainter (tp) => res.painter := tp.init(colors.bg, colors.fg, colors.fg, colors.bg, state.font) ELSE END; TYPECASE res.selector OF | NULL => u := NEW(UniSelector).init(res); res.selector := u | UniSelector (sel) => u := sel.init(res) ELSE RAISE Error( "Browser has a selector that is not a subtype of FVTypes.UniSelector") END; u.browser := res; u.quick := quick.val; res := res.init(colors := state.shadow); IF items.val # NIL THEN SetValues(res, items.val) ELSIF from.val # NIL THEN SetValues(res, ItemsFromFile(from.val, cl)) END; IF value.val # -1 THEN res.selectOnly(value.val) ELSIF select.val # NIL THEN res.selectOnly(ListVBTPosition(res, select.val)) END; AddNameProp(cl, res, name, state); RETURN res END pBrowser; PROCEDUREpMultiBrowser ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); value := NEW(CardinalListPP, name := "Value"); select := NEW(TextListPP, name := "Select"); items := NEW(TextListPP, name := "Items"); from := NEW(TextPP, name := "From"); quick := NEW(BooleanPP, name := "Quick"); res : FVMultiBrowser; m : MultiSelector; colors: Shadow.T; BEGIN ParseProps(cl, list, state, PP5{name, value, select, items, from}, KP1{quick}); AssertEmpty(list); res := cl.fv.realize("MultiBrowser", name.valname); colors := state.shadow; TYPECASE res.painter OF | NULL => res.painter := NEW(ListVBT.TextPainter).init( colors.bg, colors.fg, colors.fg, colors.bg, state.font) | ListVBT.TextPainter (tp) => res.painter := tp.init(colors.bg, colors.fg, colors.fg, colors.bg, state.font) ELSE END; TYPECASE res.selector OF | NULL => m := NEW(MultiSelector).init(res); res.selector := m | MultiSelector (sel) => m := sel.init(res) ELSE RAISE Error( "MultiBrowser has a selector that is not a subtype " & "of FVTypes.MultiSelector") END; m.quick := quick.val; m.browser := res; res := res.init(colors := state.shadow); IF items.val # NIL THEN SetValues(res, items.val) ELSIF from.val # NIL THEN SetValues(res, ItemsFromFile(from.val, cl)) END; IF value.val # NIL THEN REPEAT res.select(NARROW(Pop(value.val), REF INTEGER)^, TRUE) UNTIL value.val = NIL ELSIF select.val # NIL THEN REPEAT res.select(ListVBTPosition(res, Pop(select.val)), TRUE) UNTIL select.val = NIL END; AddNameProp(cl, res, name, state); RETURN res END pMultiBrowser; PROCEDURESetValues (v: ListVBT.T; new: RefList.T) = VAR oldCount := v.count (); newCount := RefList.Length (new); delta := oldCount - newCount; BEGIN IF delta < 0 THEN v.insertCells (oldCount, -delta) ELSIF delta > 0 THEN v.removeCells (newCount, delta) END; FOR j := 0 TO newCount - 1 DO v.setValue (j, Pop (new)) END END SetValues; PROCEDUREListVBTPosition (v: ListVBT.T; item: TEXT): [-1 .. LAST (CARDINAL)] = BEGIN FOR i := v.count () - 1 TO 0 BY -1 DO IF Text.Equal (v.getValue (i), item) THEN RETURN i END END; RETURN -1 END ListVBTPosition; PROCEDUREItemsFromFile (name: TEXT; cl: ParseClosure): RefList.T RAISES {Error} = VAR tl: RefList.T := NIL; BEGIN TRY (* EXCEPT *) WITH in = Open(name, cl.fv.path, cl.fv.baseURL) DO TRY (* FINALLY *) TRY (* EXCEPT *) LOOP Push(tl, Rd.GetLine(in)) END EXCEPT | Rd.EndOfFile => RETURN RefList.ReverseD(tl) END (* TRY *) FINALLY Rd.Close(in) END (* TRY *) END (* WITH *) EXCEPT | Rd.Failure (ref) => RAISE Error(RdUtils.FailureText(ref)) END (* TRY *) END ItemsFromFile;
PROCEDURE=========================== Menus ===============================InsertFile (pathname: TEXT; path: Rsrc.Path; baseURL: TEXT): RefList.T RAISES {Error} = VAR res: RefList.T := NIL; rd : Rd.T; BEGIN TRY rd := Open(pathname, path, baseURL); TRY LOOP Push(res, Sx.Read(rd, syntax := FVSyntax)) END FINALLY Rd.Close(rd) END EXCEPT | Sx.ReadError (txt) => RAISE Error("Sx.ReadError: " & txt) | Rd.EndOfFile => RETURN RefList.ReverseD(res) | Rd.Failure (ref) => RAISE Error(RdUtils.FailureText(ref)) END END InsertFile;
PROCEDURE=========================== Help ===============================pMenu ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); local := NEW(BooleanPP, name := "NotInTrestle"); res : FVMenu; count: CARDINAL; BEGIN ParseProps(cl, list, state, PP1{name}, KP1{local}); WITH feedback = NEW(ShadowedFeedbackVBT.T).init( NIL, state.shadow), menuFrame = NEW(ShadowedVBT.T).init( NIL, state.shadow, Shadow.Style.Raised) DO res := cl.fv.realize("Menu", name.valname); IF local.val THEN count := 0 ELSE count := LAST(CARDINAL) END; res := res.init(feedback, menuFrame, count, state.menubar); AddChildren(cl, res, list, state); AddNameProp(cl, res, name, state); RETURN res END END pMenu;
PROCEDURE=========================== Numeric ===============================pHelp (cl: ParseClosure; VAR list: RefList.T; READONLY s: State): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); local := NEW(BooleanPP, name := "NotInTrestle"); res : FVHelp; count: CARDINAL; BEGIN ParseProps(cl, list, state, PP1{name}, KP1{local}); res := cl.fv.realize("Help", name.valname); IF local.val THEN count := 0 ELSE count := LAST(CARDINAL) END; res := res.init(NIL, NIL, count); AddChildren(cl, res, list, state); AddNameProp(cl, res, name, state); RETURN res; END pHelp;
PROCEDURE======================= Texture ===========================pNumeric ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); allowEmpty := NEW(BooleanPP, name := "AllowEmpty"); hideButtons := NEW(BooleanPP, name := "HideButtons"); value := NEW(IntegerPP, name := "Value"); min := NEW(IntegerPP, name := "Min", val := FIRST(INTEGER)); max := NEW(IntegerPP, name := "Max", val := LAST(INTEGER)); forName := NEW(SymbolPP, name := "TabTo"); firstFocus := NEW(BooleanPP, name := "FirstFocus"); res: FVNumeric; BEGIN ParseProps( cl, list, state, PP5{min, max, value, name, forName}, KP3{allowEmpty, hideButtons, firstFocus}); AssertEmpty(list); IF max.val < min.val THEN RAISE Error(Fmt.F("Numeric max (%s) is less than min (%s)", Fmt.Int(max.val), Fmt.Int(min.val))) ELSIF NOT value.found THEN value.val := MIN(MAX(0, min.val), max.val) ELSIF min.val <= value.val AND value.val <= max.val THEN (* skip *) ELSE RAISE Error( Fmt.F( "Initial Numeric value (%s) is not between %s and %s", Fmt.Int(value.val), Fmt.Int(min.val), Fmt.Int(max.val))) END; res := cl.fv.realize("Numeric", name.valname); res := res.init(min.val, max.val, allowEmpty.val, hideButtons.val, state.font, state.shadow); NumericVBT.Put(res, value.val); IF forName.val # NIL THEN AddForProp(cl, res, forName) END; CheckFirstFocus(firstFocus, res); AddNameProp(cl, res, name, state); RETURN res END pNumeric;
PROCEDURE======================= Pixmap & Image ===========================pTexture ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); main := NEW(TextPP, found := TRUE); localalign := NEW(BooleanPP, name := "LocalAlign"); res: FVTexture; txt := Pixmap.Solid; BEGIN ParseProps( cl, list, state, PP2{name, main}, KP1{localalign}, main); res := cl.fv.realize("Texture", name.valname); IF main.val # NIL THEN txt := GetPixmap(main.val, cl.fv.path, cl.fv.baseURL) END; res := res.init(state.shadow.bgFg, txt, localalign.val); AddNameProp(cl, res, name, state); RETURN res END pTexture;
PROCEDUREpImage (<*UNUSED*> cl : ParseClosure; <*UNUSED*> VAR list: RefList.T; <*UNUSED*> READONLY s : State ): VBT.T RAISES {Error} =
****************** VAR state := s; name := NamePP(); main := NEW(TextPP); accurate := NEW(BooleanPP, name :=Accurate
); gamma := NEW(BooleanPP, name :=NeedsGamma
); res : FVImage; len: INTEGER; ****************
BEGIN RAISE Error ("Image not currently supported.");
************ ParseProps(cl, list, state, PP2{name, main}, KP2{accurate, gamma}, main := main); res := cl.fv.realize(Image
, name.valname); res.bg := state.shadow.bg; res.op := state.shadow.bgFg; IF gamma.val THEN res.gamma := 2.4 ELSE res.gamma := 1.0 END; res.rd := Open(main.val, cl.fv.path, cl.fv.baseURL); TRY len := Rd.Length(res.rd) EXCEPTThread.Alerted => <* ASSERT FALSE *> Rd.Failure (ref) => RAISE Error(RdUtils.FailureText(ref))END; WITH pm = NEW(ImageRd.T).init(res.rd, 0, len, res.op, NIL, res.gamma) DO res := res.init(pm, res.bg) END; AddNameProp(cl, res, name, state); RETURN res **************
END pImage; PROCEDURE=========================== Scroller ===============================pPixmap ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); main := NEW(TextPP); accurate := NEW(BooleanPP, name := "Accurate"); gamma := NEW(BooleanPP, name := "NeedsGamma"); res : FVPixmap; image : Image.Raw; op : PaintOp.T; BEGIN ParseProps(cl, list, state, PP2{name, main}, KP2{accurate, gamma}, main := main); res := cl.fv.realize("Pixmap", name.valname); image := GetRawImage(main.val, cl.fv.path, cl.fv.baseURL); TYPECASE image OF | Image.RawBitmap => op := state.shadow.bgFg | Image.RawPixmap (im) => op := PaintOp.Copy; im.needsGamma := gamma.val; IF accurate.val THEN im.colorMode := Image.Mode.Accurate ELSE im.colorMode := Image.Mode.Normal END ELSE <* ASSERT FALSE *> END; res := res.init(Image.Scaled(image), op:=op, bg:=state.shadow.bg); AddNameProp(cl, res, name, state); RETURN res END pPixmap;
PROCEDURE======================== Source & Target =======================pScroller ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); value := NEW(IntegerPP, name := "Value", val := 50); min := NEW(IntegerPP, name := "Min", val := 0); max := NEW(IntegerPP, name := "Max", val := 100); v := NEW(BooleanPP, name := "Vertical"); thumb := NEW(CardinalPP, name := "Thumb", val := 0); step := NEW(CardinalPP, name := "Step", val := 1); axis := Axis.T.Hor; res: FVScroller; BEGIN ParseProps(cl, list, state, PP6{name, value, min, max, thumb, step}, KP1{v}); AssertEmpty(list); IF v.val THEN axis := Axis.T.Ver END; thumb.val := MIN(thumb.val, max.val - min.val); res := cl.fv.realize("Scroller", name.valname); res := res.init(axis, min.val, max.val, state.shadow, step.val, thumb.val); ScrollerVBT.Put(res, value.val); AddNameProp(cl, res, name, state); RETURN res END pScroller;
PROCEDURE==================== Stable =====================pSource ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVSource; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP1{name}); ch := OneChild(cl, list, state); res := cl.fv.realize("Source", name.valname); res := res.init( NEW(ShadowedFeedbackVBT.T).init(ch, state.shadow)); AddNameProp(cl, res, name, state); RETURN res END pSource; PROCEDUREpTarget ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVTarget; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP1{name}); ch := OneChild(cl, list, state); res := cl.fv.realize("Target", name.valname); res := res.init(ch); SourceVBT.BeTarget(res, SourceVBT.NewTarget()); AddNameProp(cl, res, name, state); RETURN res END pTarget;
PROCEDURE==================== Filter, Generic, Viewport =====================pStable ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVStable; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP1{name}); ch := OneChild(cl, list, state); res := cl.fv.realize("Stable", name.valname); res := res.init(ch); AddNameProp(cl, res, name, state); RETURN res END pStable;
PROCEDURE============================= Text =================================pFilter ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); active := NEW(BooleanPP, name := "Active"); passive := NEW(BooleanPP, name := "Passive"); dormant := NEW(BooleanPP, name := "Dormant"); vanish := NEW(BooleanPP, name := "Vanish"); enum := NEW(EnumPP).init( KP4{active, passive, dormant, vanish}, 0); cursor := NEW(TextPP, name := "Cursor", val := ""); curs : Cursor.T; res : FVFilter; ch : VBT.T; BEGIN ParseProps( cl, list, state, PP2{name, cursor}, enums := EP1{enum}); ch := OneChild(cl, list, state); res := cl.fv.realize("Filter", name.valname); res := res.init(ch, state.shadow); IF Text.Empty(cursor.val) THEN curs := Cursor.DontCare ELSE curs := Cursor.FromName(ARRAY OF TEXT{cursor.val}) END; ReactivityVBT.Set( res, VAL(enum.chosen, ReactivityVBT.State), curs); AddNameProp(cl, res, name, state); RETURN res END pFilter; PROCEDUREpScale ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); hscale := NEW(RealPP, name := "HScale", val := 1.0); vscale := NEW(RealPP, name := "VScale", val := 1.0); auto := NEW(BooleanPP, name := "Auto"); autoFixed := NEW(BooleanPP, name := "AutoFixed"); VAR res: FVScale; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP3{name, hscale, vscale}, KP2{auto, autoFixed}); ch := OneChild(cl, list, state); res := cl.fv.realize("Scale", name.valname); res := res.init(ch); IF auto.val THEN ScaleFilter.AutoScale(res, keepAspectRatio := FALSE) ELSIF autoFixed.val THEN ScaleFilter.AutoScale(res, keepAspectRatio := TRUE) ELSE IF hscale.val < 1.0E-6 THEN RAISE Error("HScale is too small") END; IF vscale.val < 1.0E-6 THEN RAISE Error("VScale is too small") END; ScaleFilter.Scale(res, hscale.val, vscale.val) END; AddNameProp(cl, res, name, state); RETURN res END pScale; PROCEDUREpGeneric ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVGeneric; BEGIN ParseProps(cl, list, state, PP1{name}); AssertEmpty(list); res := cl.fv.realize("Generic", name.valname); res := res.init(NEW(TextureVBT.T).init(txt := Pixmap.Gray), FVRuntime.EMPTYSHAPE); AddNameProp(cl, res, name, state); RETURN res END pGeneric; PROCEDUREpViewport ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); step := NEW(CardinalPP, name := "Step", val := 10); horandver := NEW(BooleanPP, name := "HorAndVer"); horonly := NEW(BooleanPP, name := "HorOnly"); veronly := NEW(BooleanPP, name := "VerOnly"); enum := NEW(EnumPP).init(KP3{horandver, horonly, veronly}, 0); res : FVViewport; ch : VBT.T; axis : Axis.T; shapeStyle: ViewportVBT.ShapeStyle; BEGIN ParseProps(cl, list, state, PP2{name, step}, enums := EP1{enum}); ch := OneChild(cl, list, state); IF horandver.val OR horonly.val THEN axis := Axis.T.Ver ELSE axis := Axis.T.Hor END; IF horandver.val THEN shapeStyle := ViewportVBT.ShapeStyle.Unrelated ELSE shapeStyle := ViewportVBT.ShapeStyle.Related END; res := cl.fv.realize("Viewport", name.valname); res := res.init(ch := ch, axis := axis, shadow := state.shadow, step := step.val, shapeStyle := shapeStyle, scrollStyle := VAL(enum.chosen, ViewportVBT.ScrollStyle)); AddNameProp(cl, res, name, state); RETURN res END pViewport;
PROCEDURE========================== Text editors =========================pText ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); main := NEW(TextPP, found := TRUE); margin := NEW(RealPP, name := "Margin", val := 2.0); vmargin := NEW(RealPP, name := "VMargin", val := 0.0); leftalign := NEW(BooleanPP, name := "LeftAlign"); centeralign := NEW(BooleanPP, name := "Center"); rightalign := NEW(BooleanPP, name := "RightAlign"); enum := NEW(EnumPP).init( KP3{leftalign, centeralign, rightalign}, 1); from := NEW(TextPP, name := "From"); res : FVText; BEGIN ParseProps(cl, list, state, PP5{name, main, margin, vmargin, from}, main := main, enums := EP1{enum}); IF main.val # NIL THEN (* skip *) ELSIF from.val # NIL THEN main.val := TextFromFile(from.val, cl) ELSE RAISE Error("Main property is missing") END; res := cl.fv.realize("Text", name.valname); res := res.init(main.val, bgFg := state.shadow, fnt := state.labelFont, halign := FLOAT(enum.chosen) * 0.5, vmargin := Pts.ToMM(vmargin.val), hmargin := Pts.ToMM(margin.val)); AddNameProp(cl, res, name, state); RETURN res END pText;
PROCEDURE======================== ZSplits & ZChildren =====================pTypeIn ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); value := NEW(TextPP, name := "Value", val := ""); readOnly := NEW(BooleanPP, name := "ReadOnly"); expandOnDemand := NEW(BooleanPP, name := "ExpandOnDemand"); forName := NEW(SymbolPP, name := "TabTo"); turnMargin := NEW(RealPP, name := "TurnMargin", val := 2.0); firstFocus := NEW(BooleanPP, name := "FirstFocus"); from := NEW(TextPP, name := "From"); VAR res: FVTypeIn; BEGIN ParseProps(cl, list, state, PP5{name, value, forName, turnMargin, from}, KP3{readOnly, expandOnDemand, firstFocus}); AssertEmpty(list); res := cl.fv.realize("TypeIn", name.valname); res := res.init(expandOnDemand.val, font := state.font, colorScheme := state.shadow, readOnly := readOnly.val, turnMargin := Pts.ToMM(turnMargin.val)); IF value.found OR from.val = NIL THEN TextPort.SetText(res, value.val) ELSE TextPort.SetText(res, TextFromFile(from.val, cl)) END; VBT.SetCursor(res, Cursor.TextPointer); IF forName.val # NIL THEN AddForProp(cl, res, forName) END; CheckFirstFocus(firstFocus, res); AddNameProp(cl, res, name, state); RETURN res END pTypeIn; PROCEDUREpTextEdit ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); value := NEW(TextPP, name := "Value", val := ""); readOnly := NEW(BooleanPP, name := "ReadOnly"); clip := NEW(BooleanPP, name := "Clip"); turnMargin := NEW(RealPP, name := "TurnMargin", val := 2.0); from := NEW(TextPP, name := "From"); noScrollbar := NEW(BooleanPP, name := "NoScrollbar"); firstFocus := NEW(BooleanPP, name := "FirstFocus"); reportKeys := NEW(BooleanPP, name := "ReportKeys"); VAR res: FVTextEdit; BEGIN ParseProps( cl, list, state, PP4{name, value, from, turnMargin}, KP5{readOnly, clip, noScrollbar, firstFocus, reportKeys}); AssertEmpty(list); res := cl.fv.realize("TextEdit", name.valname); IF res.tp = NIL THEN res.tp := NEW(Port) END; res.tp := NARROW(res.tp, Port).init( textedit := res, reportKeys := TRUE (* reportKeys.val *), font := state.font, colorScheme := state.shadow, readOnly := readOnly.val, wrap := NOT clip.val, turnMargin := Pts.ToMM(turnMargin.val)); IF value.found OR from.val = NIL THEN TextPort.SetText(res.tp, value.val) ELSE TextPort.SetText(res.tp, TextFromFile(from.val, cl)) END; IF res.sb # NIL THEN res.sb := res.sb.init(Axis.T.Ver, state.shadow) ELSIF NOT noScrollbar.val THEN res.sb := NEW(TextEditVBT.Scrollbar).init(Axis.T.Ver, state.shadow) END; res := res.init(NOT noScrollbar.val); VBT.SetCursor(res, Cursor.TextPointer); CheckFirstFocus(firstFocus, res); AddNameProp(cl, res, name, state); RETURN res END pTextEdit; PROCEDUREpTypescript ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); readOnly := NEW(BooleanPP, name := "ReadOnly"); clip := NEW(BooleanPP, name := "Clip"); turnMargin := NEW(RealPP, name := "TurnMargin", val := 2.0); firstFocus := NEW(BooleanPP, name := "FirstFocus"); VAR res: FVTypescript; BEGIN ParseProps(cl, list, state, PP2{name, turnMargin}, KP2{readOnly, clip}); AssertEmpty(list); res := cl.fv.realize("Typescript", name.valname); TYPECASE res.tp OF | NULL => res.tp := NEW(TypescriptVBT.Port) | TypescriptVBT.Port => ELSE RAISE Error("The .tp field of the Typescript must be " & "a subtype of TypescriptVBT.Port") END; res.tp := res.tp.init( font := state.font, colorScheme := state.shadow, readOnly := readOnly.val, wrap := NOT clip.val, turnMargin := Pts.ToMM(turnMargin.val)); IF res.sb = NIL THEN res.sb := NEW(TextEditVBT.Scrollbar) END; res.sb := res.sb.init(Axis.T.Ver, state.shadow); res := res.init(); VBT.SetCursor(res, Cursor.TextPointer); CheckFirstFocus(firstFocus, res); AddNameProp(cl, res, name, state); RETURN res END pTypescript; PROCEDURETextFromFile (filename: TEXT; cl: ParseClosure): TEXT RAISES {Error} = BEGIN TRY IF cl.fv.baseURL = NIL THEN RETURN Rsrc.Get(filename, cl.fv.path); ELSE WITH rd = Open(filename, cl.fv.path, cl.fv.baseURL) DO TRY RETURN Rd.GetText(rd, LAST(CARDINAL)) FINALLY Rd.Close(rd) END END END EXCEPT | Rd.Failure (ref) => RAISE Error(RdUtils.FailureText(ref)) | Thread.Alerted => RAISE Error("interrupted (Thread.Alerted)") | Rsrc.NotFound => RAISE Error("No such resource: " & filename) END END TextFromFile; PROCEDURENewShadowStyle (default := Shadow.Style.Flat): EnumPP = VAR flat := NEW (BooleanPP, name := "Flat"); raised := NEW (BooleanPP, name := "Raised"); lowered := NEW (BooleanPP, name := "Lowered"); ridged := NEW (BooleanPP, name := "Ridged"); chiseled := NEW (BooleanPP, name := "Chiseled"); BEGIN RETURN NEW (EnumPP).init ( KP5 {flat, raised, lowered, ridged, chiseled}, ORD (default)) END NewShadowStyle;
PROCEDURE============================ Video and Audio ===========================pZSplit ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVZSplit; BEGIN ParseProps(cl, list, state, PP1{name}); res := cl.fv.realize("ZSplit", name.valname); res := res.init(); state.zsplit := res; AddChildren(cl, res, list, state); AddNameProp(cl, res, name, state); RETURN res END pZSplit; PROCEDUREpZBackground ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVZBackground; ch : VBT.T; BEGIN (* it's OK, because we may be inserting the form dynamically IF state.zsplit = NIL THEN RAISE Error ("ZBackground must be inside a ZSplit.") END; *) ParseProps(cl, list, state, PP1{name}); ch := OneChild(cl, list, state); res := cl.fv.realize("ZBackground", name.valname); res := res.init(ch); AddNameProp(cl, res, name, state); RETURN res END pZBackground; PROCEDUREpZChassis ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); open := NEW(BooleanPP, name := "Open"); noClose := NEW(BooleanPP, name := "NoClose"); title := NEW(VBTPP, name := "Title"); at := NEW(AtSpecPP, name := "At"); chain := NEW(ChainsPP, name := "Chain"); scaled := NEW(BooleanPP, name := "Scaled"); fixedH := NEW(BooleanPP, name := "FixedH"); fixedV := NEW(BooleanPP, name := "FixedV"); fixedHV := NEW(BooleanPP, name := "FixedHV"); VAR res : FVZChassis; titleChild, ch: VBT.T; shaper : ZSplit.ReshapeControl; BEGIN (* it's OK, because we may be inserting the form dynamically IF state.zsplit = NIL THEN RAISE Error ("ZChassis must be inside a ZSplit.") END; *) ParseProps( cl, list, state, PP4{name, title, at, chain}, KP6{open, noClose, scaled, fixedH, fixedV, fixedHV}); IF title.val = NIL THEN titleChild := TextVBT.New("<Untitled>", fnt := state.labelFont, bgFg := state.shadow) ELSE titleChild := OneChild(cl, title.val, state) END; res := cl.fv.realize("ZChassis", name.valname); state.zchild := res; ch := OneChild(cl, list, state); IF chain.shaper # NIL THEN shaper := chain.shaper ELSIF scaled.val THEN shaper := ZChildVBT.Scaled ELSIF fixedH.val THEN shaper := ZChildVBT.ScaledHFixed ELSIF fixedV.val THEN shaper := ZChildVBT.ScaledVFixed ELSIF fixedHV.val THEN shaper := ZChildVBT.ScaledHVFixed ELSE shaper := NIL END; IF at.val.edges THEN IF shaper = NIL THEN shaper := ZChildVBT.Scaled END; res := res.initFromEdges( ch, titleChild, at.val.w, at.val.e, at.val.n, at.val.s, state.shadow, NOT noClose.val, open.val, at.val.type, shaper) ELSE IF shaper = NIL THEN shaper := ZChildVBT.ScaledHVFixed END; res := res.init(ch, titleChild, state.shadow, NOT noClose.val, open.val, at.val.h, at.val.v, at.val.loc, at.val.type, shaper) END; AddNameProp(cl, res, name, state); RETURN res END pZChassis; PROCEDUREpZChild ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); open := NEW(BooleanPP, name := "Open"); at := NEW(AtSpecPP, name := "At"); chain := NEW(ChainsPP, name := "Chain"); scaled := NEW(BooleanPP, name := "Scaled"); fixedH := NEW(BooleanPP, name := "FixedH"); fixedV := NEW(BooleanPP, name := "FixedV"); fixedHV := NEW(BooleanPP, name := "FixedHV"); VAR res : FVZChild; ch : VBT.T; shaper: ZSplit.ReshapeControl; BEGIN (* it's OK, because we may be inserting the form dynamically IF state.zsplit = NIL THEN RAISE Error ("ZChild must be inside a ZSplit.") END; *) ParseProps(cl, list, state, PP3{name, at, chain}, KP5{open, scaled, fixedH, fixedV, fixedHV}); res := cl.fv.realize("ZChild", name.valname); state.zchild := res; ch := OneChild(cl, list, state); IF chain.shaper # NIL THEN shaper := chain.shaper ELSIF scaled.val THEN shaper := ZChildVBT.Scaled ELSIF fixedH.val THEN shaper := ZChildVBT.ScaledHFixed ELSIF fixedV.val THEN shaper := ZChildVBT.ScaledVFixed ELSIF fixedHV.val THEN shaper := ZChildVBT.ScaledHVFixed ELSE shaper := NIL END; IF at.val.edges THEN IF shaper = NIL THEN shaper := ZChildVBT.Scaled END; res := res.initFromEdges( ch, at.val.w, at.val.e, at.val.n, at.val.s, at.val.type, shaper, open.val) ELSE IF shaper = NIL THEN shaper := ZChildVBT.ScaledHVFixed END; res := res.init(ch, at.val.h, at.val.v, at.val.loc, at.val.type, shaper, open.val) END; AddNameProp(cl, res, name, state); RETURN res END pZChild; PROCEDUREpZGrow ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVZGrow; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP1{name}); ch := OneChild(cl, list, state); res := cl.fv.realize("ZGrow", name.valname); res := res.init( NEW(ShadowedFeedbackVBT.T).init(ch, state.shadow)); AddNameProp(cl, res, name, state); RETURN res END pZGrow; PROCEDUREpZMove ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); res : FVZMove; ch : VBT.T; BEGIN ParseProps(cl, list, state, PP1{name}); ch := OneChild(cl, list, state); res := cl.fv.realize("ZMove", name.valname); res := res.init( NEW(ShadowedFeedbackVBT.T).init(ch, state.shadow)); AddNameProp(cl, res, name, state); RETURN res END pZMove;
PROCEDURE============================= IntApply ===============================pVideo ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); source := NEW(TextPP, found := TRUE); quality := NEW(CardinalPP, name := "Quality", val := 8); colors := NEW(CardinalPP, name := "Colors", val := 50); width := NEW(CardinalPP, name := "Width", val := 640); height := NEW(CardinalPP, name := "Height", val := 480); synchronous := NEW(BooleanPP, name := "Synchronous"); msecs := NEW(CardinalPP, name := "MSecs"); paused := NEW(BooleanPP, name := "Paused"); fixed := NEW(BooleanPP, name := "FixedSize"); res: FVVideo; BEGIN ParseProps( cl, list, state, PP7{name, source, quality, colors, width, height, msecs}, KP3{synchronous, paused, fixed}, main := source); IF source.val = NIL OR Text.Empty(source.val) THEN RAISE Error("Video: must specify a source host name"); END; IF quality.val < FIRST(JVSink.Quality) OR LAST(JVSink.Quality) < quality.val THEN RAISE Error("Video quality must be between 0 and 15"); END; res := cl.fv.realize("Video", name.valname); res := res.init( source.val, quality.val, colors.val, width.val, height.val, synchronous.val, fixed.val, msecs.val); IF paused.val THEN res.setPaused(TRUE); END; AddNameProp(cl, res, name, state); RETURN res END pVideo; PROCEDUREpAudio ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); source := NEW(TextPP, name := "Value"); volume := NEW(IntegerPP, name := "Volume"); mute := NEW(BooleanPP, name := "Mute"); ignoreMapping := NEW(BooleanPP, name := "IgnoreMapping"); res: FVAudio; BEGIN ParseProps(cl, list, state, PP3{name, source, volume}, KP2{mute, ignoreMapping}); IF source.val = NIL OR Text.Empty(source.val) THEN RAISE Error("Audio: must specify a source host name"); END; IF volume.val < FIRST(Jva.Volume) OR LAST(Jva.Volume) < volume.val THEN RAISE Error(Fmt.F("Audio: value must be in range [%s..%s]", Fmt.Int(FIRST(Jva.Volume)), Fmt.Int(LAST(Jva.Volume)))); END; res := cl.fv.realize("Audio", name.valname); TRY EVAL res.init(OneChild(cl, list, state), source.val, mute.val, ignoreMapping.val, volume.val); EXCEPT | OSError.E (e) => VAR etext := ""; BEGIN IF e # NIL AND e.head # NIL THEN etext := RdUtils.FailureText(e); END; RAISE Error("Audio: initialising " & etext); END; | Thread.Alerted => RAISE Error("Audio: Thread alerted"); END; AddNameProp(cl, res, name, state); RETURN res END pAudio;
PROCEDURE====================================================================== Parsing routines for inherited properties (pIntApply ( cl : ParseClosure; VAR list: RefList.T; READONLY s : State ): VBT.T RAISES {Error} = VAR state := s; name := NamePP(); forName := NEW(SymbolPP, name := "For"); propertyName := NEW(TextPP, name := "Property"); res : FVIntApply; BEGIN ParseProps(cl, list, state, PP3{name, forName, propertyName}); IF forName = NIL OR Text.Empty(forName.valname) THEN RAISE Error("IntApply: must specify (For ...) property"); END; res := cl.fv.realize("IntApply", name.valname); EVAL res.init(cl.fv, OneChild(cl, list, state), forName.valname, propertyName.val); AddNameProp(cl, res, name, state); RETURN res; END pIntApply;
states
)
======================================================================
PROCEDUREFollow the guidelines in Kobara's book on Motif. Nice background colors have RGB components that are each between 155 and 175 on a scale of 0-255. If the color is in that range, then the LightShadow should be computedpMacro (list: RefList.T; VAR state: State) RAISES {Error} = (* (Macro name [BOA] (formals) bq-expr) *) BEGIN WITH m = Macro.Parse (list), pair = AssocQ (state.macros, list.head) DO IF pair # NIL THEN pair.tail.head := m ELSE Push (state.macros, RefList.List2 (list.head, m)) END END END pMacro;
by
multiplying the background color R, G, and B numbers each by 1.50
. Well,
that arithmetic isn't quite right; 175 * 1.50 > 255. So we just scale
linearly so that 175 comes out at 0.95 (not quite hitting white
).
Likewise, the DarkShadow should be computed by multiplying the BgColor
values by 0.5. The values in an RGB will be gamma-corrected
by Trestle, so we use true RGB
values here.
CONST rgb155 = 155.0 / 255.0; rgb175 = 175.0 / 255.0; scaleLight = 0.95 / rgb175; scaleDark = 0.5; PROCEDURE====================================================================== Parsing routines for local properties ======================================================================pBgColor (list: RefList.T; VAR state: State) RAISES {Error} = VAR r := ColorRGB(list, PaintOp.BW.UseBg); red := r.rgb.r; green := r.rgb.g; blue := r.rgb.b; nice := TRUE; BEGIN state.bgRGB := r.rgb; state.bgOp := r.op; nice := nice AND rgb155 <= red AND red <= rgb175; nice := nice AND rgb155 <= green AND green <= rgb175; nice := nice AND rgb155 <= blue AND blue <= rgb175; IF nice THEN state.darkRGB.r := red * scaleDark; state.darkRGB.g := green * scaleDark; state.darkRGB.b := blue * scaleDark; state.lightRGB.r := red * scaleLight; state.lightRGB.g := green * scaleLight; state.lightRGB.b := blue * scaleLight; state.lightOp := PaintOp.FromRGB( state.lightRGB.r, state.lightRGB.g, state.lightRGB.b, PaintOp.Mode.Accurate, -1.0, PaintOp.BW.UseFg); state.darkOp := PaintOp.FromRGB( state.darkRGB.r, state.darkRGB.g, state.darkRGB.b, PaintOp.Mode.Accurate, -1.0, PaintOp.BW.UseFg) END; state.shadow := Shadow.New(state.shadowSz, state.bgOp, state.fgOp, state.lightOp, state.darkOp) END pBgColor; PROCEDUREpColor (list: RefList.T; VAR state: State) RAISES {Error} = BEGIN WITH r = ColorRGB (list) DO state.fgRGB := r.rgb; state.fgOp := r.op END; state.shadow := Shadow.New (state.shadowSz, state.bgOp, state.fgOp, state.lightOp, state.darkOp) END pColor; PROCEDUREpLightShadow (list: RefList.T; VAR state: State) RAISES {Error} = BEGIN WITH r = ColorRGB (list) DO state.lightRGB := r.rgb; state.lightOp := r.op END; state.shadow := Shadow.New (state.shadowSz, state.bgOp, state.fgOp, state.lightOp, state.darkOp) END pLightShadow; PROCEDUREpDarkShadow (list: RefList.T; VAR state: State) RAISES {Error} = BEGIN WITH r = ColorRGB (list) DO state.darkRGB := r.rgb; state.darkOp := r.op END; state.shadow := Shadow.New (state.shadowSz, state.bgOp, state.fgOp, state.lightOp, state.darkOp) END pDarkShadow; EXCEPTION BadColorSpec; (* internal *) TYPE RgbOp = RECORD rgb: Color.T; op: PaintOp.T END; VAR qRGB := Atom.FromText ("RGB"); qHSV := Atom.FromText ("HSV"); PROCEDUREColorRGB (list: RefList.T; bw := PaintOp.BW.UseFg): RgbOp RAISES {Error} = VAR original := list; res : RgbOp; rep := qRGB; vals : ARRAY [0 .. 2] OF REAL; BEGIN TRY IF list = NIL THEN RAISE BadColorSpec END; TYPECASE list.head OF | NULL => RAISE BadColorSpec | TEXT (t) => IF list.tail # NIL THEN RAISE BadColorSpec END; res.rgb := ColorName.ToRGB (t) | REFANY => IF RefList.Length (list) = 4 THEN TYPECASE Pop (list) OF | NULL => RAISE BadColorSpec | Atom.T (s) => IF s = qRGB OR s = qHSV THEN rep := s ELSE RAISE BadColorSpec END ELSE RAISE BadColorSpec END END; IF RefList.Length (list) # 3 THEN RAISE BadColorSpec END; FOR i := 0 TO 2 DO TYPECASE Pop (list) OF | NULL => RAISE BadColorSpec | REF INTEGER (ri) => IF ri^ = 0 THEN vals [i] := 0.0 ELSIF ri^ = 1 THEN vals [i] := 1.0 ELSE RAISE BadColorSpec END | REF REAL (rr) => vals [i] := rr^ ELSE RAISE BadColorSpec END END; IF rep = qHSV THEN res.rgb := Color.FromHSV (Color.HSV {vals [0], vals [1], vals [2]}) ELSE res.rgb := Color.T {vals [0], vals [1], vals [2]}; END; END; res.op := PaintOp.FromRGB (res.rgb.r, res.rgb.g, res.rgb.b, PaintOp.Mode.Accurate, -1.0, bw) EXCEPT | BadColorSpec => Gripe ("Illegal color-spec: ", original); <* ASSERT FALSE *> | ColorName.NotFound => Gripe ("No such color: ", original); <* ASSERT FALSE *> END; RETURN res END ColorRGB; PROCEDUREpFont (list: RefList.T; VAR state: State) RAISES {Error} = BEGIN IF RefList.Length (list) = 1 AND ISTYPE (list.head, TEXT) THEN state.fontName := OneText (list) ELSE state.fontMetrics := ParseFont (list, state.fontMetrics, DefaultFontMetrics); state.fontName := MetricsToName (state.fontMetrics) END; state.font := FVRuntime.FindFont (state.fontName) END pFont; PROCEDUREpLabelFont (list: RefList.T; VAR state: State) RAISES {Error} = BEGIN IF RefList.Length (list) = 1 AND ISTYPE (list.head, TEXT) THEN state.labelFontName := OneText (list) ELSE state.labelFontMetrics := ParseFont (list, state.labelFontMetrics, DefaultLabelFontMetrics); state.labelFontName := MetricsToName (state.labelFontMetrics) END; state.labelFont := FindFont (state.labelFontName) END pLabelFont; PROCEDUREMetricsToName (metrics: RefList.T): TEXT = VAR wr := TextWr.New (); pair: RefList.T; <* FATAL Wr.Failure, Thread.Alerted *> BEGIN FOR i := 0 TO LAST (MetricsProcs) DO Wr.PutChar (wr, '-'); pair := AssocQ (metrics, MetricsProcs [i].symname); IF pair = NIL THEN Wr.PutChar (wr, '*') ELSE Wr.PutText (wr, pair.tail.head) END END; RETURN TextWr.ToText (wr) END MetricsToName; PROCEDUREParseFont (alist, metrics, default: RefList.T): RefList.T RAISES {Error} = VAR n: INTEGER; PROCEDURE gripe (x: REFANY) RAISES {Error} = BEGIN Gripe ("Bad font-spec: ", x) END gripe; BEGIN WHILE alist # NIL DO TYPECASE Pop (alist) OF | NULL => gripe (NIL) | Atom.T (sym) => IF sym = qReset THEN metrics := RefList.Append (default, metrics) ELSE gripe (sym) END | RefList.T (pair) => TYPECASE pair.head OF | NULL => gripe (pair) | Atom.T (sym) => IF MetricsNameTable.get (sym, n) THEN MetricsProcs [n].proc (sym, pair.tail, metrics) ELSE gripe (pair) END | REFANY => gripe (pair) END | REFANY (r) => gripe (r) END END; RETURN metrics END ParseFont; PROCEDUREmText (sym: Atom.T; arglist: RefList.T; VAR metrics: RefList.T) RAISES {Error} = BEGIN Push (metrics, RefList.List2 (sym, OneText (arglist))) END mText; PROCEDUREmCardinal (sym: Atom.T; arglist: RefList.T; VAR metrics: RefList.T) RAISES {Error} = BEGIN IF RefList.Length (arglist) = 1 THEN (* gripe *) TYPECASE arglist.head OF | NULL => (* gripe *) | TEXT (t) => IF Text.Equal (t, "*") THEN Push (metrics, RefList.List2 (sym, t)); RETURN END | REF INTEGER (ri) => IF ri^ >= 0 THEN Push (metrics, RefList.List2 (sym, Fmt.Int (ri^))); RETURN END ELSE (* gripe *) END END; Gripe ("Bad font-spec: ", arglist); <* ASSERT FALSE *> END mCardinal; PROCEDUREpShadowSize (list: RefList.T; VAR state: State) RAISES {Error} = BEGIN state.shadowSz := Pts.ToMM(OneReal (list)); state.shadow := Shadow.New (state.shadowSz, state.bgOp, state.fgOp, state.lightOp, state.darkOp) END pShadowSize;
TYPE PP = OBJECT (* Property pair *) name := "Main"; found := FALSE METHODS set (form: RefList.T) RAISES {Error} END; KP0 = ARRAY [0 .. -1] OF BooleanPP; KP1 = ARRAY [0 .. 0] OF BooleanPP; KP2 = ARRAY [0 .. 1] OF BooleanPP; KP3 = ARRAY [0 .. 2] OF BooleanPP; KP4 = ARRAY [0 .. 3] OF BooleanPP; KP5 = ARRAY [0 .. 4] OF BooleanPP; KP6 = ARRAY [0 .. 5] OF BooleanPP; PP0 = ARRAY [0 .. -1] OF PP; PP1 = ARRAY [0 .. 0] OF PP; PP2 = ARRAY [0 .. 1] OF PP; PP3 = ARRAY [0 .. 2] OF PP; PP4 = ARRAY [0 .. 3] OF PP; PP5 = ARRAY [0 .. 4] OF PP; PP6 = ARRAY [0 .. 5] OF PP; PP7 = ARRAY [0 .. 6] OF PP; EP0 = ARRAY [0 .. -1] OF EnumPP; EP1 = ARRAY [0 .. 0] OF EnumPP; PROCEDUREParseProps ( cl : ParseClosure; VAR list : RefList.T; VAR state: State; READONLY props: ARRAY OF PP := PP0 {}; READONLY keys : ARRAY OF BooleanPP := KP0 {}; main : PP := NIL; READONLY enums: ARRAY OF EnumPP := EP0 {} ) RAISES {Error} = (* This is where we parse the properties in a component-list. We keep scanning items until we reach something that isn't a known property. The component-parser that called us is responsible for parsing all the remaining items on the list. *) VAR copy := list; BEGIN WHILE list # NIL DO copy := list; list := ParseProp (cl, list, state, props, keys, main, enums); IF list = copy THEN EXIT END END; IF main = NIL THEN (* skip *) ELSIF list # NIL THEN main.set (list); list := NIL ELSIF NOT main.found THEN RAISE Error ("Missing Main property") END; (* Make sure they picked one in each enumeration. *) FOR i := FIRST (enums) TO LAST (enums) DO IF enums [i].chosen # -1 THEN (* skip *) ELSIF NOT enums [i].choices [enums [i].default].found THEN enums [i].choices [enums [i].default].val := TRUE; enums [i].chosen := enums [i].default ELSE Gripe ("Default marked #False, but no alternative was selected: ", enums [i].choices [enums [i].default].name); <* ASSERT FALSE *> END END END ParseProps; PROCEDUREParseProp ( cl : ParseClosure; VAR list : RefList.T; VAR state: State; READONLY props: ARRAY OF PP; READONLY keys : ARRAY OF BooleanPP; main : PP; READONLY enums: ARRAY OF EnumPP ): RefList.T RAISES {Error} = VAR sProc: StateProc; symname: TEXT; BEGIN TYPECASE list.head OF | NULL => | Atom.T (sym) => (* Is it a "keyword", like MenuStyle? *) symname := Atom.ToText (sym); FOR i := FIRST (keys) TO LAST (keys) DO IF Text.Equal (symname, keys [i].name) THEN keys [i].val := TRUE; keys [i].found := TRUE; RETURN list.tail END END; (* It might be an enumeration keyword. *) FOR i := FIRST (enums) TO LAST (enums) DO FOR j := FIRST (enums [i].choices^) TO LAST (enums [i].choices^) DO IF Text.Equal (symname, enums [i].choices [j].name) THEN IF enums [i].chosen # -1 THEN Gripe ("Contradictory choices: ", enums [i].choices [j].name & " " & enums [i].choices [enums [i].chosen].name); <* ASSERT FALSE *> ELSE enums [i].choices [j].val := TRUE; enums [i].choices [j].found := TRUE; enums [i].chosen := j; RETURN list.tail END END END END (* If it's not a keyword, it might be a symbol-component (Bar or Fill) *) | RefList.T (form) => TYPECASE Pop (form) OF | NULL => | Atom.T (sym) => (* Is it specific to this component? E.g., (Height ...) *) symname := Atom.ToText (sym); FOR i := FIRST (props) TO LAST (props) DO IF Text.Equal (symname, props [i].name) THEN props [i].set (form); (* parse and set *) props [i].found := TRUE; RETURN list.tail END END; (* Is it a state like (BgColor ...)? *) sProc := FindStateProc (sym); IF sProc # NIL THEN sProc (form, state); RETURN list.tail END; (* Is it a macro? Expand and re-test. *) WITH m = MacroFunction (sym, state) DO IF m # NIL THEN RETURN RefList.Cons (m.apply (form), list.tail) END END; (* Is it a Boolean for this component? E.g., (Flex #True ...) *) FOR i := FIRST (keys) TO LAST (keys) DO IF Text.Equal (symname, keys [i].name) THEN keys [i].val := OneBoolean (form); keys [i].found := TRUE; RETURN list.tail END END; (* Is it an enumeration keyword? *) FOR i := FIRST (enums) TO LAST (enums) DO FOR j := FIRST (enums [i].choices^) TO LAST (enums [i].choices^) DO IF Text.Equal (symname, enums [i].choices [j].name) THEN enums [i].choices [j].found := TRUE; IF OneBoolean (form) THEN IF enums [i].chosen # -1 THEN Gripe ("Contradictory choices: ", enums [i].choices [j].name & " " & enums [i].choices [enums [i].chosen].name); <* ASSERT FALSE *> ELSE enums [i].choices [j].val := TRUE; enums [i].chosen := j; RETURN list.tail END ELSIF enums [i].chosen = j THEN enums [i].choices [j].val := FALSE; enums [i].chosen := -1; RETURN list.tail ELSE RETURN list.tail END END END END; (* Is it (Main ...)? *) IF main # NIL AND sym = qMain THEN main.set (form); main.found := TRUE; RETURN list.tail END; (* Is it Insert? *) IF sym = qInsert THEN RETURN RefList.AppendD ( InsertFile (OneText (form), cl.fv.path, cl.fv.baseURL), list.tail) END (* It must a component like (HBox ...). *) ELSE END ELSE END; RETURN list END ParseProp; TYPE AtSpecPP = PP OBJECT val: RECORD h, v, w, e, n, s := 0.5; loc := ZChildVBT.Location.Center; type := ZChildVBT.CoordType.Scaled; edges := FALSE END OVERRIDES set := SetAtSpecPP END; BooleanPP = PP OBJECT val := FALSE OVERRIDES set := SetBooleanPP END; CardinalPP = PP OBJECT val: CARDINAL := 0 OVERRIDES set := SetCardinalPP END; CardinalListPP = PP OBJECT val: RefList.T := NIL OVERRIDES set := SetCardinalListPP END; ChainsPP = PP OBJECT shaper: ZSplit.ReshapeControl; OVERRIDES set := SetChainsPP END; EnumPP = PP OBJECT choices: REF ARRAY OF BooleanPP; chosen : [-1 .. LAST (CARDINAL)] := -1; default: CARDINAL := 0 METHODS init (READONLY a: ARRAY OF BooleanPP; default: CARDINAL): EnumPP := InitEnumPP END; IntegerPP = PP OBJECT val := 0 OVERRIDES set := SetIntegerPP END; RealPP = PP OBJECT val := 0.0 OVERRIDES set := SetRealPP END; SizeRangePP = PP OBJECT val := FlexVBT.DefaultRange OVERRIDES set := SetSizeRangePP END; SymbolPP = PP OBJECT val : Atom.T := NIL; valname: TEXT := "" OVERRIDES set := SetSymbolPP END; TextPP = PP OBJECT val: TEXT := NIL OVERRIDES set := SetTextPP END; TextListPP = PP OBJECT val: RefList.T := NIL OVERRIDES set := SetTextListPP END; VBTPP = PP OBJECT val: RefList.T := NIL; OVERRIDES set := SetVBTPP END; PROCEDUREInitEnumPP ( pp : EnumPP; READONLY a : ARRAY OF BooleanPP; default: CARDINAL ): EnumPP = BEGIN pp.choices := NEW (REF ARRAY OF BooleanPP, NUMBER (a)); pp.choices^ := a; pp.default := default; RETURN pp END InitEnumPP; PROCEDURESetSymbolPP (pp: SymbolPP; form: RefList.T) RAISES {Error} = BEGIN pp.val := OneSymbol (form); pp.valname := Atom.ToText (pp.val) END SetSymbolPP; PROCEDURESetBooleanPP (pp: BooleanPP; form: RefList.T) RAISES {Error} = BEGIN pp.val := OneBoolean (form) END SetBooleanPP; PROCEDURESetIntegerPP (pp: IntegerPP; form: RefList.T) RAISES {Error} = BEGIN pp.val := OneInteger (form) END SetIntegerPP; PROCEDURESetRealPP (pp: RealPP; form: RefList.T) RAISES {Error} = BEGIN pp.val := OneReal (form) END SetRealPP; PROCEDURESetCardinalPP (pp: CardinalPP; form: RefList.T) RAISES {Error} = BEGIN pp.val := OneCardinal (form) END SetCardinalPP; PROCEDURESetCardinalListPP (pp: CardinalListPP; form: RefList.T) RAISES {Error} = PROCEDURE cardinalp (ref: REFANY): BOOLEAN = BEGIN TYPECASE ref OF | NULL => RETURN FALSE | REF INTEGER (ri) => RETURN ri^ >= 0 ELSE RETURN FALSE END END cardinalp; BEGIN pp.val := ListOfType (form, cardinalp, "cardinals ") END SetCardinalListPP; PROCEDURESetTextListPP (pp: TextListPP; form: RefList.T) RAISES {Error} = PROCEDURE textp (ref: REFANY): BOOLEAN = BEGIN RETURN ISTYPE (ref, TEXT) END textp; BEGIN pp.val := ListOfType (form, textp, "texts ") END SetTextListPP; PROCEDUREListOfType (form: RefList.T; p : (PROCEDURE (ref: REFANY): BOOLEAN); name: TEXT ): RefList.T RAISES {Error} = PROCEDURE every (l: RefList.T): BOOLEAN = BEGIN WHILE l # NIL DO IF NOT p (Pop (l)) THEN RETURN FALSE END END; RETURN TRUE END every; BEGIN (** Allow form to be (1 2 3 ...) or ((1 2 3 ...)), since =(1 2 3) is read as (Value (1 2 3)), which is the same as (Value 1 2 3). *) IF every (form) THEN RETURN form END; TYPECASE form.head OF | RefList.T (l) => IF form.tail = NIL AND every (l) THEN RETURN l END ELSE END; Gripe ("Bad list of " & name, form); <* ASSERT FALSE *> END ListOfType; EXCEPTION BadAtSpec; PROCEDURESetAtSpecPP (pp: AtSpecPP; form: RefList.T) RAISES {Error} = VAR n : ARRAY [0 .. 1] OF REAL; original := form; len := RefList.Length (form); gotCoordType := FALSE; PROCEDURE pct (x: REAL) RAISES {BadAtSpec} = BEGIN IF x < 0.0 OR 1.0 < x THEN RAISE BadAtSpec END END pct; PROCEDURE ispct (x: REAL): BOOLEAN = BEGIN RETURN x >= 0.0 AND x <= 1.0 END ispct; PROCEDURE check () RAISES {BadAtSpec} = BEGIN IF form # NIL THEN RAISE BadAtSpec END; IF NOT gotCoordType THEN pp.val.type := ZChildVBT.CoordType.Absolute; IF pp.val.edges THEN IF ispct(pp.val.w) AND ispct(pp.val.e) AND ispct(pp.val.n) AND ispct(pp.val.s) THEN pp.val.type := ZChildVBT.CoordType.Scaled END ELSE IF ispct(pp.val.h) AND ispct(pp.val.v) THEN pp.val.type := ZChildVBT.CoordType.Scaled END END END; IF pp.val.type = ZChildVBT.CoordType.Absolute THEN IF pp.val.edges THEN pp.val.w := Pts.ToMM (pp.val.w); pp.val.e := Pts.ToMM (pp.val.e); pp.val.n := Pts.ToMM (pp.val.n); pp.val.s := Pts.ToMM (pp.val.s) ELSE pp.val.h := Pts.ToMM (pp.val.h); pp.val.v := Pts.ToMM (pp.val.v) END ELSE IF pp.val.edges THEN pct (pp.val.w); pct (pp.val.e); pct (pp.val.n); pct (pp.val.s) ELSE pct (pp.val.h); pct (pp.val.v) END END END check; BEGIN TRY pp.val.type := ZChildVBT.CoordType.Absolute; IF len < 2 OR len > 5 THEN RAISE BadAtSpec END; FOR i := 0 TO 1 DO TYPECASE Pop (form) OF | NULL => RAISE BadAtSpec | REF INTEGER (ri) => n [i] := FLOAT (ri^) | REF REAL (rr) => n [i] := rr^ ELSE RAISE BadAtSpec END END; pp.val.h := n [0]; pp.val.v := n [1]; IF form = NIL THEN check (); RETURN END; TYPECASE Pop (form) OF | NULL => RAISE BadAtSpec | Atom.T (s) => IF GetLocation (s, pp.val.loc) THEN IF form # NIL THEN IF GetCoordType (Pop (form), pp.val.type) THEN gotCoordType := TRUE ELSE RAISE BadAtSpec END END ELSIF GetCoordType (s, pp.val.type) THEN gotCoordType := TRUE ELSE RAISE BadAtSpec END; check (); RETURN | REF INTEGER (ri) => pp.val.n := FLOAT (ri^) | REF REAL (rr) => pp.val.n := rr^ ELSE RAISE BadAtSpec END; IF form = NIL THEN RAISE BadAtSpec END; pp.val.edges := TRUE; pp.val.w := n [0]; pp.val.e := n [1]; TYPECASE Pop (form) OF | NULL => RAISE BadAtSpec | REF INTEGER (ri) => pp.val.s := FLOAT (ri^) | REF REAL (rr) => pp.val.s := rr^ ELSE RAISE BadAtSpec END; IF form # NIL THEN IF GetCoordType (Pop (form), pp.val.type) THEN gotCoordType := TRUE ELSE RAISE BadAtSpec END; END; check () EXCEPT | BadAtSpec => Gripe ("Bad 'At' spec: ", original); <* ASSERT FALSE *> END END SetAtSpecPP; VAR Locations := ARRAY ZChildVBT.Location OF Atom.T {Atom.FromText ("NW"), Atom.FromText ("NE"), Atom.FromText ("SW"), Atom.FromText ("SE"), Atom.FromText ("Center")}; PROCEDUREGetLocation (s: Atom.T; VAR loc: ZChildVBT.Location): BOOLEAN = BEGIN FOR i := FIRST (Locations) TO LAST (Locations) DO IF s = Locations [i] THEN loc := i; RETURN TRUE END END; RETURN FALSE END GetLocation; VAR CoordTypes := ARRAY ZChildVBT.CoordType OF Atom.T { Atom.FromText ("Absolute"), Atom.FromText ("Relative")}; PROCEDUREGetCoordType (x: REFANY; VAR type: ZChildVBT.CoordType): BOOLEAN = BEGIN TYPECASE x OF | NULL => | Atom.T (s) => FOR i := FIRST (CoordTypes) TO LAST (CoordTypes) DO IF s = CoordTypes [i] THEN type := i; RETURN TRUE END END ELSE END; RETURN FALSE END GetCoordType; PROCEDURESetChainsPP (pp: ChainsPP; form: RefList.T) RAISES {Error} = BEGIN pp.shaper := NEW(ZSplit.ChainReshapeControl, chains := ChainSet (form)); END SetChainsPP; PROCEDUREChainSet (VAR list: RefList.T): ZSplit.ChainSet RAISES {Error} = VAR chain: ZSplit.Ch; chainSet := ZSplit.ChainSet{}; BEGIN WHILE RefList.Length (list) # 0 DO IF GetChain (Pop(list), chain) THEN chainSet := chainSet + ZSplit.ChainSet{chain}; ELSE Gripe ("Unknown side for chaining", list) END END; RETURN chainSet END ChainSet; VAR Chains := ARRAY ZSplit.Ch OF Atom.T {Atom.FromText ("W"), Atom.FromText ("E"), Atom.FromText ("N"), Atom.FromText ("S")}; PROCEDUREGetChain (s: Atom.T; VAR ch: ZSplit.Ch): BOOLEAN = BEGIN FOR i := FIRST (Chains) TO LAST (Chains) DO IF s = Chains [i] THEN ch := i; RETURN TRUE END END; RETURN FALSE END GetChain; PROCEDURESetSizeRangePP (pp: SizeRangePP; form: RefList.T) RAISES {Error} = BEGIN pp.val := SizeRange (form) END SetSizeRangePP; EXCEPTION BadSize; PROCEDURESizeRange (VAR list: RefList.T): FlexVBT.SizeRange RAISES {Error} = VAR size := FlexVBT.DefaultRange; original := list; BEGIN TRY IF list = NIL THEN RAISE BadSize END; GetNatural (list, size); IF RefList.Length (list) = 4 THEN GetStretchOrShrink (list, size); END; IF RefList.Length (list) = 2 THEN GetStretchOrShrink (list, size); END; IF RefList.Length (list) # 0 THEN RAISE BadSize END; RETURN size; EXCEPT | BadSize => Gripe ("Illegal size", original); <* ASSERT FALSE *> END; END SizeRange; PROCEDUREGetNatural (VAR list: RefList.T; VAR size: FlexVBT.SizeRange) RAISES {BadSize} = BEGIN TYPECASE list.head OF | NULL => RAISE BadSize | REF REAL, REF INTEGER => size.natural := Pts.ToMM(GetNum(list)); ELSE (* no leading number *) END; END GetNatural; PROCEDUREGetStretchOrShrink (VAR list: RefList.T; VAR size: FlexVBT.SizeRange) RAISES {BadSize} = BEGIN TYPECASE Pop(list) OF | NULL => RAISE BadSize | Atom.T (sym) => IF sym = qPlus THEN size.stretch := Pts.ToMM(GetNum(list, TRUE)); ELSIF sym = qMinus THEN size.shrink := Pts.ToMM(GetNum(list, TRUE)); ELSE RAISE BadSize END ELSE RAISE BadSize END END GetStretchOrShrink; VAR Infinities := ARRAY [0 .. 5] OF Atom.T { Atom.FromText ("Inf"), Atom.FromText ("inf"), Atom.FromText ("INF"), Atom.FromText ("Infinity"), Atom.FromText ("infinity"), Atom.FromText ("INFINITY")}; PROCEDUREGetNum (VAR list : RefList.T; infOK : BOOLEAN := FALSE; positiveOnly: BOOLEAN := TRUE ): REAL RAISES {BadSize} = BEGIN TYPECASE Pop(list) OF | NULL => | REF REAL (rr) => IF positiveOnly AND rr^ < 0.0 THEN RAISE BadSize END; RETURN rr^ | REF INTEGER (ri) => IF positiveOnly AND ri^ < 0 THEN RAISE BadSize END; RETURN FLOAT(ri^) | Atom.T (sym) => IF NOT infOK THEN RAISE BadSize END; FOR i := FIRST(Infinities) TO LAST(Infinities) DO IF sym = Infinities[i] THEN RETURN FlexVBT.Infinity END END ELSE END; RAISE BadSize END GetNum; PROCEDURESetVBTPP (pp: VBTPP; form: RefList.T) = BEGIN pp.val := form END SetVBTPP;
VAR state := pp.state; name := NamePP (); BEGIN ParseProps (form, state, PP1 {name}); pp.val := OneChild (pp.cl, form, state); AddNameProp (pp.cl, pp.val, name, state) END SetVBTPP;
PROCEDURE====================== Runtime Utilities =========================OneChild ( cl : ParseClosure; list : RefList.T; READONLY state: State ): VBT.T RAISES {Error} = BEGIN IF list = NIL THEN Gripe("A component is required here", ""); <* ASSERT FALSE *> ELSIF list.tail # NIL THEN Gripe(Fmt.F("A single component is required here: %s", ToText(list, maxDepth := 3, maxLength := 4))); <* ASSERT FALSE *> ELSE RETURN Item(cl, Pop(list), state) END END OneChild; PROCEDURESetTextPP (pp: TextPP; form: RefList.T) RAISES {Error} = BEGIN pp.val := OneText (form) END SetTextPP; PROCEDUREAddChildren ( cl : ParseClosure; v : MultiSplit.T; list : RefList.T; READONLY state: State ) RAISES {Error} = BEGIN WHILE list # NIL DO TYPECASE Pop(list) OF | NULL => Gripe("NIL is an illegal form"); <* ASSERT FALSE *> | RefList.T (a) => TYPECASE a.head OF | NULL => Gripe("(NIL ...) is an illegal form"); <* ASSERT FALSE *> | Atom.T (sym) => IF sym = qInsert THEN list := RefList.Append(InsertFile( OneText(a.tail), cl.fv.path, cl.fv.baseURL), list) ELSE MultiSplit.AddChild(v, Item(cl, a, state)) END ELSE MultiSplit.AddChild(v, Item(cl, a, state)) END | REFANY (ra) => MultiSplit.AddChild(v, Item(cl, ra, state)) END END END AddChildren; PROCEDUREOneText (list: RefList.T): TEXT RAISES {Error} = BEGIN IF list # NIL THEN TYPECASE list.head OF | NULL => (* Technically, this is illegal, but the FormsVBT prettyprinter in Ivy converts "" to (), and there's still some of that code around. *) IF list.tail = NIL THEN RETURN "" END | TEXT (t) => IF list.tail = NIL THEN RETURN t END ELSE END END; Gripe ("Bad text-form: ", list); <* ASSERT FALSE *> END OneText; PROCEDUREOneCardinal (list: RefList.T): CARDINAL RAISES {Error} = BEGIN IF list # NIL THEN TYPECASE list.head OF | NULL => | REF INTEGER (ri) => IF ri^ >= 0 AND list.tail = NIL THEN RETURN ri^ END ELSE END END; Gripe ("Expected a cardinal integer: ", list); <* ASSERT FALSE *> END OneCardinal; PROCEDUREOneInteger (list: RefList.T): INTEGER RAISES {Error} = BEGIN IF list # NIL THEN TYPECASE list.head OF | NULL => | REF INTEGER (ri) => IF list.tail = NIL THEN RETURN ri^ END ELSE END END; Gripe ("Expected an integer: ", list); <* ASSERT FALSE *> END OneInteger; PROCEDUREOneReal (list: RefList.T): REAL RAISES {Error} = BEGIN IF list # NIL THEN TYPECASE list.head OF | NULL => | REF INTEGER (ri) => IF list.tail = NIL THEN RETURN FLOAT (ri^) END | REF REAL (rr) => IF list.tail = NIL THEN RETURN rr^ END ELSE END END; Gripe ("Expected a real number: ", list); <* ASSERT FALSE *> END OneReal; PROCEDUREOneBoolean (form: RefList.T): BOOLEAN RAISES {Error} = BEGIN IF form # NIL AND form.tail = NIL THEN TYPECASE form.head OF | NULL => | Atom.T (sym) => IF sym = Sx.True THEN RETURN TRUE ELSIF sym = Sx.False THEN RETURN FALSE END ELSE END END; Gripe ("Not a BOOLEAN: ", form); <* ASSERT FALSE *> END OneBoolean; PROCEDUREOneSymbol (form: RefList.T): Atom.T RAISES {Error} = BEGIN IF form # NIL AND form.tail = NIL THEN TYPECASE form.head OF | NULL => | Atom.T (sym) => RETURN sym ELSE END END; Gripe ("Not a symbol: ", form); <* ASSERT FALSE *> END OneSymbol; PROCEDUREAssertEmpty (list: RefList.T) RAISES {Error} = BEGIN IF list # NIL THEN Gripe ("Extra junk in form: ", list) END END AssertEmpty;
PROCEDURE========================== Table Lookup ===========================AddNameProp ( cl : ParseClosure; v : VBT.T; pp : SymbolPP; READONLY state: State ) RAISES {Error} = VAR stateRef: REF State; BEGIN IF Named (pp) THEN FVRuntime.SetVBT (cl.fv, pp.valname, v); stateRef := NEW (REF State); stateRef^ := state; stateRef^.name := pp.valname; VBT.PutProp (v, stateRef); END END AddNameProp; PROCEDUREAddForProp (cl: ParseClosure; v: VBT.T; pp: SymbolPP) RAISES {Error} = BEGIN IF pp.val = NIL THEN RAISE Error ("A name is required here.") END; cl.fixupList := NEW (FixupLink, targetName := pp.valname, sourceVBT := v, next := cl.fixupList) END AddForProp;
PROCEDURENOTE: FVTypes contains type declarations corresponding to each component. When a new component is added, be sure to add an entry to Also, if the VBT class for a component changes (unlikely, but possible), be sure to modify the component's entry in FVTypes appropriately.FindComponentProc (sym: Atom.T): ComponentProc = VAR n: INTEGER; BEGIN IF ComponentNameTable.get (sym, n) THEN RETURN ComponentProcs [n] ELSE RETURN NIL END END FindComponentProc; PROCEDUREFindRealizeProc (sym: Atom.T): RealizeProc RAISES {Error} = VAR n: INTEGER; BEGIN IF ComponentNameTable.get (sym, n) THEN RETURN RealizeProcs [n] ELSE Gripe ("Unknown component: ", sym); <* ASSERT FALSE *> END END FindRealizeProc; PROCEDUREFindStateProc (sym: Atom.T): StateProc = VAR n: INTEGER; BEGIN IF StateNameTable.get (sym, n) THEN RETURN StateProcs [n] ELSE RETURN NIL END END FindStateProc; CONST StateNames = ARRAY OF TEXT {"BgColor", "Color", "DarkShadow", "Font", "LabelFont", "LightShadow", "Macro", "ShadowSize"}; CONST StateProcs = ARRAY [0 .. LAST (StateNames)] OF StateProc {pBgColor, pColor, pDarkShadow, pFont, pLabelFont, pLightShadow, pMacro, pShadowSize};
CONST ComponentNames = ARRAY OF TEXT{ "Any", "AnyFilter", "AnySplit", "Audio", "Bar", "Boolean", "Border", "Browser", "Button", "Chisel", "Choice", "CloseButton", "DirMenu", "FileBrowser", "Fill", "Filter", "Frame", "Generic", "Glue", "Guard", "HBox", "HPackSplit", "HTile", "Help", "Helper", "Image", "IntApply", "LinkButton", "LinkMButton", "MButton", "Menu", "MultiBrowser", "Numeric", "PageButton", "PageMButton", "Pixmap", "PopButton", "PopMButton", "Radio", "Ridge", "Rim", "Scale", "Scroller", "Shape", "Source", "Stable", "TSplit", "Target", "Text", "TextEdit", "Texture", "TrillButton", "TypeIn", "Typescript", "VBox", "VPackSplit", "VTile", "Video", "Viewport", "ZBackground", "ZChassis", "ZChild", "ZGrow", "ZMove", "ZSplit"}; CONST ComponentProcs = ARRAY [0 .. LAST(ComponentNames)] OF ComponentProc{ pAny, pAnyFilter, pAnySplit, pAudio, pBar, pBoolean, pBorder, pBrowser, pButton, pChisel, pChoice, pCloseButton, pDirMenu, pFileBrowser, pFill, pFilter, pFrame, pGeneric, pGlue, pGuard, pHBox, pHPackSplit, pHTile, pHelp, pHelper, pImage, pIntApply, pLinkButton, pLinkMButton, pMButton, pMenu, pMultiBrowser, pNumeric, pPageButton, pPageMButton, pPixmap, pPopButton, pPopMButton, pRadio, pRidge, pRim, pScale, pScroller, pShape, pSource, pStable, pTSplit, pTarget, pText, pTextEdit, pTexture, pTrillButton, pTypeIn, pTypescript, pVBox, pVPackSplit, pVTile, pVideo, pViewport, pZBackground, pZChassis, pZChild, pZGrow, pZMove, pZSplit}; CONST RealizeProcs = ARRAY [0 .. LAST(ComponentNames)] OF RealizeProc{ rAny, rAnyFilter, rAnySplit, rAudio, rBar, rBoolean, rBorder, rBrowser, rButton, rChisel, rChoice, rCloseButton, rDirMenu, rFileBrowser, rFill, rFilter, rFrame, rGeneric, rGlue, rGuard, rHBox, rHPackSplit, rHTile, rHelp, rHelper, rImage, rIntApply, rLinkButton, rLinkMButton, rMButton, rMenu, rMultiBrowser, rNumeric, rPageButton, rPageMButton, rPixmap, rPopButton, rPopMButton, rRadio, rRidge, rRim, rScale, rScroller, rShape, rSource, rStable, rTSplit, rTarget, rText, rTextEdit, rTexture, rTrillButton, rTypeIn, rTypescript, rVBox, rVPackSplit, rVTile, rVideo, rViewport, rZBackground, rZChassis, rZChild, rZGrow, rZMove, rZSplit}; TYPE mp = RECORD name : TEXT; proc : MetricsProc; fontDefault, labelFontDefault: TEXT; symname : Atom.T END;In the following table, we use
impossible
names to prevent the client
from specifying AdStyle and PixelSize, so these will always be *
in
the font name.
VAR MetricsProcs := ARRAY [0 .. 13] OF mp {mp {"Foundry", mText, "*", "*", NIL}, mp {"Family", mText, "fixed", "helvetica", NIL}, mp {"WeightName", mText, "medium", "bold", NIL}, mp {"Slant", mText, "r", "r", NIL}, mp {"Width", mText, "semicondensed", "*", NIL}, mp {" -AdStyle- ", mText, "*", "*", NIL}, mp {" -PixelSize- ", mCardinal, "*", "*", NIL}, mp {"PointSize", mCardinal, "100", "100", NIL}, mp {"HRes", mCardinal, "*", "*", NIL}, mp {"VRes", mCardinal, "*", "*", NIL}, mp {"Spacing", mText, "*", "*", NIL}, mp {"AvgWidth", mCardinal, "*", "*", NIL}, mp {"Registry", mText, "iso8859", "iso8859", NIL}, mp {"Encoding", mText, "1", "1", NIL}};
The 14 metrics-components must be in this order, so that we can generate
the strings easily. I have no idea what AdStyle
is.
VAR StateNameTable, ComponentNameTable, MetricsNameTable: AtomIntTbl.T; PROCEDUREInitParser () = BEGIN StateNameTable := NEW (AtomIntTbl.Default).init (NUMBER (StateNames)); ComponentNameTable := NEW (AtomIntTbl.Default).init (NUMBER (ComponentNames)); MetricsNameTable := NEW (AtomIntTbl.Default).init (NUMBER (MetricsProcs)); FOR i := FIRST (StateNames) TO LAST (StateNames) DO EVAL StateNameTable.put (Atom.FromText (StateNames [i]), i) END; FOR i := FIRST (ComponentNames) TO LAST (ComponentNames) DO EVAL ComponentNameTable.put (Atom.FromText (ComponentNames [i]), i) END; FOR i := FIRST (MetricsProcs) TO LAST (MetricsProcs) DO WITH s = Atom.FromText (MetricsProcs [i].name) DO EVAL MetricsNameTable.put (s, i); MetricsProcs [i].symname := s END END; DefaultFontMetrics := NIL; DefaultLabelFontMetrics := NIL; FOR i := 0 TO 13 DO WITH mp = MetricsProcs [i] DO Push (DefaultFontMetrics, RefList.List2 (mp.symname, mp.fontDefault)); Push (DefaultLabelFontMetrics, RefList.List2 (mp.symname, mp.labelFontDefault)) END END END InitParser; BEGIN END FormsVBT.