Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
4828ab1a4b
|
|
@ -15,7 +15,7 @@ HELP: fry
|
|||
} ;
|
||||
|
||||
HELP: '[
|
||||
{ $syntax "code... ]" }
|
||||
{ $syntax "'[ code... ]" }
|
||||
{ $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" } "." } ;
|
||||
|
||||
|
|
@ -49,6 +49,8 @@ $nl
|
|||
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
|
||||
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
|
||||
}
|
||||
"The following is a no-op:"
|
||||
{ $code "'[ @ ]" }
|
||||
"Here are some built-in combinators rewritten in terms of fried quotations:"
|
||||
{ $table
|
||||
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
|
||||
|
|
@ -74,18 +76,21 @@ 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." ;
|
||||
|
||||
ARTICLE: "fry" "Fried quotations"
|
||||
"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."
|
||||
"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."
|
||||
$nl
|
||||
"Fried quotations are denoted with a special parsing word:"
|
||||
"Fried quotations are started by a special parsing word:"
|
||||
{ $subsection POSTPONE: '[ }
|
||||
"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":"
|
||||
"There are two types of fry specifiers; the first can hold a value, and the second ``splices'' a quotation, as if it were inserted without surrounding brackets:"
|
||||
{ $subsection _ }
|
||||
{ $subsection @ }
|
||||
"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left."
|
||||
"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
|
||||
{ $subsection "fry.examples" }
|
||||
{ $subsection "fry.philosophy" }
|
||||
{ $subsection "fry.limitations" }
|
||||
"Quotations can also be fried without using a parsing word:"
|
||||
{ $subsection fry } ;
|
||||
"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
|
||||
$nl
|
||||
"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"
|
||||
{ $subsection fry }
|
||||
"Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ;
|
||||
|
||||
ABOUT: "fry"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: help.markup help.syntax io kernel math namespaces parser
|
||||
prettyprint sequences vocabs.loader namespaces stack-checker ;
|
||||
prettyprint sequences vocabs.loader namespaces stack-checker
|
||||
help ;
|
||||
IN: help.cookbook
|
||||
|
||||
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
|
||||
|
|
@ -324,6 +325,19 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
|
|||
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
|
||||
} ;
|
||||
|
||||
ARTICLE: "cookbook-next" "Next steps"
|
||||
"Once you have read through " { $link "first-program" } " and " { $link "cookbook" } ", the best way to keep learning Factor is to start looking at some simple example programs. Here are a few particularly nice vocabularies which should keep you busy for a little while:"
|
||||
{ $list
|
||||
{ $vocab-link "base64" }
|
||||
{ $vocab-link "roman" }
|
||||
{ $vocab-link "rot13" }
|
||||
{ $vocab-link "smtp" }
|
||||
{ $vocab-link "time-server" }
|
||||
{ $vocab-link "tools.hexdump" }
|
||||
{ $vocab-link "webapps.counter" }
|
||||
}
|
||||
"If you see code in there that you do not understand, use " { $link see } " and " { $link help } " to explore." ;
|
||||
|
||||
ARTICLE: "cookbook" "Factor cookbook"
|
||||
"The Factor cookbook is a high-level overview of the most important concepts required to program in Factor."
|
||||
{ $subsection "cookbook-syntax" }
|
||||
|
|
@ -336,6 +350,7 @@ ARTICLE: "cookbook" "Factor cookbook"
|
|||
{ $subsection "cookbook-scripts" }
|
||||
{ $subsection "cookbook-compiler" }
|
||||
{ $subsection "cookbook-philosophy" }
|
||||
{ $subsection "cookbook-pitfalls" } ;
|
||||
{ $subsection "cookbook-pitfalls" }
|
||||
{ $subsection "cookbook-next" } ;
|
||||
|
||||
ABOUT: "cookbook"
|
||||
|
|
|
|||
|
|
@ -65,6 +65,11 @@ $nl
|
|||
{ "word" { "the basic unit of code, analogous to a function or procedure in other programming languages. See " { $link "words" } } }
|
||||
} ;
|
||||
|
||||
ARTICLE: "tail-call-opt" "Tail-call optimization"
|
||||
"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $emphasis "tail-call optimization" } " and the Factor implementation guarantees that it will be performed."
|
||||
$nl
|
||||
"Tail-call optimization allows iterative algorithms to be implemented in an efficient manner using recursion, without the need for any kind of primitive looping construct in the language. However, in practice, most iteration is performed via combinators such as " { $link while } ", " { $link each } ", " { $link map } ", " { $link assoc-each } ", and so on. The definitions of these combinators do bottom-out in recursive words, however." ;
|
||||
|
||||
ARTICLE: "evaluator" "Evaluation semantics"
|
||||
{ $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:"
|
||||
{ $list
|
||||
|
|
@ -72,7 +77,7 @@ ARTICLE: "evaluator" "Evaluation semantics"
|
|||
{ "a " { $link wrapper } " - the wrapped object is pushed on the data stack. Wrappers are used to push word objects directly on the stack when they would otherwise execute. See the " { $link POSTPONE: \ } " parsing word." }
|
||||
{ "All other types of objects are pushed on the data stack." }
|
||||
}
|
||||
"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage."
|
||||
{ $subsection "tail-call-opt" }
|
||||
{ $see-also "compiler" } ;
|
||||
|
||||
ARTICLE: "objects" "Objects"
|
||||
|
|
|
|||
|
|
@ -310,8 +310,9 @@ ARTICLE: "math-bitfields" "Constructing bit fields"
|
|||
"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
|
||||
{ $subsection bitfield } ;
|
||||
|
||||
ARTICLE: "math.bitwise" "Bitwise arithmetic"
|
||||
"The " { $vocab-link "math.bitwise" } " vocabulary can implements bitwise arithmetic words that are useful for efficiency, low-level programming, and interfacing with C libraries." $nl
|
||||
ARTICLE: "math.bitwise" "Additional bitwise arithmetic"
|
||||
"The " { $vocab-link "math.bitwise" } " vocabulary provides bitwise arithmetic words extending " { $link "bitwise-arithmetic" } ". They are useful for efficiency, low-level programming, and interfacing with C libraries."
|
||||
$nl
|
||||
"Setting and clearing bits:"
|
||||
{ $subsection set-bit }
|
||||
{ $subsection clear-bit }
|
||||
|
|
|
|||
|
|
@ -47,3 +47,21 @@ HELP: <zero-rect>
|
|||
{ $values { "rect" "a new " { $link rect } } }
|
||||
{ $description "Creates a rectangle located at the origin with zero dimensions." } ;
|
||||
|
||||
ARTICLE: "math.geometry.rect" "Rectangles"
|
||||
"The " { $vocab-link "math.geometry.rect" } " vocabulary defines a rectangle data type and operations on them."
|
||||
{ $subsection rect }
|
||||
"Rectangles can be taken apart:"
|
||||
{ $subsection rect-loc }
|
||||
{ $subsection rect-dim }
|
||||
{ $subsection rect-bounds }
|
||||
{ $subsection rect-extent }
|
||||
"New rectangles can be created:"
|
||||
{ $subsection <zero-rect> }
|
||||
{ $subsection <rect> }
|
||||
{ $subsection <extent-rect> }
|
||||
"More utility words for working with rectangles:"
|
||||
{ $subsection offset-rect }
|
||||
{ $subsection rect-intersect }
|
||||
{ $subsection intersects? } ;
|
||||
|
||||
ABOUT: "math.geometry.rect"
|
||||
|
|
|
|||
|
|
@ -217,14 +217,24 @@ 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 quot>> callable? [ pprint-object ] [
|
||||
dup valid-callable? [ pprint-object ] [
|
||||
"( invalid curry )" swap present-text
|
||||
] if ;
|
||||
|
||||
M: compose pprint*
|
||||
dup [ first>> callable? ] [ second>> callable? ] bi and
|
||||
[ pprint-object ] [
|
||||
dup valid-callable? [ pprint-object ] [
|
||||
"( invalid compose )" swap present-text
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -365,3 +365,8 @@ 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
|
||||
|
|
|
|||
|
|
@ -267,6 +267,7 @@ IN: tools.deploy.shaker
|
|||
layouts:type-numbers
|
||||
lexer-factory
|
||||
listener:listener-hook
|
||||
parser:print-use-hook
|
||||
root-cache
|
||||
vocab-roots
|
||||
vocabs:dictionary
|
||||
|
|
|
|||
|
|
@ -120,9 +120,10 @@ M: editor ungraft*
|
|||
|
||||
: scroll>caret ( editor -- )
|
||||
dup graft-state>> second [
|
||||
dup caret-loc over caret-dim <rect>
|
||||
over scroll>rect
|
||||
] when drop ;
|
||||
[
|
||||
[ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
|
||||
] keep scroll>rect
|
||||
] [ drop ] if ;
|
||||
|
||||
: draw-caret ( -- )
|
||||
editor get focused?>> [
|
||||
|
|
@ -452,7 +453,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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
USING: accessors tools.test ui.gadgets ui.gadgets.labels ;
|
||||
IN: ui.gadgets.labels.tests
|
||||
|
||||
[ { 119 14 } ] [
|
||||
<gadget> { 100 14 } >>dim
|
||||
<gadget> { 14 14 } >>dim
|
||||
label-on-right { 5 5 } >>gap
|
||||
pref-dim
|
||||
] unit-test
|
||||
|
|
@ -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 ] }
|
||||
|
|
@ -43,30 +43,29 @@ scroller H{
|
|||
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
|
||||
|
||||
tuck model>> <viewport> >>viewport
|
||||
dup viewport>> @center grid-add ;
|
||||
dup viewport>> @center grid-add ; inline
|
||||
|
||||
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: rect-min ( rect1 rect2 -- rect )
|
||||
>r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin <rect> ;
|
||||
: rect-min ( rect dim -- rect' )
|
||||
[ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
|
||||
|
||||
: (scroll>rect) ( rect scroller -- )
|
||||
[
|
||||
scroller-value vneg offset-rect
|
||||
viewport-gap offset-rect
|
||||
] keep
|
||||
[ viewport>> rect-min ] keep
|
||||
[
|
||||
viewport>> 2rect-extent
|
||||
>r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax 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>
|
||||
2dup swap child? [
|
||||
[ [ pref-dim { 0 0 } swap <rect> ] keep ] dip
|
||||
[ relative-scroll-rect ] keep
|
||||
(scroll>rect) ;
|
||||
(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,24 +117,26 @@ 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
|
||||
[ call-next-method ] [
|
||||
dup follows>>
|
||||
2dup update-scroller
|
||||
>>follows drop ;
|
||||
[ 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 fixed-dim ;
|
||||
TUPLE: limited-scroller < scroller
|
||||
{ min-dim initial: { 0 0 } }
|
||||
{ max-dim initial: { 1/0. 1/0. } } ;
|
||||
|
||||
: <limited-scroller> ( gadget dim -- scroller )
|
||||
>r limited-scroller new-scroller r> >>fixed-dim ;
|
||||
: <limited-scroller> ( gadget -- scroller )
|
||||
limited-scroller new-scroller ;
|
||||
|
||||
M: limited-scroller pref-dim*
|
||||
fixed-dim>> ;
|
||||
[ call-next-method ] [ min-dim>> vmax ] [ max-dim>> vmin ] tri ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors io kernel math namespaces
|
||||
sequences words math.vectors ui.gadgets ui.gadgets.packs
|
||||
math.geometry.rect fry ;
|
||||
USING: accessors io kernel namespaces fry
|
||||
math math.vectors math.geometry.rect math.order
|
||||
sequences words ui.gadgets ui.gadgets.packs ;
|
||||
|
||||
IN: ui.gadgets.tracks
|
||||
|
||||
|
|
@ -35,13 +35,16 @@ TUPLE: track < pack sizes ;
|
|||
|
||||
M: track layout* ( track -- ) dup track-layout pack-layout ;
|
||||
|
||||
: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
|
||||
: track-pref-dims-1 ( track -- dim )
|
||||
children>> pref-dims max-dim ;
|
||||
|
||||
: track-pref-dims-2 ( track -- dim )
|
||||
[
|
||||
[ children>> pref-dims ] [ normalized-sizes ] bi
|
||||
[ [ v/n ] when* ] 2map
|
||||
max-dim
|
||||
[ >fixnum ] map ;
|
||||
[ [ v/n ] when* ] 2map max-dim [ >fixnum ] map
|
||||
]
|
||||
[ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
|
||||
v+ ;
|
||||
|
||||
M: track pref-dim* ( gadget -- dim )
|
||||
[ track-pref-dims-1 ]
|
||||
|
|
|
|||
|
|
@ -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? [
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -96,9 +96,12 @@ TUPLE: deploy-gadget < pack vocab settings ;
|
|||
: com-close ( gadget -- )
|
||||
close-window ;
|
||||
|
||||
deploy-gadget "misc" "Miscellaneous commands" {
|
||||
{ T{ key-down f f "ESC" } com-close }
|
||||
} define-command-map
|
||||
|
||||
deploy-gadget "toolbar" f {
|
||||
{ f com-close }
|
||||
{ f com-help }
|
||||
{ T{ key-down f f "F1" } com-help }
|
||||
{ f com-revert }
|
||||
{ f com-save }
|
||||
{ T{ key-down f f "RET" } com-deploy }
|
||||
|
|
|
|||
|
|
@ -25,7 +25,9 @@ TUPLE: listener-gadget < track input output stack ;
|
|||
: listener-input, ( listener -- listener )
|
||||
dup <listener-input> >>input
|
||||
dup input>>
|
||||
{ 0 100 } <limited-scroller>
|
||||
<limited-scroller>
|
||||
{ 0 100 } >>min-dim
|
||||
{ 1/0. 100 } >>max-dim
|
||||
"Input" <labelled-gadget>
|
||||
f track-add ;
|
||||
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ search-field H{
|
|||
} set-gestures
|
||||
|
||||
: <search-model> ( live-search producer -- live-search filter )
|
||||
>r dup field>> model>> ! live-search model :: producer
|
||||
>r dup field>> model>>
|
||||
ui-running? [ 1/5 seconds <delay> ] when
|
||||
[ "\n" join ] r> append <filter> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -43,7 +43,10 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
|
|||
<pane-control> ;
|
||||
|
||||
: <variables-gadget> ( model -- gadget )
|
||||
<namestack-display> { 400 400 } <limited-scroller> ;
|
||||
<namestack-display>
|
||||
<limited-scroller>
|
||||
{ 400 400 } >>min-dim
|
||||
{ 400 400 } >>max-dim ;
|
||||
|
||||
: variables ( traceback -- )
|
||||
model>> <variables-gadget>
|
||||
|
|
|
|||
|
|
@ -47,12 +47,15 @@ M: gadget tool-scroller drop f ;
|
|||
: get-tool ( class -- gadget )
|
||||
get-workspace find-tool nip ;
|
||||
|
||||
: <help-pane> ( topic -- pane )
|
||||
<pane> [ [ help ] with-pane ] keep ;
|
||||
|
||||
: help-window ( topic -- )
|
||||
[
|
||||
<pane> [ [ help ] with-pane ] keep
|
||||
{ 550 700 } <limited-scroller>
|
||||
] keep
|
||||
article-title open-window ;
|
||||
<help-pane> <limited-scroller>
|
||||
{ 550 700 } >>max-dim
|
||||
] [ article-title ] bi
|
||||
open-window ;
|
||||
|
||||
: hide-popup ( workspace -- )
|
||||
dup popup>> track-remove
|
||||
|
|
|
|||
|
|
@ -105,24 +105,7 @@ ARTICLE: "gadgets" "Pre-made UI gadgets"
|
|||
|
||||
ARTICLE: "ui-geometry" "Gadget geometry"
|
||||
"The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:"
|
||||
{ $subsection rect }
|
||||
"Rectangles can be taken apart:"
|
||||
{ $subsection rect-loc }
|
||||
{ $subsection rect-dim }
|
||||
{ $subsection rect-bounds }
|
||||
{ $subsection rect-extent }
|
||||
"New rectangles can be created:"
|
||||
{ $subsection <zero-rect> }
|
||||
{ $subsection <rect> }
|
||||
{ $subsection <extent-rect> }
|
||||
"More utility words for working with rectangles:"
|
||||
{ $subsection offset-rect }
|
||||
{ $subsection rect-intersect }
|
||||
{ $subsection intersects? }
|
||||
|
||||
! "A gadget's bounding box is always relative to its parent. "
|
||||
! { $subsection gadget-parent }
|
||||
|
||||
{ $subsection "math.geometry.rect" }
|
||||
"Word for converting from a child gadget's co-ordinate system to a parent's:"
|
||||
{ $subsection relative-loc }
|
||||
{ $subsection screen-loc }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
|
|||
IN: values
|
||||
|
||||
ARTICLE: "values" "Global values"
|
||||
"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. Values abstract over this concept. To create a new word as a value, use the following syntax:"
|
||||
"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:"
|
||||
{ $subsection POSTPONE: VALUE: }
|
||||
"To get the value, just call the word. The following words manipulate values:"
|
||||
{ $subsection get-value }
|
||||
|
|
@ -10,6 +10,8 @@ ARTICLE: "values" "Global values"
|
|||
{ $subsection POSTPONE: to: }
|
||||
{ $subsection change-value } ;
|
||||
|
||||
ABOUT: "values"
|
||||
|
||||
HELP: VALUE:
|
||||
{ $syntax "VALUE: word" }
|
||||
{ $values { "word" "a word to be created" } }
|
||||
|
|
|
|||
|
|
@ -348,6 +348,7 @@ ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
|
|||
{ $subsection 2/ }
|
||||
{ $subsection 2^ }
|
||||
{ $subsection bit? }
|
||||
"The " { $vocab-link "math.bitwise" } " vocabulary implements additional bitwise integer operations."
|
||||
{ $see-also "conditionals" } ;
|
||||
|
||||
ARTICLE: "arithmetic" "Arithmetic"
|
||||
|
|
|
|||
|
|
@ -428,7 +428,7 @@ must-fail-with
|
|||
"USE: this-better-not-exist" eval
|
||||
] must-fail
|
||||
|
||||
[ ": foo ;" eval ] [ error>> no-current-vocab? ] must-fail-with
|
||||
[ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
|
||||
|
||||
[ 92 ] [ "CHAR: \\" eval ] unit-test
|
||||
[ 92 ] [ "CHAR: \\\\" eval ] unit-test
|
||||
|
|
@ -483,7 +483,7 @@ must-fail-with
|
|||
|
||||
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with
|
||||
[ "DEFER: blah" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
|
||||
|
||||
[
|
||||
"IN: parser.tests : blah ; parsing FORGET: blah" eval
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Loading…
Reference in New Issue