diff --git a/basis/combinators/short-circuit/short-circuit-docs.factor b/basis/combinators/short-circuit/short-circuit-docs.factor index 54fc3aac43..6cd18201fe 100644 --- a/basis/combinators/short-circuit/short-circuit-docs.factor +++ b/basis/combinators/short-circuit/short-circuit-docs.factor @@ -52,17 +52,17 @@ HELP: 3|| { "quot" quotation } } { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ; -HELP: n&&-rewrite +HELP: n&& { $values { "quots" "a sequence of quotations" } { "N" integer } { "quot" quotation } } -{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ; +{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ; -HELP: n||-rewrite +HELP: n|| { $values - { "quots" "a sequence of quotations" } { "N" integer } + { "quots" "a sequence of quotations" } { "n" integer } { "quot" quotation } } -{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ; +{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each OR quotation." } ; ARTICLE: "combinators.short-circuit" "Short-circuit combinators" "The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl @@ -77,8 +77,8 @@ ARTICLE: "combinators.short-circuit" "Short-circuit combinators" { $subsection 2|| } { $subsection 3|| } "Generalized combinators:" -{ $subsection n&&-rewrite } -{ $subsection n||-rewrite } +{ $subsection n&& } +{ $subsection n|| } ; ABOUT: "combinators.short-circuit" diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor index 7b6c1d126d..2b4e522789 100644 --- a/basis/combinators/short-circuit/short-circuit.factor +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -1,35 +1,26 @@ - USING: kernel combinators quotations arrays sequences assocs - locals generalizations macros fry ; - +locals generalizations macros fry ; IN: combinators.short-circuit -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +MACRO:: n&& ( quots n -- quot ) + [ f ] + quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map + [ n nnip ] suffix 1array + [ cond ] 3append ; -:: n&&-rewrite ( quots N -- quot ) - quots - [ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ] - map - [ t ] [ N nnip ] 2array suffix - '[ f _ cond ] ; +MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ; +MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ; +MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ; +MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ; -MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ; -MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ; -MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ; -MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ; +MACRO:: n|| ( quots n -- quot ) + [ f ] + quots + [| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map + { [ drop n ndrop t ] [ f ] } suffix 1array + [ cond ] 3append ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -:: n||-rewrite ( quots N -- quot ) - quots - [ '[ drop N ndup @ dup ] [ N nnip ] 2array ] - map - [ drop N ndrop t ] [ f ] 2array suffix - '[ f _ cond ] ; - -MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ; -MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ; -MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ; -MACRO: 3|| ( quots -- quot ) 3 n||-rewrite ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ; +MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ; +MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ; +MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ; diff --git a/basis/combinators/short-circuit/smart/smart.factor b/basis/combinators/short-circuit/smart/smart.factor index ca659cacbe..b80e7294d1 100644 --- a/basis/combinators/short-circuit/smart/smart.factor +++ b/basis/combinators/short-circuit/smart/smart.factor @@ -1,7 +1,5 @@ - USING: kernel sequences math stack-checker effects accessors macros - combinators.short-circuit ; - +fry combinators.short-circuit ; IN: combinators.short-circuit.smart -MACRO: && ( quots -- quot ) dup arity n&&-rewrite ; +MACRO: && ( quots -- quot ) dup arity '[ _ _ n&& ] ; -MACRO: || ( quots -- quot ) dup arity n||-rewrite ; +MACRO: || ( quots -- quot ) dup arity '[ _ _ n|| ] ; diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index e89a9c6211..771d3800df 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs classes classes.algebra classes.tuple classes.tuple.private kernel accessors math math.intervals -namespaces sequences words combinators combinators.short-circuit +namespaces sequences words combinators arrays compiler.tree.propagation.copy ; IN: compiler.tree.propagation.info @@ -253,12 +253,13 @@ DEFER: (value-info-union) { [ over not ] [ 2drop f ] } [ { - [ [ class>> ] bi@ class<= ] - [ [ interval>> ] bi@ interval-subset? ] - [ literals<= ] - [ [ length>> ] bi@ value-info<= ] - [ [ slots>> ] bi@ [ value-info<= ] 2all? ] - } 2&& + { [ 2dup [ class>> ] bi@ class<= not ] [ f ] } + { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] } + { [ 2dup literals<= not ] [ f ] } + { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] } + { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] } + [ t ] + } cond 2nip ] } cond ; 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/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index aee0f3f4f3..014d2b31a0 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -335,6 +335,24 @@ big-endian on 7 ds-reg 0 STW ] f f f \ fixnum-mod define-sub-primitive +[ + 3 ds-reg 0 LWZ + ds-reg ds-reg 4 SUBI + 4 ds-reg 0 LWZ + 5 4 3 DIVW + 5 ds-reg 0 STW +] f f f \ fixnum/i-fast define-sub-primitive + +[ + 3 ds-reg 0 LWZ + 4 ds-reg -4 LWZ + 5 4 3 DIVW + 6 5 3 MULLW + 7 6 4 SUBF + 5 ds-reg -4 STW + 7 ds-reg 0 STW +] f f f \ fixnum/mod-fast define-sub-primitive + [ 3 ds-reg 0 LWZ 3 3 1 SRAWI diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 1ee74a434b..2c54880788 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -305,16 +305,33 @@ big-endian off ds-reg [] arg1 MOV ! push to stack ] f f f \ fixnum-shift-fast define-sub-primitive -[ +: jit-fixnum-/mod temp-reg ds-reg [] MOV ! load second parameter - ds-reg bootstrap-cell SUB ! adjust stack pointer - div-arg ds-reg [] MOV ! load first parameter + div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter mod-arg div-arg MOV ! make a copy mod-arg bootstrap-cell-bits 1- SAR ! sign-extend - temp-reg IDIV ! divide + temp-reg IDIV ; ! divide + +[ + jit-fixnum-/mod + ds-reg bootstrap-cell SUB ! adjust stack pointer ds-reg [] mod-arg MOV ! push to stack ] f f f \ fixnum-mod define-sub-primitive +[ + jit-fixnum-/mod + ds-reg bootstrap-cell SUB ! adjust stack pointer + div-arg tag-bits get SHL ! tag it + ds-reg [] div-arg MOV ! push to stack +] f f f \ fixnum/i-fast define-sub-primitive + +[ + jit-fixnum-/mod + div-arg tag-bits get SHL ! tag it + ds-reg [] mod-arg MOV ! push to stack + ds-reg bootstrap-cell neg [+] div-arg MOV +] f f f \ fixnum/mod-fast define-sub-primitive + [ arg0 ds-reg [] MOV ! load local number fixnum>slot@ ! turn local number into offset diff --git a/basis/editors/notepad2/authors.txt b/basis/editors/notepad2/authors.txt new file mode 100644 index 0000000000..7852139357 --- /dev/null +++ b/basis/editors/notepad2/authors.txt @@ -0,0 +1 @@ +Marc Fauconneau diff --git a/basis/editors/notepad2/notepad2.factor b/basis/editors/notepad2/notepad2.factor new file mode 100644 index 0000000000..4d333e45dd --- /dev/null +++ b/basis/editors/notepad2/notepad2.factor @@ -0,0 +1,16 @@ +USING: editors io.files io.launcher kernel math.parser +namespaces sequences windows.shell32 make ; +IN: editors.notepad2 + +: notepad2-path ( -- str ) + \ notepad2-path get-global [ + program-files "C:\\Windows\\system32\\notepad.exe" append-path + ] unless* ; + +: notepad2 ( file line -- ) + [ + notepad2-path , + "/g" , number>string , , + ] { } make run-detached drop ; + +[ notepad2 ] edit-hook set-global \ No newline at end of file diff --git a/basis/editors/notepad2/summary.txt b/basis/editors/notepad2/summary.txt new file mode 100644 index 0000000000..ab4a8ce377 --- /dev/null +++ b/basis/editors/notepad2/summary.txt @@ -0,0 +1 @@ +Notepad2 editor integration diff --git a/basis/editors/notepad2/tags.txt b/basis/editors/notepad2/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/basis/editors/notepad2/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 8f402f2e8c..b5d1b8d8d2 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -19,6 +19,9 @@ HELP: '[ { $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." } { $examples "See " { $link "fry.examples" } "." } ; +HELP: >r/r>-in-fry-error +{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to " { $link >r } " or " { $link r> } ". Explicit retain stack manipulation of this form does not work with fry; use " { $link dip } " instead." } ; + ARTICLE: "fry.examples" "Examples of fried quotations" "The easiest way to understand fried quotations is to look at some examples." $nl @@ -73,7 +76,10 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy" } ; ARTICLE: "fry.limitations" "Fried quotation limitations" -"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ; +"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." +$nl +"An error thrown if a fried quotation contains calls to " { $link >r } " and " { $link r> } ":" +{ $subsection >r/r>-in-fry-error } ; ARTICLE: "fry" "Fried quotations" "The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack." diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index d4a3b8b734..0137e8be22 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -1,23 +1,20 @@ IN: fry.tests USING: fry tools.test math prettyprint kernel io arrays -sequences ; +sequences eval accessors ; [ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test [ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test -[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test +[ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test -[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test +[ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test -[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test +[ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test -[ [ "a" write "b" print ] ] +[ [ "a" "b" [ write ] dip print ] ] [ "a" "b" '[ _ write _ print ] ] unit-test -[ [ 1 2 + 3 4 - ] ] -[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test - [ 1/2 ] [ 1 '[ [ _ ] dip / ] 2 swap call ] unit-test @@ -58,3 +55,10 @@ sequences ; [ { { { 3 } } } ] [ 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call ] unit-test + +[ "USING: fry kernel ; f '[ >r _ r> ]" eval ] +[ error>> >r/r>-in-fry-error? ] must-fail-with + +[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [ + 1 2 3 4 '[ "a" _ 2array "b" _ 2array "c" _ 2array "d" _ 2array 4array ] call +] unit-test diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor index 87c59e18a0..ac036f58ad 100644 --- a/basis/fry/fry.factor +++ b/basis/fry/fry.factor @@ -1,33 +1,37 @@ ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences combinators parser splitting math -quotations arrays make words ; +quotations arrays make words locals.backend summary sets ; IN: fry : _ ( -- * ) "Only valid inside a fry" throw ; : @ ( -- * ) "Only valid inside a fry" throw ; +ERROR: >r/r>-in-fry-error ; + ] + } case ; -: ((shallow-fry)) ( accum quot adder -- result ) - >r shallow-fry r> - append swap [ - [ prepose ] curry append - ] unless-empty ; inline +M: >r/r>-in-fry-error summary + drop + "Explicit retain stack manipulation is not permitted in fried quotations" ; -: (shallow-fry) ( accum quot -- result ) - [ 1quotation ] [ - unclip { - { \ _ [ [ curry ] ((shallow-fry)) ] } - { \ @ [ [ compose ] ((shallow-fry)) ] } - [ swap >r suffix r> (shallow-fry) ] - } case - ] if-empty ; +: check-fry ( quot -- quot ) + dup { >r r> load-locals get-local drop-locals } intersect + empty? [ >r/r>-in-fry-error ] unless ; -: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ; +: shallow-fry ( quot -- quot' ) + check-fry + [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat + { _ } split [ length 1- [ncurry] ] [ spread>quot ] bi prefix ; PREDICATE: fry-specifier < word { _ @ } memq? ; diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 75985c9368..1ebe528f35 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -36,3 +36,5 @@ IN: generalizations.tests [ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test [ ] [ { } 0 firstn ] unit-test [ "a" ] [ { "a" } 1 firstn ] unit-test + +[ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 069d59cee1..c63c2b66ca 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -6,8 +6,11 @@ math.ranges combinators macros quotations fry arrays ; IN: generalizations MACRO: nsequence ( n seq -- quot ) - [ drop ] [ '[ _ _ new-sequence ] ] 2bi - [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce ; + [ + [ drop ] [ '[ _ _ new-sequence ] ] 2bi + [ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce + ] keep + '[ @ _ like ] ; MACRO: narray ( n -- quot ) '[ _ { } nsequence ] ; 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/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 35e0536530..18488ed1dd 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -132,8 +132,8 @@ $nl "Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ; ARTICLE: "locals-limitations" "Limitations of locals" -"The first limitation is that the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator." -$nl +"The first limitation is also shared by " { $vocab-link "fry" } ": the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator. An error is thrown at parse time if an attempt is made to use " { $link >r } " and " { $link r> } " inside a lambda body:" +{ $subsection >r/r>-in-lambda-error } "Another limitation concerns combinators implemented as macros. Locals can only be used with such combinators if the input array immediately precedes the combinator call. For example, the following will work:" { $code ":: good-cond-usage ( a -- ... )" diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 04e077fc4f..60e40b9629 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel namespaces arrays strings prettyprint io.streams.string parser accessors generic eval combinators combinators.short-circuit combinators.short-circuit.smart math.order math.functions -definitions compiler.units ; +definitions compiler.units fry ; IN: locals.tests :: foo ( a b -- a a ) a a ; @@ -286,6 +286,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { [ a b > ] [ 5 ] } } cond ; +\ cond-test must-infer + [ 3 ] [ 1 2 cond-test ] unit-test [ 4 ] [ 2 2 cond-test ] unit-test [ 5 ] [ 3 2 cond-test ] unit-test @@ -293,6 +295,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; :: 0&&-test ( a -- ? ) { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ; +\ 0&&-test must-infer + [ f ] [ 1.5 0&&-test ] unit-test [ f ] [ 3 0&&-test ] unit-test [ f ] [ 8 0&&-test ] unit-test @@ -301,6 +305,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; :: &&-test ( a -- ? ) { [ a integer? ] [ a even? ] [ a 10 > ] } && ; +\ &&-test must-infer + [ f ] [ 1.5 &&-test ] unit-test [ f ] [ 3 &&-test ] unit-test [ f ] [ 8 &&-test ] unit-test @@ -346,6 +352,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as +ERROR: punned-class x ; + +[ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test + :: literal-identity-test ( -- a b ) { } V{ } ; @@ -390,6 +400,18 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test +[ + "USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval +] [ error>> >r/r>-in-fry-error? ] must-fail-with + +:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline +: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ; + +\ funny-macro-test must-infer + +[ t ] [ 3 funny-macro-test ] unit-test +[ f ] [ 2 funny-macro-test ] unit-test + ! :: wlet-&&-test ( a -- ? ) ! [wlet | is-integer? [ a integer? ] ! is-even? [ a even? ] diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 7de9d10436..1e205e10b0 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -6,12 +6,18 @@ quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables prettyprint.sections sets sequences.private effects effects.parser generic generic.parser compiler.units accessors -locals.backend memoize macros.expander lexer classes ; +locals.backend memoize macros.expander lexer classes summary ; IN: locals ! Inspired by ! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs +ERROR: >r/r>-in-lambda-error ; + +M: >r/r>-in-lambda-error summary + drop + "Explicit retain stack manipulation is not permitted in lambda bodies" ; + > , ] } - { [ t ] [ free-vars* ] } - } cond ; +M: local-writer free-vars* "local-reader" word-prop , ; + +M: lexical free-vars* , ; + +M: quote free-vars* , ; M: object free-vars* drop ; -M: quotation free-vars* [ add-if-free ] each ; +M: quotation free-vars* [ free-vars* ] each ; -M: lambda free-vars* - [ vars>> ] [ body>> ] bi free-vars swap diff % ; +M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ; GENERIC: lambda-rewrite* ( obj -- ) @@ -201,6 +204,8 @@ M: special rewrite-literal? drop t ; M: array rewrite-literal? [ rewrite-literal? ] contains? ; +M: quotation rewrite-literal? [ rewrite-literal? ] contains? ; + M: hashtable rewrite-literal? drop t ; M: vector rewrite-literal? drop t ; @@ -215,17 +220,20 @@ GENERIC: rewrite-element ( obj -- ) [ rewrite-element ] each ; : rewrite-sequence ( seq -- ) - [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ; + [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ; M: array rewrite-element dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; +M: quotation rewrite-element + dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; + M: vector rewrite-element rewrite-sequence ; M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; M: tuple rewrite-element - [ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ; + [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ; M: local rewrite-element , ; @@ -243,6 +251,10 @@ M: tuple local-rewrite* rewrite-element ; M: hashtable local-rewrite* rewrite-element ; +M: word local-rewrite* + dup { >r r> } memq? + [ >r/r>-in-lambda-error ] [ call-next-method ] if ; + M: object lambda-rewrite* , ; M: object local-rewrite* , ; diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index 3666fa2423..cdd2b49d9c 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -37,9 +37,17 @@ M: wrapper expand-macros* wrapped>> literal ; [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch , ] bi ; -: expand-macro ( quot -- ) - stack [ swap with-datastack >vector ] change - stack get pop >quotation end (expand-macros) ; +: word, ( word -- ) end , ; + +: expand-macro ( word quot -- ) + '[ + drop + stack [ _ with-datastack >vector ] change + stack get pop >quotation end (expand-macros) + ] [ + drop + word, + ] recover ; : expand-macro? ( word -- quot ? ) dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [ @@ -47,11 +55,9 @@ M: wrapper expand-macros* wrapped>> literal ; stack get length <= ] [ 2drop f f ] if ; -: word, ( word -- ) end , ; - M: word expand-macros* dup expand-dispatch? [ drop expand-dispatch ] [ - dup expand-macro? [ nip expand-macro ] [ + dup expand-macro? [ expand-macro ] [ drop word, ] if ] if ; diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 6874b79d2e..ddde4e1244 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -29,6 +29,8 @@ M: word integer-op-input-classes { fixnum- fixnum-fast } { fixnum* fixnum*fast } { fixnum-shift fixnum-shift-fast } + { fixnum/i fixnum/i-fast } + { fixnum/mod fixnum/mod-fast } } at ; : modular-variant ( op -- fast-op ) diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 2af0224e32..f1fd749666 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -216,27 +216,8 @@ M: object pprint* pprint-object ; M: vector pprint* pprint-object ; M: byte-vector pprint* pprint-object ; M: hashtable pprint* pprint-object ; - -GENERIC: valid-callable? ( obj -- ? ) - -M: object valid-callable? drop f ; - -M: quotation valid-callable? drop t ; - -M: curry valid-callable? quot>> valid-callable? ; - -M: compose valid-callable? - [ first>> ] [ second>> ] bi [ valid-callable? ] both? ; - -M: curry pprint* - dup valid-callable? [ pprint-object ] [ - "( invalid curry )" swap present-text - ] if ; - -M: compose pprint* - dup valid-callable? [ pprint-object ] [ - "( invalid compose )" swap present-text - ] if ; +M: curry pprint* pprint-object ; +M: compose pprint* pprint-object ; M: wrapper pprint* dup wrapped>> word? [ 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/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 7fa3c5a1a3..96698fc18f 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -323,10 +323,6 @@ M: class-see-layout class-see-layout ; [ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints) ] unit-test -[ ] [ 1 \ + curry unparse drop ] unit-test - -[ ] [ 1 \ + compose unparse drop ] unit-test - GENERIC: generic-see-test-with-f ( obj -- obj ) M: f generic-see-test-with-f ; @@ -365,8 +361,3 @@ M: started-out-hustlin' ended-up-ballin' ; inline [ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [ [ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer ] unit-test - -[ "( invalid curry )" ] [ 1 2 curry unparse ] unit-test -[ "( invalid curry )" ] [ 1 2 3 curry curry unparse ] unit-test -[ "( invalid compose )" ] [ 1 2 compose unparse ] unit-test -[ "( invalid compose )" ] [ [ 1 ] 2 3 curry compose unparse ] unit-test diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index f8f9680c16..f5778e410f 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -266,7 +266,7 @@ IN: tools.deploy.shaker layouts:tag-numbers layouts:type-numbers lexer-factory - listener:listener-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 d42df93b72..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 ; @@ -453,7 +485,7 @@ editor "caret-motion" f { T{ doc-elt } editor-select-next ; editor "selection" f { - { T{ button-down f { S+ } } extend-selection } + { T{ button-down f { S+ } 1 } extend-selection } { T{ drag } drag-selection } { T{ gain-focus } focus-editor } { T{ lose-focus } unfocus-editor } diff --git a/basis/ui/gadgets/frames/frames.factor b/basis/ui/gadgets/frames/frames.factor index c210d1b7e2..b5c3736896 100644 --- a/basis/ui/gadgets/frames/frames.factor +++ b/basis/ui/gadgets/frames/frames.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic kernel math namespaces sequences words splitting grouping math.vectors ui.gadgets.grids ui.gadgets @@ -11,16 +11,16 @@ TUPLE: frame < grid ; : ( -- grid ) 9 [ ] replicate 3 group ; -: @center 1 1 ; -: @left 0 1 ; -: @right 2 1 ; -: @top 1 0 ; -: @bottom 1 2 ; +: @center 1 1 ; inline +: @left 0 1 ; inline +: @right 2 1 ; inline +: @top 1 0 ; inline +: @bottom 1 2 ; inline -: @top-left 0 0 ; -: @top-right 2 0 ; -: @bottom-left 0 2 ; -: @bottom-right 2 2 ; +: @top-left 0 0 ; inline +: @top-right 2 0 ; inline +: @bottom-left 0 2 ; inline +: @bottom-right 2 2 ; inline : new-frame ( class -- frame ) swap new-grid ; inline @@ -28,13 +28,12 @@ TUPLE: frame < grid ; : ( -- frame ) frame new-frame ; -: (fill-center) ( vec n -- ) - over first pick third v+ [v-] 1 rot set-nth ; +: (fill-center) ( n vec -- ) + [ [ first ] [ third ] bi v+ [v-] ] keep set-second ; -: fill-center ( horiz vert dim -- ) - tuck (fill-center) (fill-center) ; +: fill-center ( dim horiz vert -- ) + [ over ] dip [ (fill-center) ] 2bi@ ; M: frame layout* dup compute-grid - [ rot rect-dim fill-center ] 3keep - grid-layout ; + [ [ rect-dim ] 2dip fill-center ] [ grid-layout ] 3bi ; diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index ef5745809e..c1b3df3857 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -363,7 +363,11 @@ M: f sloppy-pick-up* dup hand-rel over sloppy-pick-up >>caret dup relayout-1 ; -: begin-selection ( pane -- ) move-caret f >>mark drop ; +: begin-selection ( pane -- ) + f >>selecting? + move-caret + f >>mark + drop ; : extend-selection ( pane -- ) hand-moved? [ @@ -389,6 +393,7 @@ M: f sloppy-pick-up* ] if ; : select-to-caret ( pane -- ) + t >>selecting? dup mark>> [ caret>mark ] unless move-caret dup request-focus diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor index 625bfd7880..d6792abd49 100644 --- a/basis/ui/gadgets/scrollers/scrollers-tests.factor +++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor @@ -2,7 +2,8 @@ USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test kernel models models.compose models.range ui.gadgets.viewports ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames ui.gadgets.sliders math math.vectors arrays sequences -tools.test.ui math.geometry.rect accessors ; +tools.test.ui math.geometry.rect accessors ui.gadgets.buttons +ui.gadgets.packs ; IN: ui.gadgets.scrollers.tests [ ] [ @@ -74,7 +75,7 @@ dup layout "g2" get scroll>gadget "s" get layout "s" get scroller-value - ] map [ { 3 0 } = ] all? + ] map [ { 2 0 } = ] all? ] unit-test [ ] [ "Hi"