diff --git a/library/collections/namespaces.factor b/library/collections/namespaces.factor index fd6b724e4d..e359c7246f 100644 --- a/library/collections/namespaces.factor +++ b/library/collections/namespaces.factor @@ -2,7 +2,7 @@ ! See http://factor.sf.net/license.txt for BSD license. IN: namespaces USING: hashtables kernel kernel-internals lists math sequences -strings vectors ; +strings vectors words ; ! Variables in Factor: ! @@ -117,7 +117,7 @@ SYMBOL: building : literal, ( word -- ) #! Append some code that pushes the word on the stack. Used #! when building quotations. - unit , \ car , ; + literalize % ; : unique, ( obj -- ) #! Add the object to the sequence being built with make-seq diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index 2f355de4bc..335ab445ef 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -73,11 +73,7 @@ BUILTIN: f 9 not ; : \ #! Parsed as a piece of code that pushes a word on the stack #! \ foo ==> [ foo ] car - scan-word dup word? [ - unit swons \ car swons - ] [ - swons - ] ifte ; parsing + scan-word literalize [ swons ] each ; parsing ! Vocabularies : PRIMITIVE: diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index cb7220b4e4..396b52924c 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -12,25 +12,14 @@ SYMBOL: recursion-check GENERIC: prettyprint* ( indent obj -- indent ) -M: object prettyprint* ( indent obj -- indent ) +: unparse. ( obj -- ) dup unparse swap presented swons unit write-attr ; -: word-attrs ( word -- style ) - #! Return the style values for the HTML word browser - [ - presented over cons , - dup word-vocabulary [ - "word" over word-name cons , - "vocab" swap word-vocabulary cons , - ] [ - drop - ] ifte - ] make-list ; - -: word. ( word -- ) dup word-name swap word-attrs write-attr ; +M: object prettyprint* ( indent obj -- indent ) + unparse. ; M: word prettyprint* ( indent word -- indent ) - dup parsing? [ \ POSTPONE: word. bl ] when word. ; + dup parsing? [ \ POSTPONE: unparse. bl ] when unparse. ; : indent ( indent -- ) #! Print the given number of spaces. @@ -54,8 +43,8 @@ M: word prettyprint* ( indent word -- indent ) : prettyprint-elements ( indent list -- indent ) [ dup \? [ - \ \ word. bl - uncons >r car word. bl + \ \ unparse. bl + uncons >r car unparse. bl r> cdr prettyprint-elements ] [ uncons >r prettyprint* bl @@ -96,11 +85,11 @@ M: word prettyprint* ( indent word -- indent ) #! or { }, or << >>. The body of the list is indented, #! unless the list is empty. over [ - >r >r word. r >r unparse. prettyprint-elements - prettyprint> r> word. + prettyprint> r> unparse. ] [ - >r >r word. bl r> drop r> word. + >r >r unparse. bl r> drop r> unparse. ] ifte ; M: list prettyprint* ( indent list -- indent ) @@ -130,16 +119,16 @@ M: tuple prettyprint* ( indent tuple -- indent ) ] check-recursion ; M: alien prettyprint* ( alien -- str ) - \ ALIEN: word. bl alien-address unparse write ; + \ ALIEN: unparse. bl alien-address unparse write ; : matrix-rows. ( indent list -- indent ) uncons >r [ one-line on prettyprint* ] with-scope r> [ over ?prettyprint-newline matrix-rows. ] when* ; M: matrix prettyprint* ( indent obj -- indent ) - \ M[ word. bl >r 3 + r> + \ M[ unparse. bl >r 3 + r> row-list matrix-rows. - bl \ ]M word. 3 - ; + bl \ ]M unparse. 3 - ; : prettyprint ( obj -- ) [ @@ -147,9 +136,6 @@ M: matrix prettyprint* ( indent obj -- indent ) 0 swap prettyprint* drop terpri ] with-scope ; -: vocab-link ( vocab -- link ) - "vocabularies'" swap append ; - : . ( obj -- ) [ one-line on diff --git a/library/syntax/see.factor b/library/syntax/see.factor index 52f9a9474f..63b18999bf 100644 --- a/library/syntax/see.factor +++ b/library/syntax/see.factor @@ -20,11 +20,11 @@ streams strings styles unparser words ; : vocab. ( vocab -- ) dup vocab-attrs write-attr ; : prettyprint-IN: ( word -- ) - \ IN: word. bl word-vocabulary vocab. terpri ; + \ IN: unparse. bl word-vocabulary vocab. terpri ; : prettyprint-prop ( word prop -- ) tuck word-name word-prop [ - bl word. + bl unparse. ] [ drop ] ifte ; @@ -72,23 +72,23 @@ streams strings styles unparser words ; ] each ] when* ; -: definer. ( word -- ) dup definer word. bl word. bl ; +: definer. ( word -- ) dup definer unparse. bl unparse. bl ; GENERIC: (see) ( word -- ) M: compound (see) ( word -- ) tab-size get dup indent swap [ documentation. ] keep - [ word-def prettyprint-elements \ ; word. ] keep + [ word-def prettyprint-elements \ ; unparse. ] keep prettyprint-plist terpri drop ; : prettyprint-M: ( -- indent ) - \ M: word. bl tab-size get ; + \ M: unparse. bl tab-size get ; -: prettyprint-; \ ; word. terpri ; +: prettyprint-; \ ; unparse. terpri ; : method. ( word [[ class method ]] -- ) - uncons >r >r >r prettyprint-M: r> r> word. bl word. bl + uncons >r >r >r prettyprint-M: r> r> unparse. bl unparse. bl dup prettyprint-newline r> prettyprint-elements prettyprint-; drop ; @@ -99,7 +99,7 @@ M: generic (see) ( word -- ) over "dispatcher" word-prop prettyprint* bl ] with-scope drop - \ ; word. terpri + \ ; unparse. terpri dup methods [ method. ] each-with ; M: word (see) drop ; @@ -107,34 +107,34 @@ M: word (see) drop ; GENERIC: class. M: union class. - \ UNION: word. bl - dup word. bl + \ UNION: unparse. bl + dup unparse. bl 0 swap "members" word-prop prettyprint-elements drop prettyprint-; ; M: complement class. - \ COMPLEMENT: word. bl - dup word. bl - "complement" word-prop word. terpri ; + \ COMPLEMENT: unparse. bl + dup unparse. bl + "complement" word-prop unparse. terpri ; M: builtin class. - \ BUILTIN: word. bl - dup word. bl + \ BUILTIN: unparse. bl + dup unparse. bl dup "builtin-type" word-prop unparse write bl 0 swap "slots" word-prop prettyprint-elements drop prettyprint-; ; M: predicate class. - \ PREDICATE: word. bl - dup "superclass" word-prop word. bl - dup word. bl + \ PREDICATE: unparse. bl + dup "superclass" word-prop unparse. bl + dup unparse. bl tab-size get dup prettyprint-newline swap "definition" word-prop prettyprint-elements drop prettyprint-; ; M: tuple-class class. - \ TUPLE: word. bl - dup word. bl + \ TUPLE: unparse. bl + dup unparse. bl "slot-names" word-prop [ write bl ] each prettyprint-; ; diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 705d9f70c6..70519589cf 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -17,8 +17,8 @@ vectors words ; : type-check-error. ( list -- ) "Type check error" print uncons car dup "Object: " write . - "Object type: " write class word. terpri - "Expected type: " write builtin-type word. terpri ; + "Object type: " write class unparse. terpri + "Expected type: " write builtin-type unparse. terpri ; : float-format-error. ( list -- ) "Invalid floating point literal format: " write . ; @@ -86,9 +86,9 @@ M: object error. ( error -- ) . ; : :get ( var -- value ) "error-namestack" get (get) ; : debug-help ( -- ) - [ :s :r :n :c ] [ word. bl ] each + [ :s :r :n :c ] [ unparse. bl ] each "show stacks at time of error." print - \ :get word. + \ :get unparse. " ( var -- value ) inspects the error namestack." print ; : flush-error-handler ( error -- ) diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor index 1a6994a0cd..d0ba46eb8a 100644 --- a/library/tools/inspector.factor +++ b/library/tools/inspector.factor @@ -48,19 +48,13 @@ M: hashtable sheet hash>alist unzip 2list ; seq-transpose [ " | " join ] map ; -: a/an ( noun -- str ) - first "aeiouAEIOU" contains? "an " "a " ? ; - -: a/an. ( noun -- ) - dup a/an write write ; - : interned? ( word -- ? ) dup word-name swap word-vocabulary vocab hash ; : class-banner ( word -- ) dup metaclass dup [ "This is a class whose behavior is specifed by the " write - unparse write " metaclass," print + unparse. " metaclass," print "currently having " write "predicate" word-prop instances length unparse write " instances." print @@ -91,9 +85,9 @@ M: object extra-banner ( obj -- ) drop ; : inspect-banner ( obj -- ) dup references length >r - "You are looking at " write dup class unparse a/an. - " object with the following printed representation:" print - " " write dup unparse print + "You are looking at an instance of the " write dup class unparse. + " class:" print + " " write dup unparse. terpri "The object has been placed in the inspecting variable." print "It is located at address " write dup address >hex write " and takes up " write dup size unparse write diff --git a/library/tools/walker.factor b/library/tools/walker.factor index 4d925502cd..9aa414aec8 100644 --- a/library/tools/walker.factor +++ b/library/tools/walker.factor @@ -50,14 +50,14 @@ sequences io strings vectors words ; set-callstack call ; : walk-banner ( -- ) - [ &s &r &n &c ] [ word. bl ] each + [ &s &r &n &c ] [ unparse. bl ] each "show stepper stacks." print - \ &get word. + \ &get unparse. " ( var -- value ) inspects the stepper namestack." print - \ step word. " -- single step over" print - \ into word. " -- single step into" print - \ continue word. " -- continue execution" print - \ bye word. " -- exit single-stepper" print + \ step unparse. " -- single step over" print + \ into unparse. " -- single step into" print + \ continue unparse. " -- continue execution" print + \ bye unparse. " -- exit single-stepper" print report ; : walk-listener walk-banner "walk " listener-prompt set listener ; diff --git a/library/ui/hand.factor b/library/ui/hand.factor index 033dbc5a29..33c979de0c 100644 --- a/library/ui/hand.factor +++ b/library/ui/hand.factor @@ -42,6 +42,8 @@ C: hand ( world -- hand ) [ set-gadget-parent ] 2keep [ set-hand-gadget ] keep ; +: hand world get world-hand ; + : button/ ( n hand -- ) dup hand-gadget over set-hand-clicked dup screen-loc over set-hand-click-loc diff --git a/library/ui/init-world.factor b/library/ui/init-world.factor index 61bf0d0a1d..cca0fadff7 100644 --- a/library/ui/init-world.factor +++ b/library/ui/init-world.factor @@ -5,9 +5,6 @@ USING: generic io kernel listener math namespaces styles threads ; SYMBOL: stack-display -: - ; - : init-world global [ world set diff --git a/library/ui/load.factor b/library/ui/load.factor index 913da986a6..1971521e0f 100644 --- a/library/ui/load.factor +++ b/library/ui/load.factor @@ -7,11 +7,11 @@ USING: kernel parser sequences io ; "/library/ui/fonts.factor" "/library/ui/text.factor" "/library/ui/gestures.factor" - "/library/ui/hand.factor" "/library/ui/layouts.factor" "/library/ui/borders.factor" "/library/ui/frames.factor" "/library/ui/world.factor" + "/library/ui/hand.factor" "/library/ui/labels.factor" "/library/ui/buttons.factor" "/library/ui/line-editor.factor" @@ -20,9 +20,9 @@ USING: kernel parser sequences io ; "/library/ui/editors.factor" "/library/ui/menus.factor" "/library/ui/splitters.factor" - "/library/ui/presentations.factor" "/library/ui/incremental.factor" "/library/ui/panes.factor" + "/library/ui/presentations.factor" "/library/ui/init-world.factor" "/library/ui/ui.factor" ] [ diff --git a/library/ui/panes.factor b/library/ui/panes.factor index fecbee8ff8..587b07a355 100644 --- a/library/ui/panes.factor +++ b/library/ui/panes.factor @@ -4,6 +4,8 @@ IN: gadgets USING: generic hashtables io kernel line-editor listener lists math namespaces prettyprint sequences strings styles threads ; +DEFER: + ! A pane is an area that can display text. ! output: pile @@ -62,7 +64,7 @@ M: pane focusable-child* ( pane -- editor ) pane-input ; : pane-write-1 ( style text pane -- ) - [ ] keep pane-current add-gadget ; + >r r> pane-current add-gadget ; : pane-terpri ( pane -- ) dup pane-current over pane-output add-incremental diff --git a/library/ui/presentations.factor b/library/ui/presentations.factor index 30de321d80..364538ac19 100644 --- a/library/ui/presentations.factor +++ b/library/ui/presentations.factor @@ -11,39 +11,36 @@ global [ 100 commands set ] bind : define-command ( class name quot -- ) 3list commands get push ; -: applicable ( object -- ) - commands get >list - [ car call ] subset-with ; +: applicable ( object -- list ) + commands get >list [ car call ] subset-with ; -DEFER: pane-call +: command-quot ( presented quot -- quot ) + [ swap literal, % ] make-list + [ pane get pane-call drop ] cons ; -: command-menu ( pane -- menu ) - presented get dup applicable [ - 3dup third [ - [ swap literal, % ] make-list , , - [ pane-call drop ] % - ] make-list >r second r> cons - ] map 2nip ; +: command-menu ( presented -- menu ) + dup applicable + [ [ third command-quot ] keep second swons ] map-with + ; -: init-commands ( gadget pane -- ) - over presented paint-prop [ - [ drop ] swap - unit - [ command-menu show-menu ] append3 +: init-commands ( gadget -- ) + dup presented paint-prop dup [ + [ + \ drop , + literal, + [ command-menu show-menu ] % + ] make-list button-gestures ] [ 2drop ] ifte ; : ( style text -- label ) -