diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 3b698e0001..f6e2bc0940 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -138,6 +138,12 @@ most-negative-fixnum most-positive-fixnum [a,b] \ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op +{ /mod fixnum/mod } [ + \ /i \ mod + [ "outputs" word-prop ] bi@ + '[ _ _ 2bi ] "outputs" set-word-prop +] each + \ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op \ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index 277d965e39..4a06235c69 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -129,12 +129,17 @@ HELP: $title { $values { "topic" "a help article name or a word" } } { $description "Prints a help article's title, or a word's " { $link summary } ", depending on the type of " { $snippet "topic" } "." } ; +HELP: print-topic +{ $values { "topic" "an article name or a word" } } +{ $description + "Displays a help topic on " { $link output-stream } "." +} ; + HELP: help { $values { "topic" "an article name or a word" } } { $description - "Displays a help article or documentation associated to a word on " { $link output-stream } "." + "Displays a help topic." } ; - HELP: about { $values { "vocab" "a vocabulary specifier" } } { $description diff --git a/basis/help/help.factor b/basis/help/help.factor index 686578f1b6..f9775e2668 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -89,10 +89,17 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ] with-nesting ] with-style nl ; -: help ( topic -- ) +: print-topic ( topic -- ) last-element off dup $title article-content print-content nl ; +SYMBOL: help-hook + +help-hook global [ [ print-topic ] or ] change-at + +: help ( topic -- ) + help-hook get call ; + : about ( vocab -- ) dup require dup vocab [ ] [ diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor index beea9005b4..8ef49ca0d9 100644 --- a/basis/listener/listener-docs.factor +++ b/basis/listener/listener-docs.factor @@ -1,34 +1,39 @@ USING: help.markup help.syntax kernel io system prettyprint ; IN: listener +ARTICLE: "listener-watch" "Watching variables in the listener" +"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:" +{ $subsection visible-vars } +"To add or remove a single variable:" +{ $subsection show-var } +{ $subsection hide-var } +"To add and remove multiple variables:" +{ $subsection show-vars } +{ $subsection hide-vars } ; + ARTICLE: "listener" "The listener" "The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it." $nl "The classical first program can be run in the listener:" { $example "\"Hello, world\" print" "Hello, world" } -"Multi-line phrases are supported:" +"Multi-line expressions are supported:" { $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" } "The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them." -$nl -"A very common operation is to inspect the contents of the data stack in the listener:" -{ $subsection .s } -"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "." -$nl +{ $subsection "listener-watch" } "You can start a nested listener or exit a listener using the following words:" { $subsection listener } { $subsection bye } -"The following variables can be rebound inside a nested scope to customize the behavior of a listener; this can be done to create a development tool with a custom interaction loop:" -{ $subsection listener-hook } "Finally, the multi-line expression reading word can be used independently of the rest of the listener:" { $subsection read-quot } ; ABOUT: "listener" + HELP: read-quot { $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } } diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index feddbdc042..5d58cafe29 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -3,16 +3,10 @@ USING: arrays hashtables io kernel math math.parser memory namespaces parser lexer sequences strings io.styles vectors words generic system combinators continuations debugger -definitions compiler.units accessors colors ; - +definitions compiler.units accessors colors prettyprint fry +sets ; IN: listener -SYMBOL: quit-flag - -SYMBOL: listener-hook - -[ ] listener-hook set-global - GENERIC: stream-read-quot ( stream -- quot/f ) : parse-lines-interactive ( lines -- quot/f ) @@ -38,18 +32,57 @@ M: object stream-read-quot : read-quot ( -- quot/f ) input-stream get stream-read-quot ; + + : bye ( -- ) quit-flag on ; -: prompt. ( -- ) - "( " in get " )" 3append - H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ; +SYMBOL: visible-vars + +: show-var ( sym -- ) visible-vars [ swap suffix ] change ; + +: show-vars ( seq -- ) visible-vars [ swap union ] change ; + +: hide-var ( sym -- ) visible-vars [ remove ] change ; + +: hide-vars ( seq -- ) visible-vars [ swap diff ] change ; SYMBOL: error-hook [ print-error-and-restarts ] error-hook set-global + + : listener ( -- ) [ until-quit ] with-interactive-vocabs ; diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index 159421c18c..3c004e5b30 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -17,7 +17,8 @@ ARTICLE: "prettyprint-stacks" "Prettyprinting stacks" "Prettyprinting any stack:" { $subsection stack. } "Prettyprinting any call stack:" -{ $subsection callstack. } ; +{ $subsection callstack. } +"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "." ; ARTICLE: "prettyprint-variables" "Prettyprint control variables" "The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:" diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 1992dbcda3..f5778e410f 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -266,8 +266,7 @@ IN: tools.deploy.shaker layouts:tag-numbers layouts:type-numbers lexer-factory - listener:listener-hook - parser:print-use-hook + print-use-hook root-cache vocab-roots vocabs:dictionary diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index d74284cbd6..6b687f7e20 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -2,10 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math models namespaces sequences strings quotations assocs combinators classes colors -classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets -ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme -ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures -ui.render math.geometry.rect locals alien.c-types ; +classes.tuple locals alien.c-types fry opengl opengl.gl +math.vectors ui.commands ui.gadgets ui.gadgets.borders +ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks +ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render +math.geometry.rect ; IN: ui.gadgets.buttons TUPLE: button < border pressed? selected? quot ; @@ -27,7 +28,7 @@ TUPLE: button < border pressed? selected? quot ; relayout-1 ; : if-clicked ( button quot -- ) - >r dup button-update dup button-rollover? r> [ drop ] if ; + [ dup button-update dup button-rollover? ] dip [ drop ] if ; : button-clicked ( button -- ) dup quot>> if-clicked ; @@ -219,9 +220,8 @@ M: radio-control model-changed over value>> = >>selected? relayout-1 ; -: ( parent model assoc quot -- parent ) - #! quot has stack effect ( value model label -- ) - swapd [ swapd call add-gadget ] 2curry assoc-each ; inline +: ( assoc model parent quot: ( value model label -- ) -- parent ) + '[ _ swap _ call add-gadget ] assoc-each ; inline : radio-button-theme ( gadget -- gadget ) { 5 5 } >>gap @@ -232,8 +232,7 @@ M: radio-control model-changed : ( model assoc -- gadget ) - -rot - [ ] + spin [ ] { 5 5 } >>gap ; : ( value model label -- gadget ) @@ -241,20 +240,19 @@ M: radio-control model-changed : ( model assoc -- gadget ) - -rot - [ ] ; + spin [ ] ; : command-button-quot ( target command -- quot ) - [ invoke-command drop ] 2curry ; + '[ _ _ invoke-command drop ] ; : ( target gesture command -- button ) - [ command-string ] keep - swapd - command-button-quot - ; + [ command-string swap ] keep command-button-quot ; : ( target -- toolbar ) swap "toolbar" over class command-map commands>> swap - [ -rot add-gadget ] curry assoc-each ; + '[ [ _ ] 2dip add-gadget ] assoc-each ; + +: add-toolbar ( track -- track ) + dup f track-add ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index a1c4f3d04e..b5d30dd2d6 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -2,17 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays documents io kernel math models namespaces make opengl opengl.gl sequences strings io.styles -math.vectors sorting colors combinators assocs math.order -ui.clipboards ui.commands ui.gadgets ui.gadgets.borders -ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers -ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures -math.geometry.rect ; +math.vectors sorting colors combinators assocs math.order fry +calendar alarms ui.clipboards ui.commands ui.gadgets +ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels +ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers +ui.render ui.gestures math.geometry.rect ; IN: ui.gadgets.editors TUPLE: editor < gadget font color caret-color selection-color caret mark -focused? ; +focused? blink blink-alarm ; : ( -- loc ) { 0 0 } ; @@ -45,6 +45,28 @@ focused? ; dup deactivate-model swap model>> remove-loc ; +: blink-caret ( editor -- ) + [ not ] change-blink relayout-1 ; + +SYMBOL: blink-interval + +750 milliseconds blink-interval set-global + +: start-blinking ( editor -- ) + t >>blink + dup '[ _ blink-caret ] blink-interval get every >>blink-alarm drop ; + +: stop-blinking ( editor -- ) + [ [ cancel-alarm ] when* f ] change-blink-alarm drop ; + +: restart-blinking ( editor -- ) + dup focused?>> [ + [ stop-blinking ] + [ start-blinking ] + [ relayout-1 ] + tri + ] [ drop ] if ; + M: editor graft* dup dup caret>> activate-editor-model @@ -52,6 +74,7 @@ M: editor graft* M: editor ungraft* dup + dup stop-blinking dup caret>> deactivate-editor-model dup mark>> deactivate-editor-model ; @@ -64,14 +87,14 @@ M: editor ungraft* caret>> set-model ; : change-caret ( editor quot -- ) - over >r >r dup editor-caret* swap model>> r> call r> + [ [ [ editor-caret* ] [ model>> ] bi ] dip call ] [ drop ] 2bi set-caret ; inline : mark>caret ( editor -- ) - dup editor-caret* swap mark>> set-model ; + [ editor-caret* ] [ mark>> ] bi set-model ; : change-caret&mark ( editor quot -- ) - over >r change-caret r> mark>caret ; inline + [ change-caret ] [ drop mark>caret ] 2bi ; inline : editor-line ( n editor -- str ) control-value nth ; @@ -85,8 +108,8 @@ M: editor ungraft* : point>loc ( point editor -- loc ) [ - >r first2 r> tuck y>line dup , - >r dup editor-font* r> + [ first2 ] dip tuck y>line dup , + [ dup editor-font* ] dip rot editor-line x>offset , ] { } make ; @@ -94,11 +117,17 @@ M: editor ungraft* [ hand-rel ] keep point>loc ; : click-loc ( editor model -- ) - >r clicked-loc r> set-model ; + [ clicked-loc ] dip set-model ; -: focus-editor ( editor -- ) t >>focused? relayout-1 ; +: focus-editor ( editor -- ) + dup start-blinking + t >>focused? + relayout-1 ; -: unfocus-editor ( editor -- ) f >>focused? relayout-1 ; +: unfocus-editor ( editor -- ) + dup stop-blinking + f >>focused? + relayout-1 ; : (offset>x) ( font col# str -- x ) swap head-slice string-width ; @@ -106,7 +135,7 @@ M: editor ungraft* : offset>x ( col# line# editor -- x ) [ editor-line ] keep editor-font* -rot (offset>x) ; -: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ; +: loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ; : line>y ( lines# editor -- y ) line-height * ; @@ -126,7 +155,7 @@ M: editor ungraft* ] [ drop ] if ; : draw-caret ( -- ) - editor get focused?>> [ + editor get [ focused?>> ] [ blink>> ] bi and [ editor get [ caret-color>> gl-color ] [ @@ -143,7 +172,7 @@ M: editor ungraft* line-translation gl-translate ; : draw-line ( editor str -- ) - >r font>> r> { 0 0 } draw-string ; + [ font>> ] dip { 0 0 } draw-string ; : first-visible-line ( editor -- n ) clip get rect-loc second origin get second - @@ -169,7 +198,7 @@ M: editor ungraft* rot control-value ; : with-editor-translation ( n quot -- ) - >r line-translation origin get v+ r> with-translation ; + [ line-translation origin get v+ ] dip with-translation ; inline : draw-lines ( -- ) @@ -199,7 +228,7 @@ M: editor ungraft* editor get selection-start/end over first [ 2dup [ - >r 2dup r> draw-selected-line + [ 2dup ] dip draw-selected-line 1 translate-lines ] each-line 2drop ] with-editor-translation ; @@ -217,7 +246,7 @@ M: editor pref-dim* drop relayout ; : caret/mark-changed ( model editor -- ) - nip [ relayout-1 ] [ scroll>caret ] bi ; + nip [ restart-blinking ] [ scroll>caret ] bi ; M: editor model-changed { @@ -247,7 +276,9 @@ M: editor user-input* M: editor gadget-text* editor-string % ; : extend-selection ( editor -- ) - dup request-focus dup caret>> click-loc ; + dup request-focus + dup restart-blinking + dup caret>> click-loc ; : mouse-elt ( -- element ) hand-click# get { @@ -259,14 +290,15 @@ M: editor gadget-text* editor-string % ; editor-mark* before? ; : drag-selection-caret ( loc editor element -- loc ) - >r [ drag-direction? ] 2keep - model>> - r> prev/next-elt ? ; + [ + [ drag-direction? ] 2keep model>> + ] dip prev/next-elt ? ; : drag-selection-mark ( loc editor element -- loc ) - >r [ drag-direction? not ] 2keep - nip dup editor-mark* swap model>> - r> prev/next-elt ? ; + [ + [ drag-direction? not ] keep + [ editor-mark* ] [ model>> ] bi + ] dip prev/next-elt ? ; : drag-caret&mark ( editor -- caret mark ) dup clicked-loc swap mouse-elt @@ -285,15 +317,16 @@ M: editor gadget-text* editor-string % ; over gadget-selection? [ drop nip remove-selection ] [ - over >r >r dup editor-caret* swap model>> - r> call r> model>> remove-doc-range + [ [ [ editor-caret* ] [ model>> ] bi ] dip call ] + [ drop model>> ] + 2bi remove-doc-range ] if ; inline : editor-delete ( editor elt -- ) - swap [ over >r rot next-elt r> swap ] delete/backspace ; + swap [ over [ rot next-elt ] dip swap ] delete/backspace ; : editor-backspace ( editor elt -- ) - swap [ over >r rot prev-elt r> ] delete/backspace ; + swap [ over [ rot prev-elt ] dip ] delete/backspace ; : editor-select-prev ( editor elt -- ) swap [ rot prev-elt ] change-caret ; @@ -311,9 +344,8 @@ M: editor gadget-text* editor-string % ; tuck caret>> set-model mark>> set-model ; : select-elt ( editor elt -- ) - over >r - >r dup editor-caret* swap model>> r> prev/next-elt - r> editor-select ; + [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi + editor-select ; : start-of-document ( editor -- ) T{ doc-elt } editor-prev ; diff --git a/basis/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor index 1cf23e2d06..ff2220b60e 100644 --- a/basis/ui/gadgets/slots/slots.factor +++ b/basis/ui/gadgets/slots/slots.factor @@ -71,7 +71,7 @@ M: value-ref finish-editing : ( ref -- gadget ) { 0 1 } slot-editor new-track swap >>ref - dup f track-add + add-toolbar >>text dup text>> 1 track-add dup revert ; diff --git a/basis/ui/gadgets/tracks/tracks-tests.factor b/basis/ui/gadgets/tracks/tracks-tests.factor index 93f2d14528..5381eebb01 100644 --- a/basis/ui/gadgets/tracks/tracks-tests.factor +++ b/basis/ui/gadgets/tracks/tracks-tests.factor @@ -14,3 +14,10 @@ IN: ui.gadgets.tracks.tests { 100 100 } >>dim 1 track-add pref-dim ] unit-test + +[ { 10 10 } ] [ + { 0 1 } + { 10 10 } >>dim 1 track-add + { 10 10 } >>dim 0 track-add + pref-dim +] unit-test diff --git a/basis/ui/gadgets/tracks/tracks.factor b/basis/ui/gadgets/tracks/tracks.factor index 771c489ce3..ddc7cf18fd 100644 --- a/basis/ui/gadgets/tracks/tracks.factor +++ b/basis/ui/gadgets/tracks/tracks.factor @@ -41,7 +41,8 @@ M: track layout* ( track -- ) dup track-layout pack-layout ; : track-pref-dims-2 ( track -- dim ) [ [ children>> pref-dims ] [ normalized-sizes ] bi - [ [ v/n ] when* ] 2map max-dim [ >fixnum ] map + [ dup { 0 f } memq? [ drop ] [ v/n ] if ] 2map + max-dim [ >fixnum ] map ] [ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi v+ ; diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index 83a3b7ff68..b717bbb2f9 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -4,17 +4,17 @@ USING: debugger ui.tools.workspace help help.topics kernel models models.history ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons compiler.units assocs words vocabs -accessors ; +accessors fry combinators.short-circuit ; IN: ui.tools.browser TUPLE: browser-gadget < track pane history ; : show-help ( link help -- ) - dup history>> add-history - >r >link r> history>> set-model ; + history>> dup add-history + [ >link ] dip set-model ; : ( browser-gadget -- gadget ) - history>> [ [ help ] curry try ] ; + history>> [ '[ _ print-topic ] try ] ; : init-history ( browser-gadget -- ) "handbook" >link >>history drop ; @@ -22,7 +22,7 @@ TUPLE: browser-gadget < track pane history ; : ( -- gadget ) { 0 1 } browser-gadget new-track dup init-history - dup f track-add + add-toolbar dup >>pane dup pane>> 1 track-add ; @@ -38,10 +38,11 @@ M: browser-gadget ungraft* [ call-next-method ] [ remove-definition-observer ] bi ; : showing-definition? ( defspec assoc -- ? ) - [ key? ] 2keep - [ >r dup word-link? [ name>> ] when r> key? ] 2keep - >r dup vocab-link? [ vocab ] when r> key? - or or ; + { + [ key? ] + [ [ dup word-link? [ name>> ] when ] dip key? ] + [ [ dup vocab-link? [ vocab ] when ] dip key? ] + } 2|| ; M: browser-gadget definitions-changed ( assoc browser -- ) history>> diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index 1f019fca7c..641763c0b1 100644 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -25,7 +25,7 @@ TUPLE: debugger < track restarts ; : ( error restarts restart-hook -- gadget ) { 0 1 } debugger new-track - dup f track-add + add-toolbar -rot >>restarts dup restarts>> rot 1 track-add ; diff --git a/basis/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor index dcb3a3f8ad..579210325b 100644 --- a/basis/ui/tools/inspector/inspector.factor +++ b/basis/ui/tools/inspector/inspector.factor @@ -17,7 +17,7 @@ TUPLE: inspector-gadget < track object pane ; : ( -- gadget ) { 0 1 } inspector-gadget new-track - dup f track-add + add-toolbar >>pane dup pane>> 1 track-add ; diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor index a36610a7f5..36ce67e57b 100644 --- a/basis/ui/tools/interactor/interactor.factor +++ b/basis/ui/tools/interactor/interactor.factor @@ -178,10 +178,6 @@ M: interactor stream-read-quot ] } cond ; -M: interactor pref-dim* - [ line-height 4 * 0 swap 2array ] [ call-next-method ] bi - vmax ; - interactor "interactor" f { { T{ key-down f f "RET" } evaluate-input } { T{ key-down f { C+ } "k" } clear-input } diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 49ce5203d3..250fc371c7 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -1,20 +1,21 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: inspector ui.tools.interactor ui.tools.inspector -ui.tools.workspace help.markup io io.styles -kernel models namespaces parser quotations sequences ui.commands +USING: inspector help help.markup io io.styles +kernel models namespaces parser quotations sequences vocabs words +prettyprint listener debugger threads boxes concurrency.flags +math arrays generic accessors combinators assocs fry ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers -ui.gadgets.tracks ui.gestures ui.operations vocabs words -prettyprint listener debugger threads boxes concurrency.flags -math arrays generic accessors combinators assocs ; +ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations +ui.tools.browser ui.tools.interactor ui.tools.inspector +ui.tools.workspace ; IN: ui.tools.listener -TUPLE: listener-gadget < track input output stack ; +TUPLE: listener-gadget < track input output ; : listener-output, ( listener -- listener ) - >>output - dup output>> "Output" 1 track-add ; + + [ >>output ] [ 1 track-add ] bi ; : listener-streams ( listener -- input output ) [ input>> ] [ output>> ] bi ; @@ -23,17 +24,13 @@ TUPLE: listener-gadget < track input output stack ; output>> ; : listener-input, ( listener -- listener ) - dup >>input - dup input>> - - { 0 100 } >>min-dim - { 1/0. 100 } >>max-dim - "Input" - f track-add ; + dup + [ >>input ] [ 1 { 1 1 } >>fill f track-add ] bi ; : welcome. ( -- ) "If this is your first time with Factor, please read the " print - "handbook" ($link) "." print nl ; + "handbook" ($link) ". To see a list of keyboard shortcuts," print + "press F1." print nl ; M: listener-gadget focusable-child* input>> ; @@ -60,7 +57,7 @@ M: listener-gadget tool-scroller : call-listener ( quot -- ) [ workspace-busy? not ] get-workspace* listener>> - [ dup wait-for-listener (call-listener) ] 2curry + '[ _ _ dup wait-for-listener (call-listener) ] "Listener call" spawn drop ; M: listener-command invoke-command ( target command -- ) @@ -76,7 +73,7 @@ M: listener-operation invoke-command ( target command -- ) : listener-run-files ( seq -- ) [ - [ [ run-file ] each ] curry call-listener + '[ _ [ run-file ] each ] call-listener ] unless-empty ; : com-end ( listener -- ) @@ -122,20 +119,8 @@ M: engine-word word-completion-string [ select-all ] 2bi ; -TUPLE: stack-display < track ; - -: ( workspace -- gadget ) - listener>> - { 0 1 } stack-display new-track - over f track-add - swap stack>> [ [ stack. ] curry try ] t "Data stack" - 1 track-add ; - -M: stack-display tool-scroller - find-workspace listener>> tool-scroller ; - -: ui-listener-hook ( listener -- ) - >r datastack r> stack>> set-model ; +: ui-help-hook ( topic -- ) + browser-gadget call-tool ; : ui-error-hook ( error listener -- ) find-workspace debugger-popup ; @@ -146,17 +131,20 @@ M: stack-display tool-scroller : listener-thread ( listener -- ) dup listener-streams [ - [ [ ui-listener-hook ] curry listener-hook set ] - [ [ ui-error-hook ] curry error-hook set ] - [ [ ui-inspector-hook ] curry inspector-hook set ] tri + [ ui-help-hook ] help-hook set + [ '[ _ ui-error-hook ] error-hook set ] + [ '[ _ ui-inspector-hook ] inspector-hook set ] bi welcome. listener ] with-streams* ; : start-listener-thread ( listener -- ) - [ - [ input>> register-self ] [ listener-thread ] bi - ] curry "Listener" spawn drop ; + '[ + _ + [ input>> register-self ] + [ listener-thread ] + bi + ] "Listener" spawn drop ; : restart-listener ( listener -- ) #! Returns when listener is ready to receive input. @@ -168,12 +156,9 @@ M: stack-display tool-scroller [ wait-for-listener ] } cleave ; -: init-listener ( listener -- ) - f >>stack drop ; - : ( -- gadget ) { 0 1 } listener-gadget new-track - dup init-listener + add-toolbar listener-output, listener-input, ; @@ -181,12 +166,21 @@ M: stack-display tool-scroller \ listener-help H{ { +nullary+ t } } define-command +: com-auto-use ( -- ) + auto-use? [ not ] change ; + +\ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command + +listener-gadget "misc" "Miscellaneous commands" { + { T{ key-down f f "F1" } listener-help } +} define-command-map + listener-gadget "toolbar" f { { f restart-listener } - { T{ key-down f { A+ } "c" } clear-output } - { T{ key-down f { A+ } "C" } clear-stack } + { T{ key-down f { A+ } "a" } com-auto-use } + { T{ key-down f { A+ } "c" } clear-output } + { T{ key-down f { A+ } "C" } clear-stack } { T{ key-down f { C+ } "d" } com-end } - { T{ key-down f f "F1" } listener-help } } define-command-map M: listener-gadget handle-gesture ( gesture gadget -- ? ) diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index c60d0dac09..05d1ccdb82 100644 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -9,7 +9,7 @@ TUPLE: profiler-gadget < track pane ; : ( -- gadget ) { 0 1 } profiler-gadget new-track - dup f track-add + add-toolbar >>pane dup pane>> 1 track-add ; diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor index 3081eb1cdc..cf980cfc23 100644 --- a/basis/ui/tools/search/search.factor +++ b/basis/ui/tools/search/search.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs ui.tools.interactor ui.tools.listener -ui.tools.workspace help help.topics io.files io.styles kernel -models models.delay models.filter namespaces prettyprint +USING: accessors assocs help help.topics io.files io.styles +kernel models models.delay models.filter namespaces prettyprint quotations sequences sorting source-files definitions strings -tools.completion tools.crossref classes.tuple ui.commands -ui.gadgets ui.gadgets.editors ui.gadgets.lists -ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations -vocabs words vocabs.loader tools.vocabs unicode.case calendar ui -; +tools.completion tools.crossref classes.tuple vocabs words +vocabs.loader tools.vocabs unicode.case calendar locals +ui.tools.interactor ui.tools.listener ui.tools.workspace +ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists +ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.borders +ui.gestures ui.operations ui ; IN: ui.tools.search TUPLE: live-search < track field list ; @@ -23,7 +23,7 @@ TUPLE: live-search < track field list ; M: live-search handle-gesture ( gesture live-search -- ? ) tuck search-gesture dup [ over find-workspace hide-popup - >r search-value r> invoke-command f + [ search-value ] dip invoke-command f ] [ 2drop t ] if ; @@ -47,27 +47,29 @@ search-field H{ { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] } } set-gestures -: ( live-search producer -- live-search filter ) - >r dup field>> model>> - ui-running? [ 1/5 seconds ] when - [ "\n" join ] r> append ; +: ( live-search producer -- filter ) + [ + field>> model>> + ui-running? [ 1/5 seconds ] when + ] dip [ "\n" join ] prepend ; -: ( live-search seq limited? presenter -- live-search list ) - >r - [ limited-completions ] [ completions ] ? curry - - >r [ find-workspace hide-popup ] r> r> - swap ; +: init-search-model ( live-search seq limited? -- live-search ) + [ 2drop ] + [ [ limited-completions ] [ completions ] ? curry ] 3bi + >>model ; inline -: ( string seq limited? presenter -- gadget ) +: ( presenter live-search -- list ) + [ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* ; + +:: ( string seq limited? presenter -- gadget ) { 0 1 } live-search new-track >>field - dup field>> f track-add - -roll >>list + seq limited? init-search-model + presenter over >>list + dup field>> 1 { 1 1 } >>fill f track-add dup list>> 1 track-add - swap - over field>> set-editor-string - dup field>> end-of-document ; + string over field>> set-editor-string + dup field>> end-of-document ; M: live-search focusable-child* field>> ; @@ -80,26 +82,27 @@ M: live-search pref-dim* drop { 400 200 } ; [ dup synopsis >lower ] { } map>assoc sort-values ; : ( string words limited? -- gadget ) - >r definition-candidates r> [ synopsis ] ; + [ definition-candidates ] dip [ synopsis ] ; : word-candidates ( words -- candidates ) [ dup name>> >lower ] { } map>assoc ; : ( string words limited? -- gadget ) - >r word-candidates r> [ synopsis ] ; + [ word-candidates ] dip [ synopsis ] ; : com-words ( workspace -- ) dup current-word all-words t "Word search" show-titled-popup ; : show-vocab-words ( workspace vocab -- ) - "" over words natural-sort f - "Words in " rot vocab-name append show-titled-popup ; + [ "" swap words natural-sort f ] + [ "Words in " swap vocab-name append ] + bi show-titled-popup ; : show-word-usage ( workspace word -- ) - "" over smart-usage f - "Words and methods using " rot name>> append - show-titled-popup ; + [ "" swap smart-usage f ] + [ "Words and methods using " swap name>> append ] + bi show-titled-popup ; : help-candidates ( seq -- candidates ) [ dup >link swap article-title >lower ] { } map>assoc @@ -127,8 +130,9 @@ M: live-search pref-dim* drop { 400 200 } ; "Source file search" show-titled-popup ; : show-vocab-files ( workspace vocab -- ) - "" over vocab-files - "Source files in " rot vocab-name append show-titled-popup ; + [ "" swap vocab-files ] + [ "Source files in " swap vocab-name append ] + bi show-titled-popup ; : vocab-candidates ( -- candidates ) all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ; diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor index f54e1e4041..6368737460 100644 --- a/basis/ui/tools/tools-docs.factor +++ b/basis/ui/tools/tools-docs.factor @@ -32,7 +32,7 @@ ARTICLE: "ui-listener" "UI listener" { $heading "Editing commands" } "The text editing commands are standard; see " { $link "gadgets-editors" } "." { $heading "Implementation" } -"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } "), and an input area (instance of " { $link interactor } "), and a stack display kept up to date using a " { $link listener-hook } "." ; +"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } ")." ; ARTICLE: "ui-inspector" "UI inspector" "The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values." diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index aed4b9d675..3310a3e0a5 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -19,8 +19,7 @@ IN: ui.tools ; : ( workspace -- gadget ) - dup - + @@ -34,14 +33,14 @@ IN: ui.tools dup >>book dup f track-add - dup book>> 1/5 track-add - dup listener>> 4/5 track-add - dup f track-add ; + dup book>> 0 track-add + dup listener>> 1 track-add + add-toolbar ; : resize-workspace ( workspace -- ) - dup sizes>> over control-value zero? [ - 1/5 over set-second - 4/5 swap set-third + dup sizes>> over control-value 0 = [ + 0 over set-second + 1 swap set-third ] [ 2/3 over set-second 1/3 swap set-third @@ -55,13 +54,15 @@ M: workspace model-changed [ workspace-window ] ui-hook set-global -: com-listener ( workspace -- ) stack-display select-tool ; +: select-tool ( workspace n -- ) swap book>> model>> set-model ; -: com-browser ( workspace -- ) browser-gadget select-tool ; +: com-listener ( workspace -- ) 0 select-tool ; -: com-inspector ( workspace -- ) inspector-gadget select-tool ; +: com-browser ( workspace -- ) 1 select-tool ; -: com-profiler ( workspace -- ) profiler-gadget select-tool ; +: com-inspector ( workspace -- ) 2 select-tool ; + +: com-profiler ( workspace -- ) 3 select-tool ; workspace "tool-switching" f { { T{ key-down f { A+ } "1" } com-listener } diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor index 7e2158e0e9..45f15b1ffc 100644 --- a/basis/ui/tools/traceback/traceback.factor +++ b/basis/ui/tools/traceback/traceback.factor @@ -36,7 +36,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ; dup model>> 2/3 track-add - dup f track-add ; + add-toolbar ; : ( model -- gadget ) [ [ name>> namestack. ] when* ] diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor index 7bc42ea676..9c825d4920 100644 --- a/basis/ui/tools/walker/walker.factor +++ b/basis/ui/tools/walker/walker.factor @@ -62,9 +62,9 @@ M: walker-gadget focusable-child* swap >>status dup continuation>> >>traceback - dup f track-add + add-toolbar dup status>> self f track-add - dup traceback>> 1 track-add ; + dup traceback>> 1 track-add ; : walker-help ( -- ) "ui-walker" help-window ; diff --git a/basis/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor index f06e0aae26..6536cb8c7d 100644 --- a/basis/ui/tools/workspace/workspace.factor +++ b/basis/ui/tools/workspace/workspace.factor @@ -1,12 +1,12 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes continuations help help.topics kernel models - sequences ui ui.backend ui.tools.debugger ui.gadgets - ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled - ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks - ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar - ui.commands ui.gestures assocs arrays namespaces accessors ; - +sequences assocs arrays namespaces accessors math.vectors ui +ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books +ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes +ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds +ui.gadgets.presentations ui.gadgets.status-bar ui.commands +ui.gestures ; IN: ui.tools.workspace TUPLE: workspace < track book listener popup ; @@ -32,8 +32,6 @@ M: gadget tool-scroller drop f ; [ find-tool swap ] keep book>> model>> set-model ; -: select-tool ( workspace class -- ) swap show-tool drop ; - : get-workspace* ( quot -- workspace ) [ >r dup workspace? r> [ drop f ] if ] curry find-window [ dup raise-window gadget-child ] @@ -81,7 +79,7 @@ SYMBOL: workspace-dim { 600 700 } workspace-dim set-global -M: workspace pref-dim* drop workspace-dim get ; +M: workspace pref-dim* call-next-method workspace-dim get vmax ; M: workspace focusable-child* dup popup>> [ ] [ listener>> ] ?if ; diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index d3c2cff19d..92e5922802 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -41,13 +41,15 @@ $nl } "The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ; -ARTICLE: "vocabulary-search-errors" "Word lookup errors" -"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:" -{ $list - { "If there are no words having this name at all, an error is thrown and parsing stops." } - { "If there are vocabularies which contain words with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." } -} -"When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ; +ARTICLE: "vocabulary-search-errors" "Word lookup errors" +"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies." +$nl +"If " { $link auto-use? } " mode is off, a restartable error is thrown with a restart for each vocabulary in question, together with a restart which defers the word in the current vocabulary, as if " { $link POSTPONE: DEFER: } " was used." +$nl +"If " { $link auto-use? } " mode is on and only one vocabulary has a word with this name, the vocabulary is added to the search path and parsing continues." +$nl +"If any restarts were invoked, or if " { $link auto-use? } " is on, the parser will print the correct " { $link POSTPONE: USING: } " after parsing completes. This form can be copy and pasted back into the source file." +{ $subsection auto-use? } ; ARTICLE: "vocabulary-search" "Vocabulary search path" "When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order." @@ -353,3 +355,7 @@ HELP: staging-violation { $description "Throws a " { $link staging-violation } " error." } { $error-description "Thrown by the parser if a parsing word is used in the same compilation unit as where it was defined; see " { $link "compilation-units" } "." } { $notes "One possible workaround is to use the " { $link POSTPONE: << } " word to execute code at parse time. However, executing words defined in the same source file at parse time is still prohibited." } ; + +HELP: auto-use? +{ $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." } +{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "vocabulary-search-errors" } "." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index d2d407e147..f621cbb84a 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -496,3 +496,5 @@ DEFER: blah [ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ] [ error>> error>> def>> \ blah eq? ] must-fail-with + +[ ] [ f lexer set f file set "Hello world" note. ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 007120fd19..1728b471e2 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -25,7 +25,7 @@ t parser-notes set-global : note. ( str -- ) parser-notes? [ file get [ path>> write ":" write ] when* - lexer get line>> number>string write ": " write + lexer get [ line>> number>string write ": " write ] when* "Note: " write dup print ] when drop ; @@ -82,17 +82,20 @@ ERROR: no-word-error name ; SYMBOL: amended-use? -SYMBOL: do-what-i-mean? +SYMBOL: auto-use? : no-word-restarted ( restart-value -- word ) - dup word? - [ amended-use? on dup vocabulary>> (use+) ] - [ create-in ] - if ; + dup word? [ + amended-use? on + dup vocabulary>> + [ (use+) ] [ + "Added ``" swap "'' vocabulary to search path" 3append note. + ] bi + ] [ create-in ] if ; : no-word ( name -- newword ) dup words-named [ forward-reference? not ] filter - dup length 1 = do-what-i-mean? get and + dup length 1 = auto-use? get and [ nip first no-word-restarted ] [ throw-restarts no-word-restarted ] if ; diff --git a/vm/math.c b/vm/math.c index c6b91bc8f7..6a0acf7180 100644 --- a/vm/math.c +++ b/vm/math.c @@ -33,18 +33,18 @@ void primitive_float_to_fixnum(void) #define POP_FIXNUMS(x,y) \ F_FIXNUM y = untag_fixnum_fast(dpop()); \ - F_FIXNUM x = untag_fixnum_fast(dpop()); + F_FIXNUM x = untag_fixnum_fast(dpeek()); void primitive_fixnum_add(void) { POP_FIXNUMS(x,y) - box_signed_cell(x + y); + drepl(allot_integer(x + y)); } void primitive_fixnum_subtract(void) { POP_FIXNUMS(x,y) - box_signed_cell(x - y); + drepl(allot_integer(x - y)); } /* Multiply two integers, and trap overflow. @@ -54,20 +54,20 @@ void primitive_fixnum_multiply(void) POP_FIXNUMS(x,y) if(x == 0 || y == 0) - dpush(tag_fixnum(0)); + drepl(tag_fixnum(0)); else { F_FIXNUM prod = x * y; /* if this is not equal, we have overflow */ if(prod / x == y) - box_signed_cell(prod); + drepl(allot_integer(prod)); else { F_ARRAY *bx = fixnum_to_bignum(x); REGISTER_BIGNUM(bx); F_ARRAY *by = fixnum_to_bignum(y); UNREGISTER_BIGNUM(bx); - dpush(tag_bignum(bignum_multiply(bx,by))); + drepl(tag_bignum(bignum_multiply(bx,by))); } } } @@ -75,14 +75,27 @@ void primitive_fixnum_multiply(void) void primitive_fixnum_divint(void) { POP_FIXNUMS(x,y) - box_signed_cell(x / y); + F_FIXNUM result = x / y; + if(result == -FIXNUM_MIN) + drepl(allot_integer(-FIXNUM_MIN)); + else + drepl(tag_fixnum(result)); } void primitive_fixnum_divmod(void) { - POP_FIXNUMS(x,y) - box_signed_cell(x / y); - dpush(tag_fixnum(x % y)); + F_FIXNUM y = get(ds); + F_FIXNUM x = get(ds - CELLS); + if(y == -1 && x == tag_fixnum(FIXNUM_MIN)) + { + put(ds - CELLS,allot_integer(-FIXNUM_MIN)); + put(ds,tag_fixnum(0)); + } + else + { + put(ds - CELLS,tag_fixnum(x / y)); + put(ds,x % y); + } } /* @@ -96,15 +109,15 @@ void primitive_fixnum_shift(void) if(x == 0 || y == 0) { - dpush(tag_fixnum(x)); + drepl(tag_fixnum(x)); return; } else if(y < 0) { if(y <= -WORD_SIZE) - dpush(x < 0 ? tag_fixnum(-1) : tag_fixnum(0)); + drepl(x < 0 ? tag_fixnum(-1) : tag_fixnum(0)); else - dpush(tag_fixnum(x >> -y)); + drepl(tag_fixnum(x >> -y)); return; } else if(y < WORD_SIZE - TAG_BITS) @@ -112,12 +125,12 @@ void primitive_fixnum_shift(void) F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y)); if((x > 0 && (x & mask) == 0) || (x & mask) == mask) { - dpush(tag_fixnum(x << y)); + drepl(tag_fixnum(x << y)); return; } } - dpush(tag_bignum(bignum_arithmetic_shift( + drepl(tag_bignum(bignum_arithmetic_shift( fixnum_to_bignum(x),y))); }