Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
8909520e51
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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|| ] ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -13,6 +11,6 @@ IN: combinators.short-circuit.smart
|
|||
|
||||
PRIVATE>
|
||||
|
||||
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|| ] ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Marc Fauconneau
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
Notepad2 editor integration
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
DEFER: (shallow-fry)
|
||||
DEFER: shallow-fry
|
||||
: [ncurry] ( n -- quot )
|
||||
{
|
||||
{ 0 [ [ ] ] }
|
||||
{ 1 [ [ curry ] ] }
|
||||
{ 2 [ [ 2curry ] ] }
|
||||
{ 3 [ [ 3curry ] ] }
|
||||
[ \ curry <repetition> ]
|
||||
} 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? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -6,8 +6,11 @@ math.ranges combinators macros quotations fry arrays ;
|
|||
IN: generalizations
|
||||
|
||||
MACRO: nsequence ( n seq -- quot )
|
||||
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
|
||||
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce ;
|
||||
[
|
||||
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
|
||||
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
|
||||
] keep
|
||||
'[ @ _ like ] ;
|
||||
|
||||
MACRO: narray ( n -- quot )
|
||||
'[ _ { } nsequence ] ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 [ ] [
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
<PRIVATE
|
||||
|
||||
HELP: quit-flag
|
||||
{ $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
|
||||
|
||||
HELP: listener-hook
|
||||
{ $var-description "Variable holding a quotation called by the listener before reading an input expression. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ;
|
||||
PRIVATE>
|
||||
|
||||
HELP: read-quot
|
||||
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: quit-flag
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: 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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: title. ( string -- )
|
||||
H{ { foreground T{ rgba f 0.3 0.3 0.3 1 } } } format nl ;
|
||||
|
||||
: visible-vars. ( -- )
|
||||
visible-vars get [
|
||||
nl "--- Watched variables:" title.
|
||||
standard-table-style [
|
||||
[
|
||||
[
|
||||
[ [ short. ] with-cell ]
|
||||
[ [ get short. ] with-cell ]
|
||||
bi
|
||||
] with-row
|
||||
] each
|
||||
] tabular-output
|
||||
] unless-empty ;
|
||||
|
||||
: stacks. ( -- )
|
||||
datastack [ nl "--- Data stack:" title. stack. ] unless-empty
|
||||
retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty ;
|
||||
|
||||
: prompt. ( -- )
|
||||
"( " in get auto-use? get [ " - auto" append ] when " )" 3append
|
||||
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
|
||||
|
||||
: listen ( -- )
|
||||
listener-hook get call prompt.
|
||||
visible-vars. stacks. prompt.
|
||||
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
|
||||
[
|
||||
dup lexer-error? [
|
||||
|
|
@ -62,6 +95,8 @@ SYMBOL: error-hook
|
|||
: until-quit ( -- )
|
||||
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: listener ( -- )
|
||||
[ until-quit ] with-interactive-vocabs ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 -- ... )"
|
||||
|
|
|
|||
|
|
@ -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? ]
|
||||
|
|
|
|||
|
|
@ -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" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: lambda vars body ;
|
||||
|
|
@ -141,20 +147,17 @@ GENERIC: free-vars* ( form -- )
|
|||
: free-vars ( form -- vars )
|
||||
[ free-vars* ] { } make prune ;
|
||||
|
||||
: add-if-free ( object -- )
|
||||
{
|
||||
{ [ dup local-writer? ] [ "local-reader" word-prop , ] }
|
||||
{ [ dup lexical? ] [ , ] }
|
||||
{ [ dup quote? ] [ local>> , ] }
|
||||
{ [ 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* , ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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? [
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <radio-controls> ( parent model assoc quot -- parent )
|
||||
#! quot has stack effect ( value model label -- )
|
||||
swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
|
||||
: <radio-controls> ( 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
|
|||
|
||||
: <radio-buttons> ( model assoc -- gadget )
|
||||
<filled-pile>
|
||||
-rot
|
||||
[ <radio-button> ] <radio-controls>
|
||||
spin [ <radio-button> ] <radio-controls>
|
||||
{ 5 5 } >>gap ;
|
||||
|
||||
: <toggle-button> ( value model label -- gadget )
|
||||
|
|
@ -241,20 +240,19 @@ M: radio-control model-changed
|
|||
|
||||
: <toggle-buttons> ( model assoc -- gadget )
|
||||
<shelf>
|
||||
-rot
|
||||
[ <toggle-button> ] <radio-controls> ;
|
||||
spin [ <toggle-button> ] <radio-controls> ;
|
||||
|
||||
: command-button-quot ( target command -- quot )
|
||||
[ invoke-command drop ] 2curry ;
|
||||
'[ _ _ invoke-command drop ] ;
|
||||
|
||||
: <command-button> ( target gesture command -- button )
|
||||
[ command-string ] keep
|
||||
swapd
|
||||
command-button-quot
|
||||
<bevel-button> ;
|
||||
[ command-string swap ] keep command-button-quot <bevel-button> ;
|
||||
|
||||
: <toolbar> ( target -- toolbar )
|
||||
<shelf>
|
||||
swap
|
||||
"toolbar" over class command-map commands>> swap
|
||||
[ -rot <command-button> add-gadget ] curry assoc-each ;
|
||||
'[ [ _ ] 2dip <command-button> add-gadget ] assoc-each ;
|
||||
|
||||
: add-toolbar ( track -- track )
|
||||
dup <toolbar> f track-add ;
|
||||
|
|
|
|||
|
|
@ -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> ( -- loc ) { 0 0 } <model> ;
|
||||
|
||||
|
|
@ -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 <slice> ;
|
||||
|
||||
: 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 }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
|||
|
||||
: <frame-grid> ( -- grid ) 9 [ <gadget> ] 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 )
|
||||
<frame-grid> swap new-grid ; inline
|
||||
|
|
@ -28,13 +28,12 @@ TUPLE: frame < grid ;
|
|||
: <frame> ( -- 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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" <label> dup "l" set <scroller> "s" set ] unit-test
|
||||
|
|
@ -86,4 +87,22 @@ dup layout
|
|||
[ t ] [ "s" get @right grid-child slider? ] unit-test
|
||||
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
|
||||
|
||||
[ ] [
|
||||
"Click Me" [ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
|
||||
[ <pile> swap add-gadget <scroller> ] keep
|
||||
dup quot>> call
|
||||
layout
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
<gadget> { 200 200 } >>dim
|
||||
[ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
|
||||
dup
|
||||
<pile> swap add-gadget <scroller> { 100 100 } >>dim dup layout
|
||||
swap dup quot>> call
|
||||
dup layout
|
||||
model>> dependencies>> [ range-max value>> ] map
|
||||
viewport-gap 2 v*n =
|
||||
] unit-test
|
||||
|
||||
\ <scroller> must-infer
|
||||
|
|
|
|||
|
|
@ -3,9 +3,8 @@
|
|||
USING: accessors arrays ui.gadgets ui.gadgets.viewports
|
||||
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
|
||||
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
|
||||
models models.range models.compose
|
||||
combinators math.vectors classes.tuple math.geometry.rect
|
||||
combinators.short-circuit ;
|
||||
models models.range models.compose combinators math.vectors
|
||||
classes.tuple math.geometry.rect combinators.short-circuit ;
|
||||
IN: ui.gadgets.scrollers
|
||||
|
||||
TUPLE: scroller < frame viewport x y follows ;
|
||||
|
|
@ -22,9 +21,10 @@ TUPLE: scroller < frame viewport x y follows ;
|
|||
: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
|
||||
|
||||
: do-mouse-scroll ( scroller -- )
|
||||
scroll-direction get-global first2
|
||||
pick y>> slide-by-line
|
||||
swap x>> slide-by-line ;
|
||||
scroll-direction get-global
|
||||
[ first swap x>> slide-by-line ]
|
||||
[ second swap y>> slide-by-line ]
|
||||
2bi ;
|
||||
|
||||
scroller H{
|
||||
{ T{ mouse-scroll } [ do-mouse-scroll ] }
|
||||
|
|
@ -49,8 +49,8 @@ scroller H{
|
|||
|
||||
: scroll ( value scroller -- )
|
||||
[
|
||||
dup viewport>> rect-dim { 0 0 }
|
||||
rot viewport>> viewport-dim 4array flip
|
||||
viewport>> [ rect-dim { 0 0 } ] [ viewport-dim ] bi
|
||||
4array flip
|
||||
] keep
|
||||
2dup control-value = [ 2drop ] [ set-control-value ] if ;
|
||||
|
||||
|
|
@ -58,15 +58,14 @@ scroller H{
|
|||
[ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
|
||||
|
||||
: (scroll>rect) ( rect scroller -- )
|
||||
[
|
||||
scroller-value vneg offset-rect
|
||||
viewport-gap offset-rect
|
||||
] keep
|
||||
[ viewport>> dim>> rect-min ] keep
|
||||
[
|
||||
viewport>> 2rect-extent
|
||||
[ v- { 1 1 } v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+
|
||||
] keep dup scroller-value rot v+ swap scroll ;
|
||||
[ [ loc>> { 1 1 } v- ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
|
||||
{
|
||||
[ scroller-value vneg offset-rect viewport-gap offset-rect ]
|
||||
[ viewport>> dim>> rect-min ]
|
||||
[ viewport>> 2rect-extent [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+ ]
|
||||
[ scroller-value v+ ]
|
||||
[ scroll ]
|
||||
} cleave ;
|
||||
|
||||
: relative-scroll-rect ( rect gadget scroller -- newrect )
|
||||
viewport>> gadget-child relative-loc offset-rect ;
|
||||
|
|
@ -81,14 +80,17 @@ scroller H{
|
|||
[ relative-scroll-rect ] keep
|
||||
swap >>follows
|
||||
relayout
|
||||
] [
|
||||
3drop
|
||||
] if ;
|
||||
] [ 3drop ] if ;
|
||||
|
||||
: (update-scroller) ( scroller -- )
|
||||
[ scroller-value ] keep scroll ;
|
||||
|
||||
: (scroll>gadget) ( gadget scroller -- )
|
||||
>r { 0 0 } over pref-dim <rect> swap r>
|
||||
[ relative-scroll-rect ] keep
|
||||
(scroll>rect) ;
|
||||
2dup swap child? [
|
||||
[ [ pref-dim { 0 0 } swap <rect> ] keep ] dip
|
||||
[ relative-scroll-rect ] keep
|
||||
(scroll>rect)
|
||||
] [ f >>follows (update-scroller) drop ] if ;
|
||||
|
||||
: scroll>gadget ( gadget -- )
|
||||
dup find-scroller* dup [
|
||||
|
|
@ -99,7 +101,7 @@ scroller H{
|
|||
] if ;
|
||||
|
||||
: (scroll>bottom) ( scroller -- )
|
||||
dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
|
||||
[ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
|
||||
|
||||
: scroll>bottom ( gadget -- )
|
||||
find-scroller [ t >>follows relayout-1 ] when* ;
|
||||
|
|
@ -115,19 +117,19 @@ M: gadget update-scroller swap (scroll>gadget) ;
|
|||
|
||||
M: rect update-scroller swap (scroll>rect) ;
|
||||
|
||||
M: f update-scroller drop dup scroller-value swap scroll ;
|
||||
M: f update-scroller drop (update-scroller) ;
|
||||
|
||||
M: scroller layout*
|
||||
dup call-next-method
|
||||
dup follows>>
|
||||
2dup update-scroller
|
||||
>>follows drop ;
|
||||
[ call-next-method ] [
|
||||
dup follows>>
|
||||
[ update-scroller ] [ >>follows drop ] 2bi
|
||||
] bi ;
|
||||
|
||||
M: scroller focusable-child*
|
||||
viewport>> ;
|
||||
|
||||
M: scroller model-changed
|
||||
nip f >>follows drop ;
|
||||
f >>follows 2drop ;
|
||||
|
||||
TUPLE: limited-scroller < scroller
|
||||
{ min-dim initial: { 0 0 } }
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ M: value-ref finish-editing
|
|||
: <slot-editor> ( ref -- gadget )
|
||||
{ 0 1 } slot-editor new-track
|
||||
swap >>ref
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
<source-editor> >>text
|
||||
dup text>> <scroller> 1 track-add
|
||||
dup revert ;
|
||||
|
|
|
|||
|
|
@ -14,3 +14,10 @@ IN: ui.gadgets.tracks.tests
|
|||
<gadget> { 100 100 } >>dim 1 track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
||||
[ { 10 10 } ] [
|
||||
{ 0 1 } <track>
|
||||
<gadget> { 10 10 } >>dim 1 track-add
|
||||
<gadget> { 10 10 } >>dim 0 track-add
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -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+ ;
|
||||
|
|
|
|||
|
|
@ -21,9 +21,11 @@ TUPLE: viewport < gadget ;
|
|||
swap add-gadget ;
|
||||
|
||||
M: viewport layout*
|
||||
dup rect-dim viewport-gap 2 v*n v-
|
||||
over gadget-child pref-dim vmax
|
||||
swap gadget-child (>>dim) ;
|
||||
[
|
||||
[ rect-dim viewport-gap 2 v*n v- ]
|
||||
[ gadget-child pref-dim ]
|
||||
bi vmax
|
||||
] [ gadget-child ] bi (>>dim) ;
|
||||
|
||||
M: viewport focusable-child*
|
||||
gadget-child ;
|
||||
|
|
|
|||
|
|
@ -30,7 +30,7 @@ ERROR: no-world-found ;
|
|||
|
||||
: (request-focus) ( child world ? -- )
|
||||
pick parent>> pick eq? [
|
||||
>r >r dup parent>> dup r> r>
|
||||
[ dup parent>> dup ] 2dip
|
||||
[ (request-focus) ] keep
|
||||
] unless focus-child ;
|
||||
|
||||
|
|
@ -80,7 +80,7 @@ SYMBOL: ui-error-hook
|
|||
: ui-error ( error -- )
|
||||
ui-error-hook get [ call ] [ print-error ] if* ;
|
||||
|
||||
[ rethrow ] ui-error-hook set-global
|
||||
ui-error-hook global [ [ rethrow ] or ] change-at
|
||||
|
||||
: draw-world ( world -- )
|
||||
dup draw-world? [
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <help-pane> ( browser-gadget -- gadget )
|
||||
history>> [ [ help ] curry try ] <pane-control> ;
|
||||
history>> [ '[ _ print-topic ] try ] <pane-control> ;
|
||||
|
||||
: init-history ( browser-gadget -- )
|
||||
"handbook" >link <history> >>history drop ;
|
||||
|
|
@ -22,7 +22,7 @@ TUPLE: browser-gadget < track pane history ;
|
|||
: <browser-gadget> ( -- gadget )
|
||||
{ 0 1 } browser-gadget new-track
|
||||
dup init-history
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
dup <help-pane> >>pane
|
||||
dup pane>> <scroller> 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>>
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ TUPLE: debugger < track restarts ;
|
|||
|
||||
: <debugger> ( error restarts restart-hook -- gadget )
|
||||
{ 0 1 } debugger new-track
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
-rot <restart-list> >>restarts
|
||||
dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
|
||||
|
||||
|
|
@ -35,7 +35,15 @@ M: debugger focusable-child* restarts>> ;
|
|||
#! No restarts for the debugger window
|
||||
f [ drop ] <debugger> "Error" open-window ;
|
||||
|
||||
[ debugger-window ] ui-error-hook set-global
|
||||
GENERIC: error-in-debugger? ( error -- ? )
|
||||
|
||||
M: world-error error-in-debugger? world>> gadget-child debugger? ;
|
||||
|
||||
M: object error-in-debugger? drop f ;
|
||||
|
||||
[
|
||||
dup error-in-debugger? [ rethrow ] [ debugger-window ] if
|
||||
] ui-error-hook set-global
|
||||
|
||||
M: world-error error.
|
||||
"An error occurred while drawing the world " write
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ TUPLE: inspector-gadget < track object pane ;
|
|||
|
||||
: <inspector-gadget> ( -- gadget )
|
||||
{ 0 1 } inspector-gadget new-track
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
<scrolling-pane> >>output
|
||||
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
|
||||
<scrolling-pane>
|
||||
[ >>output ] [ <scroller> 1 track-add ] bi ;
|
||||
|
||||
: listener-streams ( listener -- input output )
|
||||
[ input>> ] [ output>> <pane-stream> ] bi ;
|
||||
|
|
@ -23,17 +24,13 @@ TUPLE: listener-gadget < track input output stack ;
|
|||
output>> <pane-stream> <interactor> ;
|
||||
|
||||
: listener-input, ( listener -- listener )
|
||||
dup <listener-input> >>input
|
||||
dup input>>
|
||||
<limited-scroller>
|
||||
{ 0 100 } >>min-dim
|
||||
{ 1/0. 100 } >>max-dim
|
||||
"Input" <labelled-gadget>
|
||||
f track-add ;
|
||||
dup <listener-input>
|
||||
[ >>input ] [ 1 <border> { 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 ;
|
||||
|
||||
: <stack-display> ( workspace -- gadget )
|
||||
listener>>
|
||||
{ 0 1 } stack-display new-track
|
||||
over <toolbar> f track-add
|
||||
swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
|
||||
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 <model> >>stack drop ;
|
||||
|
||||
: <listener-gadget> ( -- 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 -- ? )
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ TUPLE: profiler-gadget < track pane ;
|
|||
|
||||
: <profiler-gadget> ( -- gadget )
|
||||
{ 0 1 } profiler-gadget new-track
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
<pane> >>pane
|
||||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
: <search-model> ( live-search producer -- live-search filter )
|
||||
>r dup field>> model>> ! live-search model :: producer
|
||||
ui-running? [ 1/5 seconds <delay> ] when
|
||||
[ "\n" join ] r> append <filter> ;
|
||||
: <search-model> ( live-search producer -- filter )
|
||||
[
|
||||
field>> model>>
|
||||
ui-running? [ 1/5 seconds <delay> ] when
|
||||
] dip [ "\n" join ] prepend <filter> ;
|
||||
|
||||
: <search-list> ( live-search seq limited? presenter -- live-search list )
|
||||
>r
|
||||
[ limited-completions ] [ completions ] ? curry
|
||||
<search-model>
|
||||
>r [ find-workspace hide-popup ] r> r>
|
||||
swap <list> ;
|
||||
: init-search-model ( live-search seq limited? -- live-search )
|
||||
[ 2drop ]
|
||||
[ [ limited-completions ] [ completions ] ? curry <search-model> ] 3bi
|
||||
>>model ; inline
|
||||
|
||||
: <live-search> ( string seq limited? presenter -- gadget )
|
||||
: <search-list> ( presenter live-search -- list )
|
||||
[ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* <list> ;
|
||||
|
||||
:: <live-search> ( string seq limited? presenter -- gadget )
|
||||
{ 0 1 } live-search new-track
|
||||
<search-field> >>field
|
||||
dup field>> f track-add
|
||||
-roll <search-list> >>list
|
||||
seq limited? init-search-model
|
||||
presenter over <search-list> >>list
|
||||
dup field>> 1 <border> { 1 1 } >>fill f track-add
|
||||
dup list>> <scroller> 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 ;
|
||||
|
||||
: <definition-search> ( string words limited? -- gadget )
|
||||
>r definition-candidates r> [ synopsis ] <live-search> ;
|
||||
[ definition-candidates ] dip [ synopsis ] <live-search> ;
|
||||
|
||||
: word-candidates ( words -- candidates )
|
||||
[ dup name>> >lower ] { } map>assoc ;
|
||||
|
||||
: <word-search> ( string words limited? -- gadget )
|
||||
>r word-candidates r> [ synopsis ] <live-search> ;
|
||||
[ word-candidates ] dip [ synopsis ] <live-search> ;
|
||||
|
||||
: com-words ( workspace -- )
|
||||
dup current-word all-words t <word-search>
|
||||
"Word search" show-titled-popup ;
|
||||
|
||||
: show-vocab-words ( workspace vocab -- )
|
||||
"" over words natural-sort f <word-search>
|
||||
"Words in " rot vocab-name append show-titled-popup ;
|
||||
[ "" swap words natural-sort f <word-search> ]
|
||||
[ "Words in " swap vocab-name append ]
|
||||
bi show-titled-popup ;
|
||||
|
||||
: show-word-usage ( workspace word -- )
|
||||
"" over smart-usage f <definition-search>
|
||||
"Words and methods using " rot name>> append
|
||||
show-titled-popup ;
|
||||
[ "" swap smart-usage f <definition-search> ]
|
||||
[ "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-file-search>
|
||||
"Source files in " rot vocab-name append show-titled-popup ;
|
||||
[ "" swap vocab-files <source-file-search> ]
|
||||
[ "Source files in " swap vocab-name append ]
|
||||
bi show-titled-popup ;
|
||||
|
||||
: vocab-candidates ( -- candidates )
|
||||
all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -19,8 +19,7 @@ IN: ui.tools
|
|||
<toggle-buttons> ;
|
||||
|
||||
: <workspace-book> ( workspace -- gadget )
|
||||
dup
|
||||
<stack-display>
|
||||
<gadget>
|
||||
<browser-gadget>
|
||||
<inspector-gadget>
|
||||
<profiler-gadget>
|
||||
|
|
@ -34,14 +33,14 @@ IN: ui.tools
|
|||
dup <workspace-book> >>book
|
||||
|
||||
dup <workspace-tabs> f track-add
|
||||
dup book>> 1/5 track-add
|
||||
dup listener>> 4/5 track-add
|
||||
dup <toolbar> 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 }
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
|
|||
|
||||
dup model>> <callstack-display> 2/3 track-add
|
||||
|
||||
dup <toolbar> f track-add ;
|
||||
add-toolbar ;
|
||||
|
||||
: <namestack-display> ( model -- gadget )
|
||||
[ [ name>> namestack. ] when* ]
|
||||
|
|
|
|||
|
|
@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
|
|||
swap >>status
|
||||
dup continuation>> <traceback-gadget> >>traceback
|
||||
|
||||
dup <toolbar> f track-add
|
||||
add-toolbar
|
||||
dup status>> self <thread-status> f track-add
|
||||
dup traceback>> 1 track-add ;
|
||||
dup traceback>> 1 track-add ;
|
||||
|
||||
: walker-help ( -- ) "ui-walker" help-window ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -129,8 +129,8 @@ SYMBOL: ui-hook
|
|||
|
||||
: notify ( gadget -- )
|
||||
dup graft-state>>
|
||||
dup first { f f } { t t } ?
|
||||
pick (>>graft-state) {
|
||||
[ first { f f } { t t } ? >>graft-state ] keep
|
||||
{
|
||||
{ { f t } [ dup activate-control graft* ] }
|
||||
{ { t f } [ dup deactivate-control ungraft* ] }
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -185,7 +185,7 @@ M: world client-event
|
|||
|
||||
M: x11-ui-backend do-events
|
||||
wait-event dup XAnyEvent-window window dup
|
||||
[ [ 2dup handle-event ] assert-depth ] when 2drop ;
|
||||
[ [ [ 2dup handle-event ] ui-try ] assert-depth ] when 2drop ;
|
||||
|
||||
: x-clipboard@ ( gadget clipboard -- prop win )
|
||||
atom>> swap
|
||||
|
|
|
|||
|
|
@ -303,7 +303,13 @@ tuple
|
|||
[ f "inline" set-word-prop ]
|
||||
[ make-flushable ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ]
|
||||
[
|
||||
[
|
||||
callable instance-check-quot %
|
||||
tuple-layout ,
|
||||
\ <tuple-boa> ,
|
||||
] [ ] make
|
||||
]
|
||||
} cleave
|
||||
(( obj quot -- curry )) define-declared
|
||||
|
||||
|
|
@ -319,7 +325,16 @@ tuple
|
|||
[ f "inline" set-word-prop ]
|
||||
[ make-flushable ]
|
||||
[ ]
|
||||
[ tuple-layout [ <tuple-boa> ] curry ]
|
||||
[
|
||||
[
|
||||
\ >r ,
|
||||
callable instance-check-quot %
|
||||
\ r> ,
|
||||
callable instance-check-quot %
|
||||
tuple-layout ,
|
||||
\ <tuple-boa> ,
|
||||
] [ ] make
|
||||
]
|
||||
} cleave
|
||||
(( quot1 quot2 -- compose )) define-declared
|
||||
|
||||
|
|
@ -341,6 +356,8 @@ tuple
|
|||
{ "fixnum-bitnot" "math.private" }
|
||||
{ "fixnum-mod" "math.private" }
|
||||
{ "fixnum-shift-fast" "math.private" }
|
||||
{ "fixnum/i-fast" "math.private" }
|
||||
{ "fixnum/mod-fast" "math.private" }
|
||||
{ "fixnum<" "math.private" }
|
||||
{ "fixnum<=" "math.private" }
|
||||
{ "fixnum>" "math.private" }
|
||||
|
|
|
|||
|
|
@ -121,7 +121,7 @@ ERROR: bad-superclass class ;
|
|||
[
|
||||
\ dup ,
|
||||
[ "predicate" word-prop % ]
|
||||
[ [ bad-slot-value ] curry , ] bi
|
||||
[ [ literalize , \ bad-slot-value , ] [ ] make , ] bi
|
||||
\ unless ,
|
||||
] [ ] make ;
|
||||
|
||||
|
|
|
|||
|
|
@ -28,10 +28,7 @@ IN: combinators
|
|||
|
||||
! spread
|
||||
: spread>quot ( seq -- quot )
|
||||
[ ] [
|
||||
[ dup empty? [ [ >r ] swap [ r> ] 3append ] unless ] dip
|
||||
append
|
||||
] reduce ;
|
||||
[ ] [ [ dup empty? [ [ dip ] curry ] unless ] dip append ] reduce ;
|
||||
|
||||
: spread ( objs... seq -- )
|
||||
spread>quot call ;
|
||||
|
|
|
|||
|
|
@ -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" } "." } ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: arrays math parser tools.test kernel generic words
|
|||
io.streams.string namespaces classes effects source-files
|
||||
assocs sequences strings io.files definitions continuations
|
||||
sorting classes.tuple compiler.units debugger vocabs
|
||||
vocabs.loader accessors eval combinators ;
|
||||
vocabs.loader accessors eval combinators lexer ;
|
||||
IN: parser.tests
|
||||
|
||||
[
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
[ <no-word-error> throw-restarts no-word-restarted ]
|
||||
if ;
|
||||
|
|
|
|||
|
|
@ -15,4 +15,4 @@ IN: quotations.tests
|
|||
|
||||
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
|
||||
|
||||
! [ 1 \ + curry ] must-fail
|
||||
[ 1 \ + curry ] must-fail
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
|
||||
USING: combinators.short-circuit kernel namespaces
|
||||
USING: kernel namespaces
|
||||
math
|
||||
math.constants
|
||||
math.functions
|
||||
|
|
@ -10,6 +10,7 @@ USING: combinators.short-circuit kernel namespaces
|
|||
math.physics.vel
|
||||
combinators arrays sequences random vars
|
||||
combinators.lib
|
||||
combinators.short-circuit
|
||||
accessors ;
|
||||
|
||||
IN: boids
|
||||
|
|
@ -156,7 +157,7 @@ VAR: separation-radius
|
|||
2&& ;
|
||||
|
||||
: alignment-neighborhood ( self -- boids )
|
||||
boids> [ within-alignment-neighborhood? ] with filter ;
|
||||
boids> [ within-alignment-neighborhood? ] with filter ;
|
||||
|
||||
: alignment-force ( self -- force )
|
||||
alignment-neighborhood
|
||||
|
|
|
|||
|
|
@ -1,43 +0,0 @@
|
|||
|
||||
USING: kernel namespaces sequences math
|
||||
listener io prettyprint sequences.lib bake bake.fry ;
|
||||
|
||||
IN: display-stack
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: watched-variables
|
||||
|
||||
: watch-var ( sym -- ) watched-variables get push ;
|
||||
|
||||
: watch-vars ( seq -- ) watched-variables get [ push ] curry each ;
|
||||
|
||||
: unwatch-var ( sym -- ) watched-variables get delete ;
|
||||
|
||||
: unwatch-vars ( seq -- ) watched-variables get [ delete ] curry each ;
|
||||
|
||||
: print-watched-variables ( -- )
|
||||
watched-variables get length 0 >
|
||||
[
|
||||
"----------" print
|
||||
watched-variables get
|
||||
watched-variables get [ unparse ] map longest length 2 +
|
||||
'[ [ unparse ": " append , 32 pad-right write ] [ get . ] bi ]
|
||||
each
|
||||
|
||||
]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: display-stack ( -- )
|
||||
V{ } clone watched-variables set
|
||||
[
|
||||
print-watched-variables
|
||||
"----------" print
|
||||
datastack [ . ] each
|
||||
"----------" print
|
||||
retainstack reverse [ . ] each
|
||||
]
|
||||
listener-hook set ;
|
||||
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
USING: kernel ;
|
||||
|
||||
REQUIRES: libs/calendar libs/shuffle ;
|
||||
|
||||
PROVIDE: libs/io
|
||||
{ +files+ {
|
||||
"io.factor"
|
||||
"mmap.factor"
|
||||
"shell.factor"
|
||||
{ "os-unix.factor" [ unix? ] }
|
||||
{ "os-unix-shell.factor" [ unix? ] }
|
||||
{ "mmap-os-unix.factor" [ unix? ] }
|
||||
|
||||
{ "os-winnt.factor" [ winnt? ] }
|
||||
{ "os-winnt-shell.factor" [ winnt? ] }
|
||||
{ "mmap-os-winnt.factor" [ winnt? ] }
|
||||
|
||||
{ "os-wince.factor" [ wince? ] }
|
||||
} }
|
||||
{ +tests+ {
|
||||
"test/io.factor"
|
||||
"test/mmap.factor"
|
||||
} } ;
|
||||
|
||||
|
|
@ -1,46 +0,0 @@
|
|||
USING: arrays kernel libs-io sequences prettyprint unix-internals
|
||||
calendar namespaces math ;
|
||||
USE: io
|
||||
IN: shell
|
||||
|
||||
TUPLE: unix-shell ;
|
||||
|
||||
T{ unix-shell } \ shell set-global
|
||||
|
||||
TUPLE: file name mode nlink uid gid size mtime symbol ;
|
||||
|
||||
M: unix-shell directory* ( path -- seq )
|
||||
dup (directory) [ tuck >r "/" r> 3append stat* 2array ] map-with ;
|
||||
|
||||
M: unix-shell make-file ( path -- file )
|
||||
first2
|
||||
[ stat-mode ] keep
|
||||
[ stat-nlink ] keep
|
||||
[ stat-uid ] keep
|
||||
[ stat-gid ] keep
|
||||
[ stat-size ] keep
|
||||
[ stat-mtime timespec>timestamp >local-time ] keep
|
||||
stat-mode mode>symbol <file> ;
|
||||
|
||||
M: unix-shell file. ( file -- )
|
||||
[ [ file-mode >oct write ] keep ] with-cell
|
||||
[ bl ] with-cell
|
||||
[ [ file-nlink unparse write ] keep ] with-cell
|
||||
[ bl ] with-cell
|
||||
[ [ file-uid unparse write ] keep ] with-cell
|
||||
[ bl ] with-cell
|
||||
[ [ file-gid unparse write ] keep ] with-cell
|
||||
[ bl ] with-cell
|
||||
[ [ file-size unparse write ] keep ] with-cell
|
||||
[ bl ] with-cell
|
||||
[ [ file-mtime file-time-string write ] keep ] with-cell
|
||||
[ bl ] with-cell
|
||||
[ file-name write ] with-cell ;
|
||||
|
||||
USE: unix-internals
|
||||
M: unix-shell touch-file ( path -- )
|
||||
dup open-append dup -1 = [
|
||||
drop now dup set-file-times
|
||||
] [
|
||||
nip [ now dup set-file-times* ] keep close
|
||||
] if ;
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays calendar errors io io-internals kernel
|
||||
math nonblocking-io sequences unix-internals unix-io ;
|
||||
IN: libs-io
|
||||
|
||||
: O_APPEND HEX: 100 ; inline
|
||||
: O_EXCL HEX: 800 ; inline
|
||||
: SEEK_SET 0 ; inline
|
||||
: SEEK_CUR 1 ; inline
|
||||
: SEEK_END 2 ; inline
|
||||
: EEXIST 17 ; inline
|
||||
|
||||
: mode>symbol ( mode -- ch )
|
||||
S_IFMT bitand
|
||||
{
|
||||
{ [ dup S_IFDIR = ] [ drop "/" ] }
|
||||
{ [ dup S_IFIFO = ] [ drop "|" ] }
|
||||
{ [ dup S_IXUSR = ] [ drop "*" ] }
|
||||
{ [ dup S_IFLNK = ] [ drop "@" ] }
|
||||
{ [ dup S_IFWHT = ] [ drop "%" ] }
|
||||
{ [ dup S_IFSOCK = ] [ drop "=" ] }
|
||||
{ [ t ] [ drop "" ] }
|
||||
} cond ;
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
USING: alien calendar io io-internals kernel libs-io math
|
||||
namespaces prettyprint sequences windows-api ;
|
||||
IN: shell
|
||||
|
||||
TUPLE: winnt-shell ;
|
||||
|
||||
T{ winnt-shell } \ shell set-global
|
||||
|
||||
TUPLE: file name size mtime attributes ;
|
||||
|
||||
: ((directory*)) ( handle -- )
|
||||
"WIN32_FIND_DATA" <c-object> [ FindNextFile ] 2keep
|
||||
rot zero? [ 2drop ] [ , ((directory*)) ] if ;
|
||||
|
||||
: (directory*) ( path -- )
|
||||
"WIN32_FIND_DATA" <c-object> [
|
||||
FindFirstFile dup INVALID_HANDLE_VALUE = [
|
||||
win32-error
|
||||
] when
|
||||
] keep ,
|
||||
[ ((directory*)) ] keep FindClose win32-error=0/f ;
|
||||
|
||||
: append-star ( path -- path )
|
||||
dup peek CHAR: \\ = "*" "\\*" ? append ;
|
||||
|
||||
M: winnt-shell directory* ( path -- seq )
|
||||
normalize-pathname append-star [ (directory*) ] { } make ;
|
||||
|
||||
: WIN32_FIND_DATA>file-size ( WIN32_FILE_ATTRIBUTE_DATA -- n )
|
||||
[ WIN32_FIND_DATA-nFileSizeLow ] keep
|
||||
WIN32_FIND_DATA-nFileSizeHigh 32 shift + ;
|
||||
|
||||
M: winnt-shell make-file ( WIN32_FIND_DATA -- file )
|
||||
[ WIN32_FIND_DATA-cFileName alien>u16-string ] keep
|
||||
[ WIN32_FIND_DATA>file-size ] keep
|
||||
[
|
||||
WIN32_FIND_DATA-ftCreationTime
|
||||
FILETIME>timestamp >local-time
|
||||
] keep
|
||||
WIN32_FIND_DATA-dwFileAttributes <file> ;
|
||||
|
||||
M: winnt-shell file. ( file -- )
|
||||
[ [ file-attributes >oct write ] keep ] with-cell
|
||||
[ bl ] with-cell
|
||||
[ [ file-size unparse write ] keep ] with-cell
|
||||
[ bl ] with-cell
|
||||
[ [ file-mtime file-time-string write ] keep ] with-cell
|
||||
[ bl ] with-cell
|
||||
[ file-name write ] with-cell ;
|
||||
|
||||
M: winnt-shell touch-file ( path -- )
|
||||
#! Set the file write time to 'now'
|
||||
normalize-pathname
|
||||
dup maybe-create-file [ drop ] [ now set-file-write-time ] if ;
|
||||
|
||||
|
|
@ -1,96 +0,0 @@
|
|||
USING: alien calendar errors generic io io-internals kernel
|
||||
math namespaces nonblocking-io parser quotations sequences
|
||||
shuffle windows-api words ;
|
||||
IN: libs-io
|
||||
|
||||
: stat* ( path -- WIN32_FIND_DATA )
|
||||
"WIN32_FIND_DATA" <c-object>
|
||||
[
|
||||
FindFirstFile
|
||||
[ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep
|
||||
FindClose win32-error=0/f
|
||||
] keep ;
|
||||
|
||||
: set-file-time ( path timestamp/f timestamp/f timestamp/f -- )
|
||||
#! timestamp order: creation access write
|
||||
>r >r >r open-existing dup r> r> r>
|
||||
[ timestamp>FILETIME ] 3 napply
|
||||
SetFileTime win32-error=0/f
|
||||
close-handle ;
|
||||
|
||||
: set-file-times ( path timestamp/f timestamp/f -- )
|
||||
f -rot set-file-time ;
|
||||
|
||||
: set-file-create-time ( path timestamp -- )
|
||||
f f set-file-time ;
|
||||
|
||||
: set-file-access-time ( path timestamp -- )
|
||||
>r f r> f set-file-time ;
|
||||
|
||||
: set-file-write-time ( path timestamp -- )
|
||||
>r f f r> set-file-time ;
|
||||
|
||||
: maybe-make-filetime ( ? -- FILETIME/f )
|
||||
[ "FILETIME" <c-object> ] [ f ] if ;
|
||||
|
||||
: file-time ( path ? ? ? -- FILETIME/f FILETIME/f FILETIME/f )
|
||||
>r >r >r open-existing dup r> r> r>
|
||||
[ maybe-make-filetime ] 3 napply
|
||||
[ GetFileTime win32-error=0/f close-handle ] 3keep ;
|
||||
|
||||
: file-times ( path -- FILETIME FILETIME FILETIME )
|
||||
t t t file-time [ FILETIME>timestamp ] 3 napply ;
|
||||
|
||||
: file-create-time ( path -- FILETIME )
|
||||
t f f file-time 2drop FILETIME>timestamp ;
|
||||
|
||||
: file-access-time ( path -- FILETIME )
|
||||
f t f file-time drop nip FILETIME>timestamp ;
|
||||
|
||||
: file-write-time ( path -- FILETIME )
|
||||
f f t file-time 2nip FILETIME>timestamp ;
|
||||
|
||||
: attrib ( path -- n )
|
||||
[ stat* WIN32_FIND_DATA-dwFileAttributes ] catch
|
||||
[ drop 0 ] when ;
|
||||
|
||||
: (read-only?) ( mode -- ? )
|
||||
FILE_ATTRIBUTE_READONLY bit-set? ;
|
||||
|
||||
: read-only? ( path -- ? )
|
||||
attrib (read-only?) ;
|
||||
|
||||
: (hidden?) ( mode -- ? )
|
||||
FILE_ATTRIBUTE_HIDDEN bit-set? ;
|
||||
|
||||
: hidden? ( path -- ? )
|
||||
attrib (hidden?) ;
|
||||
|
||||
: (system?) ( mode -- ? )
|
||||
FILE_ATTRIBUTE_SYSTEM bit-set? ;
|
||||
|
||||
: system? ( path -- ? )
|
||||
attrib (system?) ;
|
||||
|
||||
: (directory?) ( mode -- ? )
|
||||
FILE_ATTRIBUTE_DIRECTORY bit-set? ;
|
||||
|
||||
: directory? ( path -- ? )
|
||||
attrib (directory?) ;
|
||||
|
||||
: (archive?) ( mode -- ? )
|
||||
FILE_ATTRIBUTE_ARCHIVE bit-set? ;
|
||||
|
||||
: archive? ( path -- ? )
|
||||
attrib (archive?) ;
|
||||
|
||||
! FILE_ATTRIBUTE_DEVICE
|
||||
! FILE_ATTRIBUTE_NORMAL
|
||||
! FILE_ATTRIBUTE_TEMPORARY
|
||||
! FILE_ATTRIBUTE_SPARSE_FILE
|
||||
! FILE_ATTRIBUTE_REPARSE_POINT
|
||||
! FILE_ATTRIBUTE_COMPRESSED
|
||||
! FILE_ATTRIBUTE_OFFLINE
|
||||
! FILE_ATTRIBUTE_NOT_CONTENT_INDEXED
|
||||
! FILE_ATTRIBUTE_ENCRYPTED
|
||||
|
||||
|
|
@ -1,40 +0,0 @@
|
|||
USING: calendar io io-internals kernel math namespaces
|
||||
nonblocking-io prettyprint quotations sequences ;
|
||||
IN: shell
|
||||
|
||||
SYMBOL: shell
|
||||
HOOK: directory* shell ( path -- seq )
|
||||
HOOK: make-file shell ( bytes -- file )
|
||||
HOOK: file. shell ( file -- )
|
||||
HOOK: touch-file shell ( path -- )
|
||||
|
||||
: (ls) ( path -- )
|
||||
>r H{ } r> directory*
|
||||
[
|
||||
[ [ make-file file. ] with-row ] each
|
||||
] curry tabular-output ;
|
||||
|
||||
: ls ( -- )
|
||||
cwd (ls) ;
|
||||
|
||||
: pwd ( -- )
|
||||
cwd pprint nl ;
|
||||
|
||||
: (slurp) ( quot -- )
|
||||
>r default-buffer-size read r> over [
|
||||
dup slip (slurp)
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: slurp ( stream quot -- )
|
||||
[ (slurp) ] curry with-stream ;
|
||||
|
||||
: cat ( path -- )
|
||||
<file-reader> stdio get
|
||||
duplex-stream-out <duplex-stream>
|
||||
[ write ] slurp ;
|
||||
|
||||
: copy-file ( path path -- )
|
||||
>r <file-reader> r>
|
||||
<file-writer> <duplex-stream> [ write ] slurp ;
|
||||
|
|
@ -1,42 +0,0 @@
|
|||
USING: calendar errors io kernel libs-io math namespaces sequences
|
||||
shell test ;
|
||||
IN: temporary
|
||||
|
||||
SYMBOL: file "file-appender-test.txt" \ file set
|
||||
[ \ file get delete-file ] catch drop
|
||||
[ f ] [ \ file get exists? ] unit-test
|
||||
\ file get <file-appender> [ "asdf" write ] with-stream
|
||||
[ t ] [ \ file get exists? ] unit-test
|
||||
[ 4 ] [ \ file get file-length ] unit-test
|
||||
\ file get <file-appender> [ "jkl;" write ] with-stream
|
||||
[ t ] [ \ file get exists? ] unit-test
|
||||
[ 8 ] [ \ file get file-length ] unit-test
|
||||
[ "asdfjkl;" ] [ \ file get <file-reader> contents ] unit-test
|
||||
\ file get delete-file
|
||||
[ f ] [ \ file get exists? ] unit-test
|
||||
|
||||
SYMBOL: directory "test-directory" \ directory set
|
||||
\ directory get create-directory
|
||||
[ t ] [ \ directory get directory? ] unit-test
|
||||
\ directory get delete-directory
|
||||
[ f ] [ \ directory get directory? ] unit-test
|
||||
|
||||
SYMBOL: time "time-test.txt" \ time set
|
||||
[ \ time get delete-file ] catch drop
|
||||
\ time get touch-file
|
||||
[ 0 ] [ \ time get file-length ] unit-test
|
||||
[ t ] [ \ time get exists? ] unit-test
|
||||
\ time get 0 unix-time>timestamp dup set-file-times
|
||||
[ t ] [ \ time get file-write-time 0 unix-time>timestamp = ] unit-test
|
||||
[ t ] [ \ time get file-access-time 0 unix-time>timestamp = ] unit-test
|
||||
\ time get touch-file
|
||||
[ t ] [ now \ time get file-write-time timestamp- 10 < ] unit-test
|
||||
\ time get delete-file
|
||||
|
||||
SYMBOL: longname "" 255 CHAR: a pad-left \ longname set
|
||||
\ longname get touch-file
|
||||
[ t ] [ \ longname get exists? ] unit-test
|
||||
[ 0 ] [ \ longname get file-length ] unit-test
|
||||
\ longname get delete-file
|
||||
[ f ] [ \ longname get exists? ] unit-test
|
||||
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
USING: alien errors io kernel libs-io mmap namespaces test ;
|
||||
|
||||
IN: temporary
|
||||
SYMBOL: mmap "mmap-test.txt" \ mmap set
|
||||
|
||||
[ \ mmap get delete-file ] catch drop
|
||||
\ mmap get [
|
||||
"Four" write
|
||||
] with-file-writer
|
||||
|
||||
\ mmap get [
|
||||
>r CHAR: R r> mmap-address 3 set-alien-unsigned-1
|
||||
] with-mmap
|
||||
|
||||
\ mmap get [
|
||||
mmap-address 3 alien-unsigned-1 CHAR: R = [
|
||||
"mmap test failed" throw
|
||||
] unless
|
||||
] with-mmap
|
||||
|
||||
[ \ mmap get delete-file ] catch drop
|
||||
43
vm/math.c
43
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 == tag_fixnum(-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)));
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue