steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

release
Eduardo Cavazos 2007-11-19 15:30:07 -06:00
parent f927a01370 23369eecc9
commit 71f072fa95
66 changed files with 1080 additions and 1751 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
core/alien/compiler/compiler.factor
View File

@ -196,6 +196,12 @@ M: alien-invoke alien-node-abi
alien-invoke-library library
[ library-abi ] [ "cdecl" ] if* ;
M: alien-invoke-error summary
drop
"Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
: pop-parameters pop-literal nip [ expand-constants ] map ;
: stdcall-mangle ( symbol node -- symbol )
"@"
swap alien-node-parameters parameter-sizes drop
@ -219,11 +225,6 @@ M: no-such-symbol summary
[ no-such-symbol ] unless
] unless rot drop ;
M: alien-invoke-error summary
drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ;
: pop-parameters pop-literal nip [ expand-constants ] map ;
\ alien-invoke [
! Four literals
4 ensure-values
@ -233,10 +234,10 @@ M: alien-invoke-error summary
pop-literal nip over set-alien-invoke-function
pop-literal nip over set-alien-invoke-library
pop-literal nip over set-alien-invoke-return
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
! If symbol doesn't resolve, no stack effect, no compile
dup alien-invoke-dlsym 2drop
! Quotation which coerces parameters to required types
dup make-prep-quot recursive-state get infer-quot
! Add node to IR
dup node,
! Magic #: consume exactly the number of inputs
@ -260,7 +261,7 @@ M: alien-indirect alien-node-return alien-indirect-return ;
M: alien-indirect alien-node-abi alien-indirect-abi ;
M: alien-indirect-error summary
drop "Words calling ``alien-indirect'' cannot run in the interpreter. Compile the caller word and try again." ;
drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
\ alien-indirect [
! Three literals and function pointer
@ -309,7 +310,7 @@ M: alien-callback alien-node-return alien-callback-return ;
M: alien-callback alien-node-abi alien-callback-abi ;
M: alien-callback-error summary
drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- )
alien-callback-xt [ word-xt <alien> ] curry

4
core/bootstrap/stage1.factor
View File

@ -25,6 +25,10 @@ vocabs.loader system ;
"math.integers" require
"math.floats" require
"memory" require
! this must add its init hook before io.backend does
"libc" require
"io.streams.c" require
"vocabs.loader" require
"syntax" require

10
core/compiler/test/alien.factor Normal file → Executable file
View File

@ -2,7 +2,8 @@ IN: temporary
USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects
namespaces.private io io.streams.string memory system threads ;
namespaces.private io io.streams.string memory system threads
tools.test.inference ;
FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test
@ -79,10 +80,7 @@ FUNCTION: tiny ffi_test_17 int x ;
: indirect-test-1
"int" { } "cdecl" alien-indirect ;
: short-effect
dup effect-in length swap effect-out length 2array ;
[ { 1 1 } ] [ [ indirect-test-1 ] infer short-effect ] unit-test
{ 1 1 } [ indirect-test-1 ] unit-test-effect
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
@ -91,7 +89,7 @@ FUNCTION: tiny ffi_test_17 int x ;
: indirect-test-2
"int" { "int" "int" } "cdecl" alien-indirect data-gc ;
[ { 3 1 } ] [ [ indirect-test-2 ] infer short-effect ] unit-test
{ 3 1 } [ indirect-test-2 ] unit-test-effect
[ 5 ]
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]

39
core/compiler/test/redefine.factor Normal file → Executable file
View File

@ -1,36 +1,33 @@
USING: compiler definitions generic assocs inference math
namespaces parser tools.test words kernel sequences arrays io
effects ;
effects tools.test.inference ;
IN: temporary
parse-hook get [
DEFER: foo \ foo reset-generic
DEFER: bar \ bar reset-generic
: short-effect
dup effect-in length swap effect-out length 2array ;
[ ] [ \ foo [ 1 2 ] define-compound ] unit-test
[ { 0 2 } ] [ [ foo ] infer short-effect ] unit-test
[ ] [ \ foo compile ] unit-test
[ ] [ \ foo [ 1 2 ] define-compound ] unit-test
{ 0 2 } [ foo ] unit-test-effect
[ ] [ \ foo compile ] unit-test
[ ] [ \ bar [ foo foo ] define-compound ] unit-test
[ ] [ \ bar compile ] unit-test
[ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test
[ t ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ bar compile ] unit-test
[ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test
[ t ] [ \ bar changed-words get key? ] unit-test
[ ] [ recompile ] unit-test
[ { 0 3 } ] [ [ foo ] infer short-effect ] unit-test
[ f ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ bar [ 1 2 ] define-compound ] unit-test
[ t ] [ \ bar changed-words get key? ] unit-test
{ 0 3 } [ foo ] unit-test-effect
[ f ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ bar [ 1 2 ] define-compound ] unit-test
[ t ] [ \ bar changed-words get key? ] unit-test
[ ] [ recompile ] unit-test
[ { 0 2 } ] [ [ bar ] infer short-effect ] unit-test
[ f ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test
[ f ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ bar [ 1 2 3 ] define-compound ] unit-test
[ t ] [ \ bar changed-words get key? ] unit-test
{ 0 2 } [ bar ] unit-test-effect
[ f ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test
[ f ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ bar [ 1 2 3 ] define-compound ] unit-test
[ t ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ bar forget ] unit-test
[ f ] [ \ bar changed-words get key? ] unit-test
[ f ] [ \ bar changed-words get key? ] unit-test
: xy ;
: yx xy ;

38
core/dlists/dlists-tests.factor Normal file → Executable file
View File

@ -1,4 +1,6 @@
USING: dlists dlists.private kernel tools.test ;
USING: dlists dlists.private kernel tools.test random assocs
hashtables sequences namespaces sorting debugger io prettyprint
math ;
IN: temporary
[ t ] [ <dlist> dlist-empty? ] unit-test
@ -59,3 +61,37 @@ IN: temporary
[ 0 ] [ <dlist> dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
: assert-same-elements
[ prune natural-sort ] 2apply assert= ;
: dlist-push-all [ push-front ] curry each ;
: dlist-delete-all [ dlist-delete drop ] curry each ;
: dlist>array [ [ , ] dlist-slurp ] { } make ;
[ ] [
5 [ drop 30 random >fixnum ] map prune
6 [ drop 30 random >fixnum ] map prune 2dup nl . . nl
[
<dlist>
[ dlist-push-all ] keep
[ dlist-delete-all ] keep
dlist>array
] 2keep seq-diff assert-same-elements
] unit-test
[ ] [
<dlist> "d" set
1 "d" get push-front
2 "d" get push-front
3 "d" get push-front
4 "d" get push-front
2 "d" get dlist-delete drop
3 "d" get dlist-delete drop
4 "d" get dlist-delete drop
] unit-test
[ 1 ] [ "d" get dlist-length ] unit-test
[ 1 ] [ "d" get dlist>array length ] unit-test

28
core/dlists/dlists.factor Normal file → Executable file
View File

@ -49,15 +49,15 @@ C: <dlist-node> dlist-node
drop nip t
] [
drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
] if ;
] if ; inline
: dlist-find-node ( quot dlist -- node/f ? )
dlist-front [ (dlist-find-node) ] [ drop f f ] if* ;
dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; inline
: (dlist-each-node) ( quot dlist -- )
over
[ 2dup call >r dlist-node-next r> (dlist-each-node) ]
[ 2drop ] if ;
[ 2drop ] if ; inline
: dlist-each-node ( quot dlist -- )
>r dlist-front r> (dlist-each-node) ; inline
@ -98,17 +98,20 @@ PRIVATE>
: pop-back* ( dlist -- ) pop-back drop ;
: dlist-find ( quot dlist -- obj/f ? )
dlist-find-node dup [ >r dlist-node-obj r> ] when ;
dlist-find-node dup [ >r dlist-node-obj r> ] when ; inline
: dlist-contains? ( quot dlist -- ? )
dlist-find nip ;
dlist-find nip ; inline
: unlink-node ( dlist-node -- )
dup dlist-node-prev over dlist-node-next set-prev-when
dup dlist-node-next swap dlist-node-prev set-next-when ;
: (delete-node) ( dlist dlist-node -- )
{
{ [ 2dup >r dlist-front r> = ] [ drop pop-front* ] }
{ [ 2dup >r dlist-back r> = ] [ drop pop-back* ] }
{ [ t ] [ dup dlist-node-prev swap dlist-node-next set-prev-when
dec-length ] }
{ [ over dlist-front over eq? ] [ drop pop-front* ] }
{ [ over dlist-back over eq? ] [ drop pop-back* ] }
{ [ t ] [ unlink-node dec-length ] }
} cond ;
: delete-node* ( quot dlist -- obj/f ? )
@ -116,10 +119,13 @@ PRIVATE>
[ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if*
] [
2drop f f
] if ;
] if ; inline
: delete-node ( quot dlist -- obj/f )
delete-node* drop ;
delete-node* drop ; inline
: dlist-delete ( obj dlist -- obj/f )
>r [ eq? ] curry r> delete-node ;
: dlist-each ( dlist quot -- )
[ dlist-node-obj ] swap compose dlist-each-node ; inline

338
core/inference/inference-tests.factor
View File

@ -6,46 +6,40 @@ continuations generic.standard sorting assocs definitions
prettyprint io inspector bootstrap.image tuples
classes.union classes.predicate debugger bootstrap.image
bootstrap.image.private io.launcher threads.private
io.streams.string combinators.private ;
io.streams.string combinators.private tools.test.inference ;
IN: temporary
: short-effect
dup effect-in length swap effect-out length 2array ;
{ 0 2 } [ 2 "Hello" ] unit-test-effect
{ 1 2 } [ dup ] unit-test-effect
[ { 0 2 } ] [ [ 2 "Hello" ] infer short-effect ] unit-test
[ { 1 2 } ] [ [ dup ] infer short-effect ] unit-test
{ 1 2 } [ [ dup ] call ] unit-test-effect
[ [ call ] infer ] unit-test-fails
[ { 1 2 } ] [ [ [ dup ] call ] infer short-effect ] unit-test
[ [ call ] infer short-effect ] unit-test-fails
{ 2 4 } [ 2dup ] unit-test-effect
[ { 2 4 } ] [ [ 2dup ] infer short-effect ] unit-test
{ 1 0 } [ [ ] [ ] if ] unit-test-effect
[ [ if ] infer ] unit-test-fails
[ [ [ ] if ] infer ] unit-test-fails
[ [ [ 2 ] [ ] if ] infer ] unit-test-fails
{ 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect
[ { 1 0 } ] [ [ [ ] [ ] if ] infer short-effect ] unit-test
[ [ if ] infer short-effect ] unit-test-fails
[ [ [ ] if ] infer short-effect ] unit-test-fails
[ [ [ 2 ] [ ] if ] infer short-effect ] unit-test-fails
[ { 4 3 } ] [ [ [ rot ] [ -rot ] if ] infer short-effect ] unit-test
[ { 4 3 } ] [
{ 4 3 } [
[
[
[ swap 3 ] [ nip 5 5 ] if
] [
-rot
] if
] infer short-effect
] unit-test
[ swap 3 ] [ nip 5 5 ] if
] [
-rot
] if
] unit-test-effect
[ { 1 1 } ] [ [ dup [ ] when ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer short-effect ] unit-test
{ 1 1 } [ dup [ ] when ] unit-test-effect
{ 1 1 } [ dup [ dup fixnum* ] when ] unit-test-effect
{ 2 1 } [ [ dup fixnum* ] when ] unit-test-effect
[ { 1 0 } ] [ [ [ drop ] when* ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer short-effect ] unit-test
{ 1 0 } [ [ drop ] when* ] unit-test-effect
{ 1 1 } [ [ { { [ ] } } ] unless* ] unit-test-effect
[ { 0 1 } ] [
[ [ 2 2 fixnum+ ] dup [ ] when call ] infer short-effect
] unit-test
{ 0 1 }
[ [ 2 2 fixnum+ ] dup [ ] when call ] unit-test-effect
[
[ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
@ -57,37 +51,37 @@ IN: temporary
: termination-test-2 [ termination-test-1 ] [ 3 ] if ;
[ { 1 1 } ] [ [ termination-test-2 ] infer short-effect ] unit-test
{ 1 1 } [ termination-test-2 ] unit-test-effect
: infinite-loop infinite-loop ;
[ [ infinite-loop ] infer short-effect ] unit-test-fails
[ [ infinite-loop ] infer ] unit-test-fails
: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
[ [ no-base-case-1 ] infer short-effect ] unit-test-fails
[ [ no-base-case-1 ] infer ] unit-test-fails
: simple-recursion-1 ( obj -- obj )
dup [ simple-recursion-1 ] [ ] if ;
[ { 1 1 } ] [ [ simple-recursion-1 ] infer short-effect ] unit-test
{ 1 1 } [ simple-recursion-1 ] unit-test-effect
: simple-recursion-2 ( obj -- obj )
dup [ ] [ simple-recursion-2 ] if ;
[ { 1 1 } ] [ [ simple-recursion-2 ] infer short-effect ] unit-test
{ 1 1 } [ simple-recursion-2 ] unit-test-effect
: bad-recursion-2 ( obj -- obj )
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
[ [ bad-recursion-2 ] infer short-effect ] unit-test-fails
[ [ bad-recursion-2 ] infer ] unit-test-fails
: funny-recursion ( obj -- obj )
dup [ funny-recursion 1 ] [ 2 ] if drop ;
[ { 1 1 } ] [ [ funny-recursion ] infer short-effect ] unit-test
{ 1 1 } [ funny-recursion ] unit-test-effect
! Simple combinators
[ { 1 2 } ] [ [ [ first ] keep second ] infer short-effect ] unit-test
{ 1 2 } [ [ first ] keep second ] unit-test-effect
! Mutual recursion
DEFER: foe
@ -110,8 +104,8 @@ DEFER: foe
2drop f
] if ;
[ { 2 1 } ] [ [ fie ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ foe ] infer short-effect ] unit-test
{ 2 1 } [ fie ] unit-test-effect
{ 2 1 } [ foe ] unit-test-effect
: nested-when ( -- )
t [
@ -120,7 +114,7 @@ DEFER: foe
] when
] when ;
[ { 0 0 } ] [ [ nested-when ] infer short-effect ] unit-test
{ 0 0 } [ nested-when ] unit-test-effect
: nested-when* ( obj -- )
[
@ -129,11 +123,11 @@ DEFER: foe
] when*
] when* ;
[ { 1 0 } ] [ [ nested-when* ] infer short-effect ] unit-test
{ 1 0 } [ nested-when* ] unit-test-effect
SYMBOL: sym-test
[ { 0 1 } ] [ [ sym-test ] infer short-effect ] unit-test
{ 0 1 } [ sym-test ] unit-test-effect
: terminator-branch
dup [
@ -142,7 +136,7 @@ SYMBOL: sym-test
"foo" throw
] if ;
[ { 1 1 } ] [ [ terminator-branch ] infer short-effect ] unit-test
{ 1 1 } [ terminator-branch ] unit-test-effect
: recursive-terminator ( obj -- )
dup [
@ -151,12 +145,12 @@ SYMBOL: sym-test
"Hi" throw
] if ;
[ { 1 0 } ] [ [ recursive-terminator ] infer short-effect ] unit-test
{ 1 0 } [ recursive-terminator ] unit-test-effect
GENERIC: potential-hang ( obj -- obj )
M: fixnum potential-hang dup [ potential-hang ] when ;
[ ] [ [ 5 potential-hang ] infer short-effect drop ] unit-test
[ ] [ [ 5 potential-hang ] infer drop ] unit-test
TUPLE: funny-cons car cdr ;
GENERIC: iterate ( obj -- )
@ -164,24 +158,24 @@ M: funny-cons iterate funny-cons-cdr iterate ;
M: f iterate drop ;
M: real iterate drop ;
[ { 1 0 } ] [ [ iterate ] infer short-effect ] unit-test
{ 1 0 } [ iterate ] unit-test-effect
! Regression
: cat ( obj -- * ) dup [ throw ] [ throw ] if ;
: dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
[ { 3 0 } ] [ [ dog ] infer short-effect ] unit-test
{ 3 0 } [ dog ] unit-test-effect
! Regression
DEFER: monkey
: friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
: monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
[ { 3 0 } ] [ [ friend ] infer short-effect ] unit-test
{ 3 0 } [ friend ] unit-test-effect
! Regression -- same as above but we infer short-effect the second word first
! Regression -- same as above but we infer the second word first
DEFER: blah2
: blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
: blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
[ { 3 0 } ] [ [ blah2 ] infer short-effect ] unit-test
{ 3 0 } [ blah2 ] unit-test-effect
! Regression
DEFER: blah4
@ -189,7 +183,7 @@ DEFER: blah4
dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
: blah4 ( a b c -- )
dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
[ { 3 0 } ] [ [ blah4 ] infer short-effect ] unit-test
{ 3 0 } [ blah4 ] unit-test-effect
! Regression
: bad-combinator ( obj quot -- )
@ -199,14 +193,14 @@ DEFER: blah4
[ swap slip ] keep swap bad-combinator
] if ; inline
[ [ [ 1 ] [ ] bad-combinator ] infer short-effect ] unit-test-fails
[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
! Regression
: bad-input#
dup string? [ 2array throw ] unless
over string? [ 2array throw ] unless ;
[ { 2 2 } ] [ [ bad-input# ] infer short-effect ] unit-test
{ 2 2 } [ bad-input# ] unit-test-effect
! Regression
@ -214,18 +208,18 @@ DEFER: blah4
DEFER: do-crap
: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
[ [ do-crap ] infer short-effect ] unit-test-fails
[ [ do-crap ] infer ] unit-test-fails
! This one does not
DEFER: do-crap*
: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
[ [ do-crap* ] infer short-effect ] unit-test-fails
[ [ do-crap* ] infer ] unit-test-fails
! Regression
: too-deep ( a b -- c )
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
[ { 2 1 } ] [ [ too-deep ] infer short-effect ] unit-test
{ 2 1 } [ too-deep ] unit-test-effect
! Error reporting is wrong
MATH: xyz
@ -233,7 +227,7 @@ M: fixnum xyz 2array ;
M: float xyz
[ 3 ] 2apply swapd >r 2array swap r> 2array swap ;
[ t ] [ [ [ xyz ] infer short-effect ] catch inference-error? ] unit-test
[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test
! Doug Coleman discovered this one while working on the
! calendar library
@ -265,17 +259,17 @@ DEFER: C
[ dup B C ]
} dispatch ;
[ { 1 0 } ] [ [ A ] infer short-effect ] unit-test
[ { 1 0 } ] [ [ B ] infer short-effect ] unit-test
[ { 1 0 } ] [ [ C ] infer short-effect ] unit-test
{ 1 0 } [ A ] unit-test-effect
{ 1 0 } [ B ] unit-test-effect
{ 1 0 } [ C ] unit-test-effect
! I found this bug by thinking hard about the previous one
DEFER: Y
: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
: Y ( a b -- c d ) X ;
[ { 2 2 } ] [ [ X ] infer short-effect ] unit-test
[ { 2 2 } ] [ [ Y ] infer short-effect ] unit-test
{ 2 2 } [ X ] unit-test-effect
{ 2 2 } [ Y ] unit-test-effect
! This one comes from UI code
DEFER: #1
@ -284,17 +278,17 @@ DEFER: #1
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
[ \ #4 word-def infer short-effect ] unit-test-fails
[ [ #1 ] infer short-effect ] unit-test-fails
[ \ #4 word-def infer ] unit-test-fails
[ [ #1 ] infer ] unit-test-fails
! Similar
DEFER: bar
: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
[ [ foo ] infer short-effect ] unit-test-fails
[ [ foo ] infer ] unit-test-fails
[ 1234 infer short-effect ] unit-test-fails
[ 1234 infer ] unit-test-fails
! This used to hang
[ t ] [
@ -340,128 +334,128 @@ DEFER: bar
: bad-recursion-1 ( a -- b )
dup [ drop bad-recursion-1 5 ] [ ] if ;
[ [ bad-recursion-1 ] infer short-effect ] unit-test-fails
[ [ bad-recursion-1 ] infer ] unit-test-fails
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
[ [ bad-bin ] infer short-effect ] unit-test-fails
[ [ bad-bin ] infer ] unit-test-fails
[ t ] [ [ [ r> ] infer short-effect ] catch inference-error? ] unit-test
[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test
! Regression
[ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test
! Test some curry stuff
[ { 1 1 } ] [ [ 3 [ ] curry 4 [ ] curry if ] infer short-effect ] unit-test
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect
[ { 2 1 } ] [ [ [ ] curry 4 [ ] curry if ] infer short-effect ] unit-test
{ 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails
! Test number protocol
[ { 2 1 } ] [ [ bitor ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ bitand ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ bitxor ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ mod ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ /i ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ /f ] infer short-effect ] unit-test
[ { 2 2 } ] [ [ /mod ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ + ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ - ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ * ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ / ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ < ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ <= ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ > ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ >= ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ number= ] infer short-effect ] unit-test
{ 2 1 } [ bitor ] unit-test-effect
{ 2 1 } [ bitand ] unit-test-effect
{ 2 1 } [ bitxor ] unit-test-effect
{ 2 1 } [ mod ] unit-test-effect
{ 2 1 } [ /i ] unit-test-effect
{ 2 1 } [ /f ] unit-test-effect
{ 2 2 } [ /mod ] unit-test-effect
{ 2 1 } [ + ] unit-test-effect
{ 2 1 } [ - ] unit-test-effect
{ 2 1 } [ * ] unit-test-effect
{ 2 1 } [ / ] unit-test-effect
{ 2 1 } [ < ] unit-test-effect
{ 2 1 } [ <= ] unit-test-effect
{ 2 1 } [ > ] unit-test-effect
{ 2 1 } [ >= ] unit-test-effect
{ 2 1 } [ number= ] unit-test-effect
! Test object protocol
[ { 2 1 } ] [ [ = ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ clone ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ hashcode* ] infer short-effect ] unit-test
{ 2 1 } [ = ] unit-test-effect
{ 1 1 } [ clone ] unit-test-effect
{ 2 1 } [ hashcode* ] unit-test-effect
! Test sequence protocol
[ { 1 1 } ] [ [ length ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ nth ] infer short-effect ] unit-test
[ { 2 0 } ] [ [ set-length ] infer short-effect ] unit-test
[ { 3 0 } ] [ [ set-nth ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ new ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ new-resizable ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ like ] infer short-effect ] unit-test
[ { 2 0 } ] [ [ lengthen ] infer short-effect ] unit-test
{ 1 1 } [ length ] unit-test-effect
{ 2 1 } [ nth ] unit-test-effect
{ 2 0 } [ set-length ] unit-test-effect
{ 3 0 } [ set-nth ] unit-test-effect
{ 2 1 } [ new ] unit-test-effect
{ 2 1 } [ new-resizable ] unit-test-effect
{ 2 1 } [ like ] unit-test-effect
{ 2 0 } [ lengthen ] unit-test-effect
! Test assoc protocol
[ { 2 2 } ] [ [ at* ] infer short-effect ] unit-test
[ { 3 0 } ] [ [ set-at ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ new-assoc ] infer short-effect ] unit-test
[ { 2 0 } ] [ [ delete-at ] infer short-effect ] unit-test
[ { 1 0 } ] [ [ clear-assoc ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ assoc-size ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ assoc-like ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ assoc-clone-like ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ >alist ] infer short-effect ] unit-test
[ { 1 3 } ] [ [ [ 2drop f ] assoc-find ] infer short-effect ] unit-test
{ 2 2 } [ at* ] unit-test-effect
{ 3 0 } [ set-at ] unit-test-effect
{ 2 1 } [ new-assoc ] unit-test-effect
{ 2 0 } [ delete-at ] unit-test-effect
{ 1 0 } [ clear-assoc ] unit-test-effect
{ 1 1 } [ assoc-size ] unit-test-effect
{ 2 1 } [ assoc-like ] unit-test-effect
{ 2 1 } [ assoc-clone-like ] unit-test-effect
{ 1 1 } [ >alist ] unit-test-effect
{ 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect
! Test some random library words
[ { 1 1 } ] [ [ 1quotation ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ string>number ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ get ] infer short-effect ] unit-test
{ 1 1 } [ 1quotation ] unit-test-effect
{ 1 1 } [ string>number ] unit-test-effect
{ 1 1 } [ get ] unit-test-effect
[ { 2 0 } ] [ [ push ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ append ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ peek ] infer short-effect ] unit-test
{ 2 0 } [ push ] unit-test-effect
{ 2 1 } [ append ] unit-test-effect
{ 1 1 } [ peek ] unit-test-effect
[ { 1 1 } ] [ [ reverse ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ member? ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ remove ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ natural-sort ] infer short-effect ] unit-test
{ 1 1 } [ reverse ] unit-test-effect
{ 2 1 } [ member? ] unit-test-effect
{ 2 1 } [ remove ] unit-test-effect
{ 1 1 } [ natural-sort ] unit-test-effect
[ { 1 0 } ] [ [ forget ] infer short-effect ] unit-test
[ { 4 0 } ] [ [ define-class ] infer short-effect ] unit-test
[ { 2 0 } ] [ [ define-tuple-class ] infer short-effect ] unit-test
[ { 2 0 } ] [ [ define-union-class ] infer short-effect ] unit-test
[ { 3 0 } ] [ [ define-predicate-class ] infer short-effect ] unit-test
{ 1 0 } [ forget ] unit-test-effect
{ 4 0 } [ define-class ] unit-test-effect
{ 2 0 } [ define-tuple-class ] unit-test-effect
{ 2 0 } [ define-union-class ] unit-test-effect
{ 3 0 } [ define-predicate-class ] unit-test-effect
! Test words with continuations
[ { 0 0 } ] [ [ [ drop ] callcc0 ] infer short-effect ] unit-test
[ { 0 1 } ] [ [ [ 4 swap continue-with ] callcc1 ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ [ + ] [ ] [ ] cleanup ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ [ + ] [ 3drop 0 ] recover ] infer short-effect ] unit-test
{ 0 0 } [ [ drop ] callcc0 ] unit-test-effect
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] unit-test-effect
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
! Test stream protocol
[ { 2 0 } ] [ [ set-timeout ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ stream-read ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ stream-read1 ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ stream-readln ] infer short-effect ] unit-test
[ { 2 2 } ] [ [ stream-read-until ] infer short-effect ] unit-test
[ { 2 0 } ] [ [ stream-write ] infer short-effect ] unit-test
[ { 2 0 } ] [ [ stream-write1 ] infer short-effect ] unit-test
[ { 1 0 } ] [ [ stream-nl ] infer short-effect ] unit-test
[ { 1 0 } ] [ [ stream-close ] infer short-effect ] unit-test
[ { 3 0 } ] [ [ stream-format ] infer short-effect ] unit-test
[ { 3 0 } ] [ [ stream-write-table ] infer short-effect ] unit-test
[ { 1 0 } ] [ [ stream-flush ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ make-span-stream ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ make-block-stream ] infer short-effect ] unit-test
[ { 2 1 } ] [ [ make-cell-stream ] infer short-effect ] unit-test
{ 2 0 } [ set-timeout ] unit-test-effect
{ 2 1 } [ stream-read ] unit-test-effect
{ 1 1 } [ stream-read1 ] unit-test-effect
{ 1 1 } [ stream-readln ] unit-test-effect
{ 2 2 } [ stream-read-until ] unit-test-effect
{ 2 0 } [ stream-write ] unit-test-effect
{ 2 0 } [ stream-write1 ] unit-test-effect
{ 1 0 } [ stream-nl ] unit-test-effect
{ 1 0 } [ stream-close ] unit-test-effect
{ 3 0 } [ stream-format ] unit-test-effect
{ 3 0 } [ stream-write-table ] unit-test-effect
{ 1 0 } [ stream-flush ] unit-test-effect
{ 2 1 } [ make-span-stream ] unit-test-effect
{ 2 1 } [ make-block-stream ] unit-test-effect
{ 2 1 } [ make-cell-stream ] unit-test-effect
! Test stream utilities
[ { 1 1 } ] [ [ lines ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ contents ] infer short-effect ] unit-test
{ 1 1 } [ lines ] unit-test-effect
{ 1 1 } [ contents ] unit-test-effect
! Test prettyprinting
[ { 1 0 } ] [ [ . ] infer short-effect ] unit-test
[ { 1 0 } ] [ [ short. ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ unparse ] infer short-effect ] unit-test
{ 1 0 } [ . ] unit-test-effect
{ 1 0 } [ short. ] unit-test-effect
{ 1 1 } [ unparse ] unit-test-effect
[ { 1 0 } ] [ [ describe ] infer short-effect ] unit-test
[ { 1 0 } ] [ [ error. ] infer short-effect ] unit-test
{ 1 0 } [ describe ] unit-test-effect
{ 1 0 } [ error. ] unit-test-effect
! Test odds and ends
[ { 1 1 } ] [ [ ' ] infer short-effect ] unit-test
[ { 2 0 } ] [ [ write-image ] infer short-effect ] unit-test
[ { 1 1 } ] [ [ <process-stream> ] infer short-effect ] unit-test
[ { 0 0 } ] [ [ idle-thread ] infer short-effect ] unit-test
{ 1 1 } [ ' ] unit-test-effect
{ 2 0 } [ write-image ] unit-test-effect
{ 1 1 } [ <process-stream> ] unit-test-effect
{ 0 0 } [ idle-thread ] unit-test-effect
! Incorrect stack declarations on inline recursive words should
! be caught
@ -471,13 +465,13 @@ DEFER: bar
[ [ barxxx ] infer ] unit-test-fails
! A typo
[ { 1 0 } ] [ [ { [ ] } dispatch ] infer short-effect ] unit-test
{ 1 0 } [ { [ ] } dispatch ] unit-test-effect
DEFER: inline-recursive-2
: inline-recursive-1 ( -- ) inline-recursive-2 ;
: inline-recursive-2 ( -- ) inline-recursive-1 ;
[ { 0 0 } ] [ [ inline-recursive-1 ] infer short-effect ] unit-test
{ 0 0 } [ inline-recursive-1 ] unit-test-effect
! Hooks
SYMBOL: my-var
@ -486,23 +480,22 @@ HOOK: my-hook my-var ( -- x )
M: integer my-hook "an integer" ;
M: string my-hook "a string" ;
[ { 0 1 } ] [ [ my-hook ] infer short-effect ] unit-test
{ 0 1 } [ my-hook ] unit-test-effect
DEFER: deferred-word
: calls-deferred-word [ deferred-word ] [ 3 ] if ;
[ { 1 1 } ] [ [ calls-deferred-word ] infer short-effect ] unit-test
{ 1 1 } [ calls-deferred-word ] unit-test-effect
USE: inference.dataflow
[ { 1 0 } ] [ [ [ iterate-next ] iterate-nodes ] infer short-effect ] unit-test
{ 1 0 } [ [ iterate-next ] iterate-nodes ] unit-test-effect
[ { 1 0 } ] [
[
[ [ iterate-next ] iterate-nodes ] with-node-iterator
] infer short-effect
] unit-test
{ 1 0 }
[
[ [ iterate-next ] iterate-nodes ] with-node-iterator
] unit-test-effect
: nilpotent ( quot -- )
t [ [ call ] keep nilpotent ] [ drop ] if ; inline
@ -510,14 +503,13 @@ USE: inference.dataflow
: semisimple ( quot -- )
[ call ] keep [ [ semisimple ] keep ] nilpotent drop ; inline
[ { 0 1 } ] [
[ [ ] [ call ] keep [ [ call ] keep ] nilpotent ]
infer short-effect
] unit-test
{ 0 1 }
[ [ ] [ call ] keep [ [ call ] keep ] nilpotent ]
unit-test-effect
[ { 0 0 } ] [ [ [ ] semisimple ] infer short-effect ] unit-test
{ 0 0 } [ [ ] semisimple ] unit-test-effect
[ { 1 0 } ] [ [ [ drop ] each-node ] infer short-effect ] unit-test
{ 1 0 } [ [ drop ] each-node ] unit-test-effect
DEFER: an-inline-word
@ -533,9 +525,9 @@ DEFER: an-inline-word
: an-inline-word ( obj quot -- )
>r normal-word r> call ; inline
[ { 1 1 } ] [ [ [ 3 * ] an-inline-word ] infer short-effect ] unit-test
{ 1 1 } [ [ 3 * ] an-inline-word ] unit-test-effect
[ { 0 1 } ] [ [ [ 2 ] [ 2 ] [ + ] compose compose call ] infer short-effect ] unit-test
{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] unit-test-effect
TUPLE: custom-error ;
@ -559,4 +551,4 @@ TUPLE: custom-error ;
! This was a false trigger of the undecidable quotation
! recursion bug
[ { 2 1 } ] [ [ find-last-sep ] infer short-effect ] unit-test
{ 2 1 } [ find-last-sep ] unit-test-effect

2
core/io/io.factor
View File

@ -25,7 +25,7 @@ GENERIC: stream-write-table ( table-cells style stream -- )
[ stream-write ] keep stream-nl ;
: (stream-copy) ( in out -- )
64 1024 * pick stream-read
64 1024 * pick stream-read-partial
[ over stream-write (stream-copy) ] [ 2drop ] if* ;
: stream-copy ( in out -- )

39
core/system/system-docs.factor
View File

@ -1,5 +1,5 @@
USING: generic help.markup help.syntax kernel math memory
namespaces sequences kernel.private io.files ;
namespaces sequences kernel.private io.files strings ;
IN: system
ARTICLE: "os" "System interface"
@ -21,23 +21,27 @@ ARTICLE: "os" "System interface"
{ $subsection cell-bits }
"Reading environment variables:"
{ $subsection os-env }
{ $subsection os-envs }
"Getting the path to the Factor VM and image:"
{ $subsection vm }
{ $subsection image }
"Getting the current time:"
{ $subsection millis }
"Exiting the Factor VM:"
{ $subsection exit } ;
{ $subsection exit }
{ $see-also "file-streams" "network-streams" "io.launcher" "io.mmap" } ;
ABOUT: "os"
HELP: cpu
{ $values { "cpu" "a string" } }
{ $values { "cpu" string } }
{ $description
"Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:"
{ $code "x86.32" "x86.64" "ppc" "arm" }
} ;
HELP: os
{ $values { "os" "a string" } }
{ $values { "os" string } }
{ $description
"Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:"
{ $code
@ -87,17 +91,28 @@ HELP: exit ( n -- )
{ $description "Exits the Factor process." } ;
HELP: millis ( -- n )
{ $values { "n" "an integer" } }
{ $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." } ;
{ $values { "n" integer } }
{ $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." }
{ $notes "This is a low-level word. The " { $vocab-link "calendar" } " vocabulary provides features for date/time arithmetic and formatting." } ;
HELP: os-env ( key -- value )
{ $values { "key" "a string" } { "value" "a string" } }
{ $values { "key" string } { "value" string } }
{ $description "Looks up the value of a shell environment variable." }
{ $examples
"This is an operating system-specific feature. On Unix, you can do:"
{ $unchecked-example "\"USER\" os-env print" "jane" }
}
{ $errors "Windows CE has no concept of ``environment variables'', so this word throws an error there." } ;
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
HELP: os-envs
{ $values { "assoc" "an association mapping strings to strings" } }
{ $description "Outputs the current set of environment variables." }
{ $notes
"Names and values of environment variables are operating system-specific."
}
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
{ os-env os-envs } related-words
HELP: win32?
{ $values { "?" "a boolean" } }
@ -124,11 +139,11 @@ HELP: cell
{ $description "Outputs the pointer size in bytes of the current CPU architecture." } ;
HELP: cells
{ $values { "m" "an integer" } { "n" "an integer" } }
{ $values { "m" integer } { "n" integer } }
{ $description "Computes the number of bytes used by " { $snippet "m" } " CPU operand-sized cells." } ;
HELP: cell-bits
{ $values { "n" "an integer" } }
{ $values { "n" integer } }
{ $description "Outputs the number of bits in one CPU operand-sized cell." } ;
HELP: bootstrap-cell
@ -136,9 +151,9 @@ HELP: bootstrap-cell
{ $description "Outputs the pointer size in bytes for the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
HELP: bootstrap-cells
{ $values { "m" "an integer" } { "n" "an integer" } }
{ $values { "m" integer } { "n" integer } }
{ $description "Computes the number of bytes used by " { $snippet "m" } " cells in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
HELP: bootstrap-cell-bits
{ $values { "n" "an integer" } }
{ $values { "n" integer } }
{ $description "Outputs the number of bits in one cell in the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;

1
core/words/words-docs.factor
View File

@ -161,6 +161,7 @@ $nl
{ $subsection word? }
{ $subsection "interned-words" }
{ $subsection "word-definition" }
{ $subsection "word-props" }
{ $subsection "word.private" }
{ $see-also "vocabularies" "vocabs.loader" "definitions" } ;

2
extra/color-picker/color-picker.factor
View File

@ -18,7 +18,7 @@ TUPLE: color-preview ;
{ 100 100 } over set-rect-dim ;
M: color-preview model-changed
dup control-value over set-gadget-interior relayout-1 ;
swap model-value over set-gadget-interior relayout-1 ;
: <color-model> ( model -- model )
[ [ 256 /f ] map 1 add <solid> ] <filter> ;

2
extra/help/cookbook/cookbook.factor
View File

@ -217,7 +217,7 @@ ARTICLE: "cookbook-io" "I/O cookbook"
} ;
ARTICLE: "cookbook-philosophy" "Factor philosophy"
"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might me related to the amount of code you " { $emphasis "don't" } " have to write."
"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might be related to the amount of code you " { $emphasis "don't" } " have to write."
$nl
"If you try to write Factor word definitions which are longer than a couple of lines, you will find it hard to keep track of the stack contents. Well-written Factor code is " { $emphasis "factored" } " into short definitions, where each definition is easy to test interactively, and has a clear purpose. Well-chosen word names are critical, and having a thesaurus on hand really helps."
$nl

6
extra/help/handbook/handbook.factor
View File

@ -131,7 +131,7 @@ ARTICLE: "collections" "Collections"
{ $subsection "graphs" }
{ $subsection "buffers" } ;
USE: io.sockets
USING: io.sockets io.launcher io.mmap ;
ARTICLE: "io" "Input and output"
{ $subsection "streams" }
@ -144,7 +144,9 @@ ARTICLE: "io" "Input and output"
"Advanced features:"
{ $subsection "stream-binary" }
{ $subsection "styles" }
{ $subsection "network-streams" } ;
{ $subsection "network-streams" }
{ $subsection "io.launcher" }
{ $subsection "io.mmap" } ;
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.annotations" }

113
extra/io/launcher/launcher-docs.factor Normal file
View File

@ -0,0 +1,113 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.launcher quotations kernel ;
IN: io.launcher
HELP: +command+
{ $description "Launch descriptor key. A command line string, to be processed by the system's shell." } ;
HELP: +arguments+
{ $description "Launch descriptor key. A sequence of command line argument strings. The first element is the program to launch and the remaining arguments are passed to the program without further processing." } ;
HELP: +detached+
{ $description "Launch descriptor key. A boolean indicating whether " { $link run-process } " will return immediately, rather than wait for the program to complete."
$nl
"Default value is " { $link f } "." }
{ $notes "Cannot be used with " { $link <process-stream> } "." }
{ $see-also run-detached } ;
HELP: +environment+
{ $description "Launch descriptor key. An association mapping strings to strings, specifying environment variables to set for the spawned process. The association is combined with the current environment using the operation specified by the " { $link +environment-mode+ } " launch descriptor key."
$nl
"Default value is an empty association." } ;
HELP: +environment-mode+
{ $description "Launch descriptor key. Must equal of the following:"
{ $list
{ $link prepend-environment }
{ $link replace-environment }
{ $link append-environment }
}
"Default value is " { $link append-environment } "."
} ;
HELP: prepend-environment
{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence."
$nl
"This is used in situations where you want to spawn a child process with some default environment variables set, but allowing the user to override these defaults by changing the environment before launching Factor." } ;
HELP: replace-environment
{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key."
$nl
"This is used in situations where you want full control over a child process environment, perhaps for security or testing." } ;
HELP: append-environment
{ $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the current environment together with the value of the " { $link +environment+ } " key, with entries from the " { $link +environment+ } " key taking precedence."
$nl
"This is used in situations where you want a spawn child process with some overridden environment variables." } ;
HELP: default-descriptor
{ $description "Association storing default values for launch descriptor keys." } ;
HELP: with-descriptor
{ $values { "desc" "a launch descriptor" } { "quot" quotation } }
{ $description "Calls the quotation in a dynamic scope where keys from " { $snippet "desc" } " can be read as variables, and any keys not supplied assume their default value as set in " { $link default-descriptor } "." } ;
HELP: get-environment
{ $values { "env" "an association" } }
{ $description "Combines the current environment with the value of " { $link +environment+ } " using " { $link +environment-mode+ } "." } ;
HELP: run-process*
{ $values { "desc" "a launch descriptor" } }
{ $contract "Launches a process using the launch descriptor." }
{ $notes "User code should call " { $link run-process } " instead." } ;
HELP: >descriptor
{ $values { "obj" object } { "desc" "a launch descriptor" } }
{ $description "Creates a launch descriptor from an object, which must be one of the following:"
{ $list
{ "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" }
{ "a sequence of strings -- this is wrapped in a launch descriptor with a single " { $link +arguments+ } " key" }
{ "an association, used to set launch parameters for additional control" }
}
} ;
HELP: run-process
{ $values { "obj" object } }
{ $contract "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } ;
HELP: run-detached
{ $values { "obj" object } }
{ $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." }
{ $notes
"This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set."
} ;
HELP: <process-stream>
{ $values { "obj" object } { "stream" "a bidirectional stream" } }
{ $description "Launches a process and redirects its input and output via a paper of pipes which may be read and written as a stream." }
{ $notes "Closing the stream will block until the process exits." } ;
{ run-process run-detached <process-stream> } related-words
ARTICLE: "io.launcher" "Launching OS processes"
"The " { $vocab-link "io.launcher" } " vocabulary implements cross-platform process launching."
$nl
"Words which launch processes can take either a command line string, a sequence of command line arguments, or a launch descriptor:"
{ $list
{ "strings are wrapped in a launch descriptor with a single " { $link +command+ } " key" }
{ "sequences of strings are wrapped in a launch descriptor with a single " { $link +arguments+ } " key" }
{ "launch descriptors are associations, which can set extra launch parameters for finer control" }
}
"A launch descriptor is an association containing keys from the below set:"
{ $subsection +command+ }
{ $subsection +arguments+ }
{ $subsection +detached+ }
{ $subsection +environment+ }
{ $subsection +environment-mode+ }
"The following words are used to launch processes:"
{ $subsection run-process }
{ $subsection run-detached }
{ $subsection <process-stream> } ;
ABOUT: "io.launcher"

38
extra/io/mmap/mmap-docs.factor Normal file
View File

@ -0,0 +1,38 @@
USING: help.markup help.syntax alien math ;
IN: io.mmap
HELP: mapped-file
{ $class-description "The class of memory-mapped files, opened by " { $link <mapped-file> } " and closed by " { $link close-mapped-file } ". The following two slots are of interest to users:"
{ $list
{ { $link mapped-file-length } " - the length of the mapped file area, in bytes" }
{ { $link mapped-file-address } " - an " { $link alien } " pointing at the file's memory area" }
}
} ;
HELP: <mapped-file>
{ $values { "path" "a pathname string" } { "length" integer } { "mmap" mapped-file } }
{ $contract "Opens a file and maps the first " { $snippet "length" } " bytes into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." }
{ $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: (close-mapped-file)
{ $values { "mmap" mapped-file } }
{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link close-mapped-file } " instead." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
HELP: close-mapped-file
{ $values { "mmap" mapped-file } }
{ $description "Releases system resources associated with the mapped file." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
ARTICLE: "io.mmap" "Memory-mapped files"
"The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
{ $subsection <mapped-file> }
{ $subsection close-mapped-file }
"A combinator which wraps the above two words:"
{ $subsection with-mapped-file }
"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:"
{ $subsection mapped-file-address }
"Data can be read and written from the memory area using alien words. See " { $link "reading-writing-memory" } "." ;
ABOUT: "io.mmap"

21
extra/io/mmap/mmap.factor Normal file → Executable file
View File

@ -4,20 +4,31 @@ USING: continuations io.backend kernel quotations sequences
system alien sequences.private ;
IN: io.mmap
TUPLE: mapped-file length address handle ;
TUPLE: mapped-file length address handle closed? ;
M: mapped-file length mapped-file-length ;
: check-closed ( mapped-file -- mapped-file )
dup mapped-file-closed? [
"Mapped file is closed" throw
] when ; inline
M: mapped-file length check-closed mapped-file-length ;
M: mapped-file nth-unsafe
mapped-file-address swap alien-unsigned-1 ;
check-closed mapped-file-address swap alien-unsigned-1 ;
M: mapped-file set-nth-unsafe
mapped-file-address swap set-alien-unsigned-1 ;
check-closed mapped-file-address swap set-alien-unsigned-1 ;
INSTANCE: mapped-file sequence
HOOK: <mapped-file> io-backend ( path length -- mmap )
HOOK: close-mapped-file io-backend ( mmap -- )
HOOK: (close-mapped-file) io-backend ( mmap -- )
: close-mapped-file ( mmap -- )
check-closed
t over set-mapped-file-closed?
(close-mapped-file) ;
: with-mapped-file ( path length quot -- )
>r <mapped-file> r>

2
extra/io/unix/mmap/mmap.factor
View File

@ -15,7 +15,7 @@ M: unix-io <mapped-file> ( path length -- obj )
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
r> mmap-open \ mapped-file construct-boa ;
M: unix-io close-mapped-file ( mmap -- )
M: unix-io (close-mapped-file) ( mmap -- )
[ mapped-file-address ] keep
[ mapped-file-length munmap ] keep
mapped-file-handle close

46
extra/io/windows/launcher/launcher.factor
View File

@ -1,8 +1,7 @@
USING: alien alien.c-types arrays continuations
destructors io io.windows libc
io.nonblocking io.streams.duplex windows.types math
windows.kernel32 windows namespaces io.launcher kernel
sequences io.windows.nt.backend windows.errors assocs ;
USING: alien alien.c-types arrays continuations destructors io
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system ;
IN: io.windows.launcher
! From MSDN: "Handles in PROCESS_INFORMATION must be closed with CloseHandle when they are no longer needed."
@ -52,19 +51,30 @@ TUPLE: CreateProcess-args
CreateProcess-args-lpProcessInformation
} get-slots CreateProcess win32-error=0/f ;
: fill-lpCommandLine
: join-arguments ( args -- cmd-line )
[ "\"" swap "\"" 3append ] map " " join ;
: app-name/cmd-line ( -- app-name cmd-line )
+command+ get [
[
+arguments+ get [ CHAR: \s , ] [
CHAR: " ,
[ dup CHAR: " = [ CHAR: \\ , ] when , ] each
CHAR: " ,
] interleave
] "" make
] unless* over set-CreateProcess-args-lpCommandLine ;
" " split1
] [
+arguments+ get unclip swap join-arguments
] if* ;
: cmd-line ( -- cmd-line )
+command+ get [ +arguments+ get join-arguments ] unless* ;
: fill-lpApplicationName
app-name/cmd-line
pick set-CreateProcess-args-lpCommandLine
over set-CreateProcess-args-lpApplicationName ;
: fill-lpCommandLine
cmd-line over set-CreateProcess-args-lpCommandLine ;
: fill-dwCreateFlags
CREATE_UNICODE_ENVIRONMENT
0
pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
+detached+ get [ DETACHED_PROCESS bitor ] when
over set-CreateProcess-args-dwCreateFlags ;
@ -86,7 +96,11 @@ TUPLE: CreateProcess-args
M: windows-io run-process* ( desc -- )
[
default-CreateProcess-args
fill-lpCommandLine
wince? [
fill-lpApplicationName
] [
fill-lpCommandLine
] if
fill-dwCreateFlags
fill-lpEnvironment
dup call-CreateProcess

33
extra/io/windows/mmap/mmap.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
USING: alien alien.c-types alien.syntax arrays continuations
destructors generic io.mmap io.nonblocking io.windows
kernel libc math namespaces quotations sequences windows
windows.advapi32 windows.kernel32 ;
windows.advapi32 windows.kernel32 io.backend ;
IN: io.windows.mmap
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
@ -51,12 +51,16 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
dup length f f AdjustTokenPrivileges win32-error=0/f
] with-process-token ;
: with-privileges ( seq quot -- )
HOOK: with-privileges io-backend ( seq quot -- ) inline
M: windows-nt-io with-privileges
over [ [ t set-privilege ] each ] curry compose
swap [ [ f set-privilege ] each ] curry [ ] cleanup ;
: mmap-open ( path access-mode create-mode flProtect access length -- handle handle address )
drop
M: windows-ce-io with-privileges
nip call ;
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
>r >r open-file dup f r> 0 0 f
CreateFileMapping [ win32-error=0/f ] keep
@ -68,20 +72,17 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
M: windows-io <mapped-file> ( path length -- mmap )
[
[
>r
GENERIC_WRITE GENERIC_READ bitor
OPEN_ALWAYS
PAGE_READWRITE SEC_COMMIT bitor
FILE_MAP_ALL_ACCESS r> mmap-open
] keep
-roll -rot 2array \ mapped-file construct-boa
swap
GENERIC_WRITE GENERIC_READ bitor
OPEN_ALWAYS
PAGE_READWRITE SEC_COMMIT bitor
FILE_MAP_ALL_ACCESS mmap-open
-rot 2array
\ mapped-file construct-boa
] with-destructors ;
M: windows-io close-mapped-file ( mapped-file -- )
M: windows-io (close-mapped-file) ( mapped-file -- )
[
dup mapped-file-handle [
close-always
] each
dup mapped-file-handle [ close-always ] each
mapped-file-address UnmapViewOfFile win32-error=0/f
] with-destructors ;

16
extra/io/windows/windows-tests.factor Executable file
View File

@ -0,0 +1,16 @@
USING: io.files kernel tools.test ;
IN: temporary
[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
[ "c:" ] [ "c:" parent-directory ] unit-test
[ "Z:" ] [ "Z:" parent-directory ] unit-test
[ t ] [ "c:\\" root-directory? ] unit-test
[ t ] [ "Z:\\" root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test

2
extra/models/models-tests.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ TUPLE: model-tester hit? ;
: <model-tester> model-tester construct-empty ;
M: model-tester model-changed t swap set-model-tester-hit? ;
M: model-tester model-changed nip t swap set-model-tester-hit? ;
[ T{ model-tester f t } ]
[

52
extra/models/models.factor Normal file → Executable file
View File

@ -3,10 +3,10 @@
USING: generic kernel math sequences timers arrays assocs ;
IN: models
TUPLE: model value connections dependencies ref ;
TUPLE: model value connections dependencies ref locked? ;
: <model> ( value -- model )
V{ } clone V{ } clone 0 model construct-boa ;
V{ } clone V{ } clone 0 f model construct-boa ;
M: model equal? 2drop f ;
@ -49,7 +49,7 @@ DEFER: remove-connection
drop
] if ;
GENERIC: model-changed ( observer -- )
GENERIC: model-changed ( model observer -- )
: add-connection ( observer model -- )
dup model-connections empty? [ dup activate-model ] when
@ -60,11 +60,26 @@ GENERIC: model-changed ( observer -- )
dup model-connections empty? [ dup deactivate-model ] when
drop ;
GENERIC: set-model ( value model -- )
: with-locked-model ( model quot -- )
swap
t over set-model-locked?
slip
f swap set-model-locked? ; inline
M: model set-model
[ set-model-value ] keep
model-connections [ model-changed ] each ;
GENERIC: update-model ( model -- )
M: model update-model drop ;
: set-model ( value model -- )
dup model-locked? [
2drop
] [
dup [
[ set-model-value ] keep
[ update-model ] keep
dup model-connections [ model-changed ] curry* each
] with-locked-model
] if ;
: ((change-model)) ( model quot -- newvalue model )
over >r >r model-value r> call r> ; inline
@ -87,10 +102,10 @@ TUPLE: filter model quot ;
[ add-dependency ] keep ;
M: filter model-changed
dup filter-model model-value over filter-quot call
swap model-value over filter-quot call
swap set-model ;
M: filter model-activated model-changed ;
M: filter model-activated dup filter-model swap model-changed ;
TUPLE: compose ;
@ -103,11 +118,13 @@ TUPLE: compose ;
: set-composed-value >r model-dependencies r> 2each ; inline
M: compose model-changed
nip
dup [ model-value ] composed-value swap delegate set-model ;
M: compose model-activated model-changed ;
M: compose model-activated dup model-changed ;
M: compose set-model [ set-model ] set-composed-value ;
M: compose update-model
dup model-value swap [ set-model ] set-composed-value ;
TUPLE: mapping assoc ;
@ -117,13 +134,15 @@ TUPLE: mapping assoc ;
tuck set-mapping-assoc ;
M: mapping model-changed
nip
dup mapping-assoc [ model-value ] assoc-map
swap delegate set-model ;
M: mapping model-activated model-changed ;
M: mapping model-activated dup model-changed ;
M: mapping set-model
mapping-assoc [ swapd at set-model ] curry assoc-each ;
M: mapping update-model
dup model-value swap mapping-assoc
[ swapd at set-model ] curry assoc-each ;
TUPLE: history back forward ;
@ -161,10 +180,9 @@ TUPLE: delay model timeout ;
f delay construct-model
[ set-delay-timeout ] keep
[ set-delay-model ] 2keep
[ add-dependency ] keep
dup update-delay-model ;
[ add-dependency ] keep ;
M: delay model-changed 0 over delay-timeout add-timer ;
M: delay model-changed nip 0 over delay-timeout add-timer ;
M: delay model-activated update-delay-model ;

9
extra/tools/test/inference/inference.factor Executable file
View File

@ -0,0 +1,9 @@
USING: effects sequences kernel arrays quotations inference
tools.test ;
IN: tools.test.inference
: short-effect
dup effect-in length swap effect-out length 2array ;
: unit-test-effect ( effect quot -- )
>r 1quotation r> [ infer short-effect ] curry unit-test ;

16
extra/tools/test/ui/ui.factor Executable file
View File

@ -0,0 +1,16 @@
USING: dlists ui.gadgets kernel ui namespaces io.streams.string
io ;
IN: tools.test.ui
! We can't print to stdio here because that might be a pane
! stream, and our graft-queue rebinding here would be captured
! by code adding children to the pane...
: with-grafted-gadget ( gadget quot -- )
[
<dlist> \ graft-queue [
over
graft notify-queued
swap slip
ungraft notify-queued
] with-variable
] string-out print ;

1
extra/ui/cocoa/cocoa.factor Normal file → Executable file
View File

@ -62,7 +62,6 @@ M: cocoa-ui-backend set-title ( string world -- )
M: cocoa-ui-backend (open-world-window) ( world -- )
dup gadget-window
dup start-world
dup auto-position
world-handle second f -> makeKeyAndOrderFront: ;

4
extra/ui/gadgets/books/books-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: temporary
USING: tools.test.inference ui.gadgets.books ;
{ 2 1 } [ <book> ] unit-test-effect

7
extra/ui/gadgets/books/books.factor
View File

@ -10,15 +10,14 @@ TUPLE: book ;
: current-page ( book -- gadget )
[ control-value ] keep nth-gadget ;
M: book model-changed ( book -- )
M: book model-changed
nip
dup hide-all
dup current-page show-gadget
relayout ;
: <book> ( pages model -- book )
<gadget> book construct-control
[ add-gadgets ] keep
[ model-changed ] keep ;
<gadget> book construct-control [ add-gadgets ] keep ;
M: book pref-dim* gadget-children pref-dims max-dim ;

9
extra/ui/gadgets/buttons/buttons-tests.factor
View File

@ -1,6 +1,7 @@
IN: temporary
USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
ui.gadgets tools.test namespaces sequences kernel models ;
ui.gadgets tools.test namespaces sequences kernel models
tools.test.inference ;
TUPLE: foo-gadget ;
@ -27,6 +28,12 @@ T{ foo-gadget } <toolbar> "t" set
} <radio-buttons> "religion" set
] unit-test
{ 2 1 } [ <radio-buttons> ] unit-test-effect
{ 2 1 } [ <toggle-buttons> ] unit-test-effect
{ 2 1 } [ <checkbox> ] unit-test-effect
[ 0 ] [
"religion" get gadget-child radio-control-value
] unit-test

4
extra/ui/gadgets/buttons/buttons.factor
View File

@ -141,7 +141,7 @@ TUPLE: checkbox ;
dup checkbox-theme ;
M: checkbox model-changed
dup control-value over set-button-selected? relayout-1 ;
swap model-value over set-button-selected? relayout-1 ;
TUPLE: radio-paint color ;
@ -178,7 +178,7 @@ TUPLE: radio-control value ;
tuck set-radio-control-value ; inline
M: radio-control model-changed
dup control-value
swap model-value
over radio-control-value =
over set-button-selected?
relayout-1 ;

3
extra/ui/gadgets/editors/editors-docs.factor
View File

@ -16,9 +16,6 @@ $nl
{ { $link editor-focused? } " - a boolean." }
} } ;
HELP: loc-monitor
{ $class-description "Instances of this class are used internally by " { $link editor } " controls to redraw the editor when the caret or mark is moved by calling " { $link set-model } " on " { $link editor-caret } " or " { $link editor-mark } "." } ;
HELP: <editor>
{ $values { "editor" "a new " { $link editor } } }
{ $description "Creates a new " { $link editor } " with an empty document." } ;

45
extra/ui/gadgets/editors/editors-tests.factor Normal file → Executable file
View File

@ -1,38 +1,33 @@
USING: ui.gadgets.editors tools.test kernel io io.streams.plain
io.streams.string definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures ;
[ t ] [
<editor> "editor" set
"editor" get graft*
"editor" get <plain-writer> [ \ = see ] with-stream
"editor" get editor-string [ \ = see ] string-out =
"editor" get ungraft*
] unit-test
definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures
tools.test.inference tools.test.ui ;
[ "foo bar" ] [
<editor> "editor" set
"editor" get graft*
"foo bar" "editor" get set-editor-string
"editor" get T{ one-line-elt } select-elt
"editor" get gadget-selection
"editor" get ungraft*
"editor" get [
"foo bar" "editor" get set-editor-string
"editor" get T{ one-line-elt } select-elt
"editor" get gadget-selection
] with-grafted-gadget
] unit-test
[ "baz quux" ] [
<editor> "editor" set
"editor" get graft*
"foo bar\nbaz quux" "editor" get set-editor-string
"editor" get T{ one-line-elt } select-elt
"editor" get gadget-selection
"editor" get ungraft*
"editor" get [
"foo bar\nbaz quux" "editor" get set-editor-string
"editor" get T{ one-line-elt } select-elt
"editor" get gadget-selection
] with-grafted-gadget
] unit-test
[ ] [
<editor> "editor" set
"editor" get graft*
"foo bar\nbaz quux" "editor" get set-editor-string
4 hand-click# set
"editor" get position-caret
"editor" get ungraft*
"editor" get [
"foo bar\nbaz quux" "editor" get set-editor-string
4 hand-click# set
"editor" get position-caret
] with-grafted-gadget
] unit-test
{ 0 1 } [ <editor> ] unit-test-effect

64
extra/ui/gadgets/editors/editors.factor
View File

@ -2,10 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays documents ui.clipboards ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.theme
ui.render ui.gestures io kernel math models namespaces opengl
opengl.gl sequences strings io.styles math.vectors sorting
colors combinators ;
ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io
kernel math models namespaces opengl opengl.gl sequences strings
io.styles math.vectors sorting colors combinators ;
IN: ui.gadgets.editors
TUPLE: editor
@ -14,15 +13,11 @@ font color caret-color selection-color
caret mark
focused? ;
TUPLE: loc-monitor editor ;
: <loc> ( editor -- loc )
loc-monitor construct-boa
{ 0 0 } <model> [ add-connection ] keep ;
: <loc> ( -- loc ) { 0 0 } <model> ;
: init-editor-locs ( editor -- )
dup <loc> over set-editor-caret
dup <loc> swap set-editor-mark ;
<loc> over set-editor-caret
<loc> swap set-editor-mark ;
: editor-theme ( editor -- )
black over set-editor-color
@ -48,10 +43,14 @@ TUPLE: source-editor ;
: <source-editor> source-editor construct-editor ;
: activate-editor-model ( editor model -- )
dup activate-model swap gadget-model add-loc ;
2dup add-connection
dup activate-model
swap gadget-model add-loc ;
: deactivate-editor-model ( editor model -- )
dup deactivate-model swap gadget-model remove-loc ;
2dup remove-connection
dup deactivate-model
swap gadget-model remove-loc ;
M: editor graft*
dup
@ -63,12 +62,6 @@ M: editor ungraft*
dup editor-caret deactivate-editor-model
dup editor-mark deactivate-editor-model ;
M: editor model-changed
dup gadget-model
over editor-caret [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model)
drop editor-self relayout ;
: editor-caret* ( editor -- loc ) editor-caret model-value ;
: editor-mark* ( editor -- loc ) editor-mark model-value ;
@ -129,15 +122,11 @@ M: editor model-changed
line-height 0 swap 2array ;
: scroll>caret ( editor -- )
dup gadget-grafted? [
dup gadget-graft-state second [
dup caret-loc over caret-dim { 1 0 } v+ <rect>
over scroll>rect
] when drop ;
M: loc-monitor model-changed
loc-monitor-editor editor-self
dup relayout-1 scroll>caret ;
: draw-caret ( -- )
editor get editor-focused? [
editor get
@ -219,6 +208,22 @@ M: editor draw-gadget*
M: editor pref-dim*
dup editor-font* swap control-value text-dim ;
: contents-changed
editor-self swap
over editor-caret [ over validate-loc ] (change-model)
over editor-mark [ over validate-loc ] (change-model)
drop relayout ;
: caret/mark-changed
nip editor-self dup relayout-1 scroll>caret ;
M: editor model-changed
{
{ [ 2dup gadget-model eq? ] [ contents-changed ] }
{ [ 2dup editor-caret eq? ] [ caret/mark-changed ] }
{ [ 2dup editor-mark eq? ] [ caret/mark-changed ] }
} cond ;
M: editor gadget-selection?
selection-start/end = not ;
@ -421,16 +426,6 @@ editor "selection" f {
{ T{ key-down f { S+ C+ } "END" } select-end-of-document }
} define-command-map
! Editors support the stream output protocol
M: editor stream-write1 >r 1string r> stream-write ;
M: editor stream-write
editor-self dup end-of-document user-input ;
M: editor stream-close drop ;
M: editor stream-flush drop ;
! Fields are like editors except they edit an external model
TUPLE: field model editor ;
@ -453,5 +448,6 @@ M: field ungraft*
dup field-editor gadget-model remove-connection ;
M: field model-changed
nip
dup field-editor editor-string
swap field-model set-model ;

100
extra/ui/gadgets/gadgets-tests.factor Normal file → Executable file
View File

@ -1,6 +1,8 @@
IN: temporary
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
namespaces models kernel ;
namespaces models kernel tools.test.inference dlists math
math.parser ui sequences hashtables assocs io arrays
prettyprint io.streams.string ;
[ T{ rect f { 10 10 } { 20 20 } } ]
[
@ -49,11 +51,11 @@ C: <fooey> fooey
"a" get "b" get add-gadget
<gadget> "c" set
"b" get "c" get add-gadget
! position a and b
{ 100 200 } "a" get set-rect-loc
{ 200 100 } "b" get set-rect-loc
! give c a loc, it doesn't matter
{ -1000 23 } "c" get set-rect-loc
@ -108,3 +110,95 @@ C: <fooey> fooey
{ 1 1 } "g4" get set-rect-dim
[ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
TUPLE: mock-gadget graft-called ungraft-called ;
: <mock-gadget>
0 0 mock-gadget construct-boa <gadget> over set-delegate ;
M: mock-gadget graft*
dup mock-gadget-graft-called 1+
swap set-mock-gadget-graft-called ;
M: mock-gadget ungraft*
dup mock-gadget-ungraft-called 1+
swap set-mock-gadget-ungraft-called ;
! We can't print to stdio here because that might be a pane
! stream, and our graft-queue rebinding here would be captured
! by code adding children to the pane...
[
<dlist> \ graft-queue [
[ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
[ t ] [ graft-queue dlist-empty? ] unit-test
] with-variable
<dlist> \ graft-queue [
[ t ] [ graft-queue dlist-empty? ] unit-test
<mock-gadget> "g" set
[ ] [ "g" get queue-graft ] unit-test
[ f ] [ graft-queue dlist-empty? ] unit-test
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ { f t } ] [ "g" get gadget-graft-state ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ { f f } ] [ "g" get gadget-graft-state ] unit-test
[ t ] [ graft-queue dlist-empty? ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ ] [ notify-queued ] unit-test
[ { t t } ] [ "g" get gadget-graft-state ] unit-test
[ t ] [ graft-queue dlist-empty? ] unit-test
[ ] [ "g" get graft-later ] unit-test
[ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
[ ] [ "g" get ungraft-later ] unit-test
[ { t f } ] [ "g" get gadget-graft-state ] unit-test
[ ] [ notify-queued ] unit-test
[ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
[ { f f } ] [ "g" get gadget-graft-state ] unit-test
] with-variable
: add-some-children
3 [
<mock-gadget> over <model> over set-gadget-model
dup "g" get add-gadget
swap 1+ number>string set
] each ;
: status-flags
{ "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ;
: notify-combo ( ? ? -- )
nl "===== Combo: " write 2dup 2array . nl
<dlist> \ graft-queue [
<mock-gadget> "g" set
[ ] [ add-some-children ] unit-test
[ V{ { f f } } ] [ status-flags ] unit-test
[ ] [ "g" get graft ] unit-test
[ V{ { f t } } ] [ status-flags ] unit-test
dup [ [ ] [ notify-queued ] unit-test ] when
[ ] [ "g" get clear-gadget ] unit-test
[ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
[ [ ] [ notify-queued ] unit-test ] when
[ ] [ add-some-children ] unit-test
[ { f t } ] [ "1" get gadget-graft-state ] unit-test
[ { f t } ] [ "2" get gadget-graft-state ] unit-test
[ { f t } ] [ "3" get gadget-graft-state ] unit-test
[ ] [ [ "x" print notify ] graft-queue swap dlist-slurp ] unit-test
[ ] [ notify-queued ] unit-test
[ V{ { t t } } ] [ status-flags ] unit-test
] with-variable ;
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
] string-out print
{ 0 1 } [ <gadget> ] unit-test-effect
{ 1 0 } [ unparent ] unit-test-effect
{ 2 0 } [ add-gadget ] unit-test-effect
{ 2 0 } [ add-gadgets ] unit-test-effect
{ 1 0 } [ clear-gadget ] unit-test-effect
{ 1 0 } [ relayout ] unit-test-effect
{ 1 0 } [ relayout-1 ] unit-test-effect
{ 1 1 } [ pref-dim ] unit-test-effect

91
extra/ui/gadgets/gadgets.factor
View File

@ -41,8 +41,8 @@ M: array rect-dim drop { 0 0 } ;
(rect-union) <extent-rect> ;
TUPLE: gadget
pref-dim parent children orientation state focus
visible? root? clipped? grafted?
pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state
interior boundary
model ;
@ -50,7 +50,7 @@ M: gadget equal? 2drop f ;
M: gadget hashcode* drop gadget hashcode* ;
M: gadget model-changed drop ;
M: gadget model-changed 2drop ;
: gadget-child ( gadget -- child ) gadget-children first ;
@ -59,10 +59,11 @@ M: gadget model-changed drop ;
: <zero-rect> ( -- rect ) { 0 0 } dup <rect> ;
: <gadget> ( -- gadget )
<zero-rect> { 0 1 } t {
<zero-rect> { 0 1 } t { f f } {
set-delegate
set-gadget-orientation
set-gadget-visible?
set-gadget-graft-state
} gadget construct ;
: construct-gadget ( class -- tuple )
@ -70,7 +71,7 @@ M: gadget model-changed drop ;
: activate-control ( gadget -- )
dup gadget-model dup [ 2dup add-connection ] when drop
model-changed ;
dup gadget-model swap model-changed ;
: deactivate-control ( gadget -- )
dup gadget-model dup [ 2dup remove-connection ] when 2drop ;
@ -169,33 +170,33 @@ M: array gadget-text*
: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
: invalidate ( gadget -- )
\ invalidate swap set-gadget-state ;
\ invalidate swap set-gadget-layout-state ;
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
: invalid ( -- queue ) \ invalid get-global ;
: layout-queue ( -- queue ) \ layout-queue get ;
: add-invalid ( gadget -- )
: layout-later ( gadget -- )
#! When unit testing gadgets without the UI running, the
#! invalid queue is not initialized and we simply ignore
#! invalidation requests.
invalid [ push-front ] [ drop ] if* ;
layout-queue [ push-front ] [ drop ] if* ;
DEFER: relayout
: invalidate* ( gadget -- )
\ invalidate* over set-gadget-state
\ invalidate* over set-gadget-layout-state
dup forget-pref-dim
dup gadget-root?
[ add-invalid ] [ gadget-parent [ relayout ] when* ] if ;
[ layout-later ] [ gadget-parent [ relayout ] when* ] if ;
: relayout ( gadget -- )
dup gadget-state \ invalidate* eq?
dup gadget-layout-state \ invalidate* eq?
[ drop ] [ invalidate* ] if ;
: relayout-1 ( gadget -- )
dup gadget-state
[ drop ] [ dup invalidate add-invalid ] if ;
dup gadget-layout-state
[ drop ] [ dup invalidate layout-later ] if ;
: show-gadget t swap set-gadget-visible? ;
@ -215,7 +216,8 @@ DEFER: relayout
GENERIC: pref-dim* ( gadget -- dim )
: ?set-gadget-pref-dim ( dim gadget -- )
dup gadget-state [ 2drop ] [ set-gadget-pref-dim ] if ;
dup gadget-layout-state
[ 2drop ] [ set-gadget-pref-dim ] if ;
: pref-dim ( gadget -- dim )
dup gadget-pref-dim [ ] [
@ -232,36 +234,59 @@ M: gadget layout* drop ;
: prefer ( gadget -- ) dup pref-dim swap set-layout-dim ;
: validate ( gadget -- ) f swap set-gadget-state ;
: validate ( gadget -- ) f swap set-gadget-layout-state ;
: layout ( gadget -- )
dup gadget-state [
dup gadget-layout-state [
dup validate
dup layout*
dup [ layout ] each-child
] when drop ;
: graft-queue \ graft-queue get ;
: unqueue-graft ( gadget -- )
dup graft-queue dlist-delete [ "Not queued" throw ] unless
dup gadget-graft-state first { t t } { f f } ?
swap set-gadget-graft-state ;
: queue-graft ( gadget -- )
{ f t } over set-gadget-graft-state
graft-queue push-front ;
: queue-ungraft ( gadget -- )
{ t f } over set-gadget-graft-state
graft-queue push-front ;
: graft-later ( gadget -- )
dup gadget-graft-state {
{ { f t } [ drop ] }
{ { t t } [ drop ] }
{ { t f } [ unqueue-graft ] }
{ { f f } [ queue-graft ] }
} case ;
: ungraft-later ( gadget -- )
dup gadget-graft-state {
{ { f f } [ drop ] }
{ { t f } [ drop ] }
{ { f t } [ unqueue-graft ] }
{ { t t } [ queue-ungraft ] }
} case ;
GENERIC: graft* ( gadget -- )
M: gadget graft* drop ;
: graft ( gadget -- )
t over set-gadget-grafted?
dup graft*
dup activate-control
[ graft ] each-child ;
dup graft-later [ graft ] each-child ;
GENERIC: ungraft* ( gadget -- )
M: gadget ungraft* drop ;
: ungraft ( gadget -- )
dup gadget-grafted? [
dup [ ungraft ] each-child
dup deactivate-control
dup ungraft*
f over set-gadget-grafted?
] when drop ;
dup [ ungraft ] each-child ungraft-later ;
: (unparent) ( gadget -- )
dup ungraft
@ -272,7 +297,14 @@ M: gadget ungraft* drop ;
tuck gadget-focus eq?
[ f swap set-gadget-focus ] [ drop ] if ;
SYMBOL: in-layout?
: not-in-layout
in-layout? get
[ "Cannot add/remove gadgets in layout*" throw ] when ;
: unparent ( gadget -- )
not-in-layout
[
dup gadget-parent dup [
over (unparent)
@ -290,6 +322,7 @@ M: gadget ungraft* drop ;
f swap set-gadget-children ;
: clear-gadget ( gadget -- )
not-in-layout
dup (clear-gadget) relayout ;
: ((add-gadget)) ( gadget box -- )
@ -299,12 +332,14 @@ M: gadget ungraft* drop ;
over unparent
dup pick set-gadget-parent
[ ((add-gadget)) ] 2keep
gadget-grafted? [ graft ] [ drop ] if ;
gadget-graft-state second [ graft ] [ drop ] if ;
: add-gadget ( gadget parent -- )
not-in-layout
[ (add-gadget) ] keep relayout ;
: add-gadgets ( seq parent -- )
not-in-layout
swap [ over (add-gadget) ] each relayout ;
: parents ( gadget -- seq )

19
extra/ui/gadgets/incremental/incremental.factor Normal file → Executable file
View File

@ -11,17 +11,18 @@ IN: ui.gadgets.incremental
! pack-gap.
! The cursor is the current size of the incremental pack.
! New gadgets are added at cursor-cursor*gadget-orientation.
! New gadgets are added at
! incremental-cursor gadget-orientation v*
TUPLE: incremental cursor ;
: <incremental> ( pack -- incremental )
incremental construct-empty
[ set-gadget-delegate ] keep
dup delegate pref-dim over set-incremental-cursor ;
dup pref-dim
{ set-gadget-delegate set-incremental-cursor }
incremental construct ;
M: incremental pref-dim*
dup gadget-state [
dup gadget-layout-state [
dup delegate pref-dim over set-incremental-cursor
] when incremental-cursor ;
@ -39,9 +40,11 @@ M: incremental pref-dim*
swap set-rect-loc ;
: prefer-incremental ( gadget -- )
dup forget-pref-dim dup pref-dim over set-rect-dim layout ;
dup forget-pref-dim dup pref-dim over set-rect-dim
layout ;
: add-incremental ( gadget incremental -- )
not-in-layout
2dup (add-gadget)
over prefer-incremental
2dup incremental-loc
@ -50,6 +53,8 @@ M: incremental pref-dim*
gadget-parent [ invalidate* ] when* ;
: clear-incremental ( incremental -- )
dup (clear-gadget) dup forget-pref-dim
not-in-layout
dup (clear-gadget)
dup forget-pref-dim
{ 0 0 } over set-incremental-cursor
gadget-parent [ relayout ] when* ;

2
extra/ui/gadgets/labels/labels.factor
View File

@ -40,7 +40,7 @@ M: label gadget-text* label-string % ;
TUPLE: label-control ;
M: label-control model-changed
dup control-value over set-label-text relayout ;
swap model-value over set-label-text relayout ;
: <label-control> ( model -- gadget )
"" <label> label-control construct-control ;

1
extra/ui/gadgets/lists/lists.factor
View File

@ -42,6 +42,7 @@ TUPLE: list index presenter color hook ;
] map 2nip ;
M: list model-changed
nip
dup clear-gadget
dup <list-items> over add-gadgets
bound-index ;

7
extra/ui/gadgets/panes/panes-tests.factor Normal file → Executable file
View File

@ -1,7 +1,8 @@
IN: temporary
USING: alien ui.gadgets.panes ui.gadgets namespaces
kernel sequences io io.streams.string tools.test prettyprint
definitions help help.syntax help.markup splitting ;
definitions help help.syntax help.markup splitting
tools.test.ui models ;
: #children "pane" get gadget-children length ;
@ -33,3 +34,7 @@ ARTICLE: "test-article" "This is a test article"
<pane> [ \ = see ] with-pane
<pane> [ \ = help ] with-pane
[ ] [
\ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
] unit-test

2
extra/ui/gadgets/panes/panes.factor
View File

@ -140,7 +140,7 @@ M: duplex-stream write-gadget
TUPLE: pane-control quot ;
M: pane-control model-changed
dup control-value swap dup pane-control-quot with-pane ;
swap model-value swap dup pane-control-quot with-pane ;
: <pane-control> ( model quot -- pane )
>r <pane> pane-control construct-control r>

37
extra/ui/gadgets/scrollers/scrollers-tests.factor
View File

@ -2,7 +2,8 @@ IN: temporary
USING: ui.gadgets ui.gadgets.scrollers
namespaces tools.test kernel models ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
ui.gadgets.sliders math math.vectors arrays sequences ;
ui.gadgets.sliders math math.vectors arrays sequences
tools.test.inference tools.test.ui ;
[ ] [
<gadget> "g" set
@ -20,12 +21,14 @@ ui.gadgets.sliders math math.vectors arrays sequences ;
[ ] [
<gadget> dup "g" set
10 1 0 100 <range> 20 1 0 100 <range> 2array <compose>
<viewport> "v" set
<viewport> "v" set
] unit-test
[ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
"v" get [
[ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
] with-grafted-gadget
[ ] [
<gadget> { 100 100 } over set-rect-dim
@ -36,27 +39,25 @@ ui.gadgets.sliders math math.vectors arrays sequences ;
[ ] [ "s" get layout ] unit-test
[ ] [ "s" get graft ] unit-test
"s" get [
[ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
[ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
[ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
[ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
[ ] [ { 0 0 } "s" get scroll ] unit-test
[ ] [ { 0 0 } "s" get scroll ] unit-test
[ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
[ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
[ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
[ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
[ ] [ { 10 20 } "s" get scroll ] unit-test
[ ] [ { 10 20 } "s" get scroll ] unit-test
[ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
[ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
[ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
[ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
[ ] [ "s" get ungraft ] unit-test
[ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
] with-grafted-gadget
<gadget> { 600 400 } over set-rect-dim "g1" set
<gadget> { 600 10 } over set-rect-dim "g2" set
@ -84,3 +85,5 @@ dup layout
[ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
[ t ] [ "s" get @right grid-child slider? ] unit-test
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
{ 1 1 } [ <scroller> ] unit-test-effect

14
extra/ui/gadgets/scrollers/scrollers.factor
View File

@ -28,7 +28,7 @@ scroller H{
{ T{ mouse-scroll } [ do-mouse-scroll ] }
} set-gestures
: viewport, ( -- )
: viewport, ( child -- )
g gadget-model <viewport>
g-> set-scroller-viewport @center frame, ;
@ -106,7 +106,7 @@ scroller H{
dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
: scroll>bottom ( gadget -- )
find-scroller* [
find-scroller [
t over set-scroller-follows relayout-1
] when* ;
@ -115,10 +115,10 @@ scroller H{
: update-scroller ( scroller follows -- )
{
{ [ dup t eq? ] [ drop (scroll>bottom) "A" drop ] }
{ [ dup rect? ] [ swap (scroll>rect) "B" drop ] }
{ [ dup ] [ swap (scroll>gadget) "C" drop ] }
{ [ t ] [ drop dup scroller-value swap scroll "D" drop ] }
{ [ dup t eq? ] [ drop (scroll>bottom) ] }
{ [ dup rect? ] [ swap (scroll>rect) ] }
{ [ dup ] [ swap (scroll>gadget) ] }
{ [ t ] [ drop dup scroller-value swap scroll ] }
} cond ;
M: scroller layout*
@ -131,4 +131,4 @@ M: scroller focusable-child*
scroller-viewport ;
M: scroller model-changed
f swap set-scroller-follows ;
nip f swap set-scroller-follows ;

8
extra/ui/gadgets/sliders/sliders.factor
View File

@ -47,7 +47,7 @@ TUPLE: slider elevator thumb saved line ;
: screen>slider slider-scale / ;
M: slider model-changed slider-elevator relayout-1 ;
M: slider model-changed nip slider-elevator relayout-1 ;
TUPLE: thumb ;
@ -131,7 +131,7 @@ M: elevator layout*
: slide-by-line ( amount slider -- )
[ slider-line * ] keep slide-by ;
: <slide-button> ( vector polygon amount -- )
: <slide-button> ( vector polygon amount -- button )
>r gray swap <polygon-gadget> r>
[ swap find-slider slide-by-line ] curry <repeat-button>
[ set-gadget-orientation ] keep ;
@ -144,7 +144,7 @@ M: elevator layout*
: <left-button> { 0 1 } arrow-left -1 <slide-button> ;
: <right-button> { 0 1 } arrow-right 1 <slide-button> ;
: build-x-slider ( slider -- slider )
: build-x-slider ( slider -- )
[
<left-button> @left frame,
{ 0 1 } elevator,
@ -154,7 +154,7 @@ M: elevator layout*
: <up-button> { 1 0 } arrow-up -1 <slide-button> ;
: <down-button> { 1 0 } arrow-down 1 <slide-button> ;
: build-y-slider ( slider -- slider )
: build-y-slider ( slider -- )
[
<up-button> @top frame,
{ 1 0 } elevator,

4
extra/ui/gadgets/viewports/viewports.factor
View File

@ -16,8 +16,7 @@ TUPLE: viewport ;
: <viewport> ( content model -- viewport )
<gadget> viewport construct-control
t over set-gadget-clipped?
[ add-gadget ] keep
[ model-changed ] keep ;
[ add-gadget ] keep ;
M: viewport layout*
dup rect-dim viewport-gap 2 v*n v-
@ -33,6 +32,7 @@ M: viewport pref-dim* viewport-dim ;
gadget-model range-value [ >fixnum ] map ;
M: viewport model-changed
nip
dup relayout-1
dup scroller-value
vneg viewport-gap v+

11
extra/ui/gadgets/worlds/worlds.factor Normal file → Executable file
View File

@ -112,12 +112,6 @@ world H{
{ T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
} set-gestures
: start-world ( world -- )
dup graft
dup relayout
dup world-title over set-title
request-focus ;
: close-global ( world global -- )
dup get-global find-world rot eq?
[ f swap set-global ] [ drop ] if ;
@ -126,3 +120,8 @@ world H{
drop-prefix <reversed>
T{ lose-focus } swap each-gesture
T{ gain-focus } swap each-gesture ;
M: world graft*
dup (open-world-window)
dup world-title over set-title
request-focus ;

4
extra/ui/render/render-docs.factor Normal file → Executable file
View File

@ -9,13 +9,13 @@ HELP: gadget
{ { $link gadget-parent } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
{ { $link gadget-children } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
{ { $link gadget-orientation } " - an orientation specifier. This slot is used by layout gadgets." }
{ { $link gadget-state } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
{ { $link gadget-layout-state } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
{ { $link gadget-visible? } " - a boolean indicating if the gadget should display and receive user input." }
{ { $link gadget-root? } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
{ { $link gadget-clipped? } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
{ { $link gadget-grafted? } " - if set to " { $link t } ", the gadget is parented in a native window." }
{ { $link gadget-interior } " - an object whose class implements the " { $link draw-interior } " generic word." }
{ { $link gadget-boundary } " - an object whose class implements the " { $link draw-boundary } " generic word." }
{ { $link gadget-model } " - XXX" }
}
"Gadgets delegate to " { $link rect } " instances holding their location and dimensions." }
{ $notes

6
extra/ui/tools/browser/browser-tests.factor Executable file
View File

@ -0,0 +1,6 @@
IN: temporary
USING: tools.test tools.test.ui ui.tools.browser
tools.test.inference ;
{ 0 1 } [ <browser-gadget> ] unit-test-effect
[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test

4
extra/ui/tools/interactor/interactor-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: temporary
USING: ui.tools.interactor tools.test.inference ;
{ 1 1 } [ <interactor> ] unit-test-effect

24
extra/ui/tools/interactor/interactor.factor
View File

@ -25,19 +25,8 @@ help ;
2drop f
] if ;
TUPLE: caret-help model gadget ;
: <caret-help> ( interactor -- caret-help )
[ editor-caret 100 <delay> ] keep caret-help construct-boa
dup dup caret-help-model add-connection ;
M: caret-help model-changed
dup caret-help-gadget
swap caret-help-model model-value over word-at-loc
swap show-summary ;
: init-caret-help ( interactor -- )
dup <caret-help> swap set-interactor-help ;
dup editor-caret 100 <delay> swap set-interactor-help ;
: init-interactor-history ( interactor -- )
V{ } clone swap set-interactor-history ;
@ -52,13 +41,20 @@ M: caret-help model-changed
M: interactor graft*
dup delegate graft*
dup interactor-help caret-help-model activate-model
dup dup interactor-help add-connection
f swap set-interactor-busy? ;
M: interactor ungraft*
dup interactor-help caret-help-model deactivate-model
dup dup interactor-help remove-connection
delegate ungraft* ;
M: interactor model-changed
2dup interactor-help eq? [
swap model-value over word-at-loc swap show-summary
] [
delegate model-changed
] if ;
: write-input ( string input -- )
<input> presented associate
[ H{ { font-style bold } } format ] with-nesting ;

40
extra/ui/tools/listener/listener-tests.factor
View File

@ -1,35 +1,39 @@
USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences
timers tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words ;
ui.gadgets.panes vocabs words tools.test.ui ;
IN: temporary
timers [ init-timers ] unless
[ f ] [ "word" source-editor command-map empty? ] unit-test
<listener-gadget> "listener" set
[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
{ "kernel" } [ vocab-words ] map use associate
"listener" get listener-gadget-input set-interactor-vars
[ ] [ <listener-gadget> "listener" set ] unit-test
[ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test
"listener" get [
{ "kernel" } [ vocab-words ] map use associate
"listener" get listener-gadget-input set-interactor-vars
[ "USE: words word-name" ]
[ \ word-name "listener" get word-completion-string ] unit-test
[ "dup" ] [ \ dup "listener" get word-completion-string ] unit-test
<pane> <interactor> "i" set
H{ } "i" get set-interactor-vars
[ "USE: words word-name" ]
[ \ word-name "listener" get word-completion-string ] unit-test
[ t ] [ "i" get interactor? ] unit-test
<pane> <interactor> "i" set
H{ } "i" get set-interactor-vars
[ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
[ t ] [ "i" get interactor? ] unit-test
[ ] [
"i" get [ "SYMBOL:" parse ] catch go-to-error
] unit-test
[ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
[ t ] [
"i" get gadget-model doc-end
"i" get editor-caret* =
] unit-test
[ ] [
"i" get [ "SYMBOL:" parse ] catch go-to-error
] unit-test
[ t ] [
"i" get gadget-model doc-end
"i" get editor-caret* =
] unit-test
] with-grafted-gadget

27
extra/ui/tools/search/search-tests.factor
View File

@ -1,7 +1,7 @@
USING: assocs ui.tools.search help.topics io.files io.styles
kernel namespaces sequences source-files threads timers
tools.test ui.gadgets ui.gestures vocabs
vocabs.loader words ;
vocabs.loader words tools.test.ui debugger ;
IN: temporary
timers get [ init-timers ] unless
@ -12,12 +12,16 @@ timers get [ init-timers ] unless
T{ key-down f { C+ } "x" } swap search-gesture
] unit-test
: assert-non-empty empty? f assert= ;
: update-live-search ( search -- seq )
dup [
300 sleep do-timers
live-search-list control-value
] with-grafted-gadget ;
: test-live-search ( gadget quot -- ? )
>r dup graft 300 sleep do-timers
dup live-search-list control-value
dup empty? [ "Empty" throw ] when
r> all?
>r ungraft r> ;
>r update-live-search dup assert-non-empty r> all? ;
[ t ] [
"swp" all-words f <definition-search>
@ -26,11 +30,12 @@ timers get [ init-timers ] unless
[ t ] [
"" all-words t <definition-search>
dup graft
{ "set-word-prop" } over live-search-field set-control-value
300 sleep
do-timers
search-value \ set-word-prop eq?
dup [
{ "set-word-prop" } over live-search-field set-control-value
300 sleep
do-timers
search-value \ set-word-prop eq?
] with-grafted-gadget
] unit-test
[ t ] [

39
extra/ui/tools/tools-tests.factor
View File

@ -2,14 +2,14 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
ui.tools.search ui.tools.workspace kernel models namespaces
sequences timers tools.test ui.gadgets ui.gadgets.buttons
ui.gadgets.labelled ui.gadgets.presentations
ui.gadgets.scrollers vocabs ;
ui.gadgets.scrollers vocabs tools.test.ui ui ;
IN: temporary
[
[ f ] [
0 <model> <gadget> [ set-gadget-model ] keep gadget set
<workspace-tabs> gadget-children empty?
] unit-test
] unit-test
] with-scope
timers get [ init-timers ] unless
@ -31,24 +31,29 @@ timers get [ init-timers ] unless
"w" get hide-popup
] unit-test
[ ] [
<workspace> "w" set
"w" get graft
"w" get "kernel" vocab show-vocab-words
] unit-test
[ ] [ <workspace> [ ] with-grafted-gadget ] unit-test
"w" get workspace-popup closable-gadget-content
live-search-list gadget-child "p" set
"w" get [
[ t ] [ "p" get presentation? ] unit-test
[ ] [ "w" get "kernel" vocab show-vocab-words ] unit-test
"p" get <operations-menu> gadget-child gadget-child "c" set
[ ] [ notify-queued ] unit-test
[ t ] [ "c" get button? ] unit-test
[ ] [ "w" get workspace-popup closable-gadget-content
live-search-list gadget-child "p" set ] unit-test
[ ] [
"w" get workspace-listener listener-gadget-input
3 handle-parse-error
] unit-test
[ t ] [ "p" get presentation? ] unit-test
[ ] [ "w" get ungraft ] unit-test
[ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
[ ] [ notify-queued ] unit-test
[ t ] [ "c" get button? ] unit-test
[ ] [
"w" get workspace-listener listener-gadget-input
3 handle-parse-error
] unit-test
[ ] [ notify-queued ] unit-test
] with-grafted-gadget

18
extra/ui/tools/tools.factor
View File

@ -12,15 +12,6 @@ vocabs.loader tools.test ui.gadgets.buttons
ui.gadgets.status-bar mirrors ;
IN: ui.tools
: workspace-tabs ( -- seq )
{
<stack-display>
<browser-gadget>
<inspector-gadget>
<walker>
<profiler-gadget>
} ;
: <workspace-tabs> ( -- tabs )
g gadget-model
"tool-switching" workspace command-map
@ -28,7 +19,13 @@ IN: ui.tools
<toggle-buttons> ;
: <workspace-book> ( -- gadget )
workspace-tabs [ execute ] map g gadget-model <book> ;
[
<stack-display> ,
<browser-gadget> ,
<inspector-gadget> ,
<walker> ,
<profiler-gadget> ,
] { } make g gadget-model <book> ;
: <workspace> ( -- workspace )
0 <model> { 0 1 } <track> workspace construct-control [
@ -52,6 +49,7 @@ IN: ui.tools
] if relayout ;
M: workspace model-changed
nip
dup workspace-listener listener-gadget-output scroll>bottom
dup resize-workspace
request-focus ;

6
extra/ui/tools/traceback/traceback.factor
View File

@ -5,15 +5,15 @@ ui.commands ui.gadgets ui.gadgets.labelled
ui.gadgets.tracks ui.gestures ;
IN: ui.tools.traceback
: <callstack-display> ( model -- )
: <callstack-display> ( model -- gadget )
[ [ continuation-call callstack. ] when* ]
"Call stack" <labelled-pane> ;
: <datastack-display> ( model -- )
: <datastack-display> ( model -- gadget )
[ [ continuation-data stack. ] when* ]
"Data stack" <labelled-pane> ;
: <retainstack-display> ( model -- )
: <retainstack-display> ( model -- gadget )
[ [ continuation-retain stack. ] when* ]
"Retain stack" <labelled-pane> ;

57
extra/ui/tools/walker/walker-tests.factor Normal file → Executable file
View File

@ -2,27 +2,30 @@ USING: arrays continuations ui.tools.listener ui.tools.walker
ui.tools.workspace inspector kernel namespaces sequences threads
listener tools.test ui ui.gadgets ui.gadgets.worlds
ui.gadgets.packs vectors ui.tools tools.interpreter
tools.interpreter.debug ;
tools.interpreter.debug tools.test.inference tools.test.ui ;
IN: temporary
{ 0 1 } [ <walker> ] unit-test-effect
[ ] [ <walker> "walker" set ] unit-test
! Make sure the toolbar buttons don't throw if we're
! not actually walking.
"walker" get [
! Make sure the toolbar buttons don't throw if we're
! not actually walking.
[ ] [ "walker" get com-step ] unit-test
[ ] [ "walker" get com-into ] unit-test
[ ] [ "walker" get com-out ] unit-test
[ ] [ "walker" get com-back ] unit-test
[ ] [ "walker" get com-inspect ] unit-test
[ ] [ "walker" get reset-walker ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-step ] unit-test
[ ] [ "walker" get com-into ] unit-test
[ ] [ "walker" get com-out ] unit-test
[ ] [ "walker" get com-back ] unit-test
[ ] [ "walker" get com-inspect ] unit-test
[ ] [ "walker" get reset-walker ] unit-test
[ ] [ "walker" get com-continue ] unit-test
] with-grafted-gadget
: <test-world> ( gadget -- world )
[ gadget, ] make-pile "Hi" f <world> ;
[
f <workspace>
f <workspace> dup [
[ <test-world> 2array 1vector windows set ] keep
"ok" off
@ -37,38 +40,40 @@ IN: temporary
[ t ] [ "ok" get ] unit-test
[ ] [ <walker> "w" set ] unit-test
[ ] [ walker get-tool "w" set ] unit-test
continuation "c" set
[ ] [ "c" get "w" get call-tool* ] unit-test
[ ] [
[ "c" set f ] callcc1
[ "q" set ] [ "w" get com-inspect stop ] if*
] unit-test
[ t ] [
"q" get dup first continuation?
swap second \ inspect eq? and
] unit-test
] with-scope
] with-grafted-gadget
[
f <workspace> <test-world> 2array 1vector windows set
f <workspace> dup [
<test-world> 2array 1vector windows set
[ ] [
[ 2 3 break 4 ] quot>cont f swap 2array walker call-tool
] unit-test
[ ] [
[ 2 3 break 4 ] quot>cont f swap 2array walker call-tool
] unit-test
[ ] [ walker get-tool com-continue ] unit-test
[ ] [ walker get-tool com-continue ] unit-test
[ ] [ yield ] unit-test
[ ] [ yield ] unit-test
[ t ] [ walker get-tool walker-active? ] unit-test
[ t ] [ walker get-tool walker-active? ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
[ ] [ "walker" get com-continue ] unit-test
] with-grafted-gadget
] with-scope

5
extra/ui/tools/walker/walker.factor
View File

@ -46,12 +46,13 @@ TUPLE: walker model interpreter history ;
V{ } clone over set-walker-history
update-stacks ;
M: walker graft* dup delegate graft* reset-walker ;
: <walker> ( -- gadget )
f <model> f f walker construct-boa [
toolbar,
g walker-model <traceback-gadget> 1 track,
] { 0 1 } build-track
dup reset-walker ;
] { 0 1 } build-track ;
M: walker call-tool* ( continuation walker -- )
[ restore ] with-walker ;

4
extra/ui/tools/workspace/workspace-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: temporary
USING: tools.test tools.test.inference ui.tools ;
{ 0 1 } [ <workspace> ] unit-test-effect

6
extra/ui/ui-docs.factor Normal file → Executable file
View File

@ -18,11 +18,6 @@ HELP: find-window
{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
{ $description "Finds a native window whose world satisfies the quotation, outputting " { $link f } " if no such world could be found. The front-most native window is checked first." } ;
HELP: start-world
{ $values { "world" world } }
{ $description "Starts a world." }
{ $notes "This word should be called by the UI backend after " { $link register-window } ", but before making the world's containing window visible on the screen." } ;
HELP: register-window
{ $values { "world" world } { "handle" "a baackend-specific handle" } }
{ $description "Adds a window to the global " { $link windows } " variable." }
@ -174,7 +169,6 @@ ARTICLE: "ui-backend-windows" "UI backend window management"
{ $subsection open-world-window }
"This word should create a native window, store some kind of handle in the " { $link world-handle } " slot, then call two words:"
{ $subsection register-window }
{ $subsection start-world }
"The following words must also be implemented:"
{ $subsection set-title }
{ $subsection raise-window }

52
extra/ui/ui.factor Normal file → Executable file
View File

@ -3,7 +3,8 @@
USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words timers
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init ;
ui.gestures ui.backend ui.render continuations init
combinators ;
IN: ui
! Assoc mapping aliens to gadgets
@ -53,25 +54,23 @@ SYMBOL: windows
reset-world ;
: open-world-window ( world -- )
dup pref-dim over set-gadget-dim
dup (open-world-window)
draw-world ;
dup pref-dim over set-gadget-dim dup relayout graft ;
: open-window ( gadget title -- )
>r [ 1 track, ] { 0 1 } make-track r>
f <world> open-world-window ;
: find-window ( quot -- world )
windows get 1 <column>
windows get values
[ gadget-child swap call ] curry* find-last nip ; inline
: restore-windows ( -- )
windows get [ 1 <column> >array ] keep delete-all
windows get [ values ] keep delete-all
[ dup reset-world (open-world-window) ] each
forget-rollover ;
: restore-windows? ( -- ? )
windows get [ empty? not ] [ f ] if* ;
windows get empty? not ;
: update-hand ( world -- )
dup hand-world get-global eq?
@ -79,7 +78,8 @@ SYMBOL: windows
: layout-queued ( -- seq )
[
invalid [
in-layout? on
layout-queue [
dup layout find-world [ , ] when*
] dlist-slurp
] { } make ;
@ -87,24 +87,40 @@ SYMBOL: windows
SYMBOL: ui-hook
: init-ui ( -- )
<dlist> \ invalid set-global
<dlist> \ graft-queue set-global
<dlist> \ layout-queue set-global
V{ } clone windows set-global ;
: redraw-worlds ( seq -- )
[ dup update-hand draw-world ] each ;
: notify ( gadget -- )
dup gadget-graft-state {
{ { f t } [ dup activate-control dup graft* ] }
{ { t f } [ dup activate-control dup ungraft* ] }
} case
dup gadget-graft-state first { f f } { t t } ?
swap set-gadget-graft-state ;
: notify-queued ( -- )
graft-queue [ notify ] dlist-slurp ;
: ui-step ( -- )
[
do-timers
notify-queued
layout-queued
redraw-worlds
10 sleep
] assert-depth ;
: start-ui ( -- )
init-timers
restore-windows? [
restore-windows
] [
init-ui ui-hook get call
] if ;
: redraw-worlds ( seq -- )
[ dup update-hand draw-world ] each ;
: ui-step ( -- )
[
do-timers layout-queued redraw-worlds 10 sleep
] assert-depth ;
] if ui-step ;
: ui-running ( quot -- )
t \ ui-running set-global

29
extra/ui/windows/windows.factor
View File

@ -340,18 +340,19 @@ SYMBOL: hWnd
] ui-try
] alien-callback ;
: do-events ( -- )
msg-obj get f 0 0 PM_REMOVE PeekMessage
zero? not [
msg-obj get MSG-message WM_QUIT = [
msg-obj get [ TranslateMessage drop ] keep DispatchMessage drop
] unless
] when ;
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
: event-loop ( -- )
windows get empty? [
[ do-events ui-step ] ui-try event-loop
] unless ;
: event-loop ( msg -- )
{
{ [ windows get empty? ] [ drop ] }
{ [ dup peek-message? ] [ >r [ ui-step ] ui-try r> event-loop ] }
{ [ dup MSG-message WM_QUIT = ] [ drop ] }
{ [ t ] [
dup TranslateMessage drop
dup DispatchMessage drop
event-loop
] }
} cond ;
: register-wndclassex ( -- class )
"WNDCLASSEX" <c-object>
@ -414,8 +415,8 @@ M: windows-ui-backend (open-world-window) ( world -- )
[ rect-dim first2 create-window dup setup-gl ] keep
[ f <win> ] keep
[ swap win-hWnd register-window ] 2keep
[ set-world-handle ] 2keep
start-world win-hWnd show-window ;
dupd set-world-handle
win-hWnd show-window ;
M: windows-ui-backend select-gl-context ( handle -- )
[ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ;
@ -442,7 +443,7 @@ M: windows-ui-backend ui
init-clipboard
init-win32-ui
start-ui
event-loop
msg-obj get event-loop
] [ cleanup-win32-ui ] [ ] cleanup
] ui-running ;

1
extra/ui/x11/x11.factor Normal file → Executable file
View File

@ -224,7 +224,6 @@ M: x11-ui-backend set-title ( string world -- )
M: x11-ui-backend (open-world-window) ( world -- )
dup gadget-window
dup start-world
world-handle x11-handle-window dup set-closable map-window ;
M: x11-ui-backend raise-window ( world -- )

15
vm/code_gc.c Normal file → Executable file
View File

@ -379,6 +379,8 @@ CELL compute_heap_forwarding(F_HEAP *heap)
scan->forwarding = (F_BLOCK *)address;
address += scan->size;
}
else if(scan->status == B_MARKED)
critical_error("Why is the block marked?",0);
scan = next_block(heap,scan);
}
@ -391,6 +393,14 @@ F_COMPILED *forward_xt(F_COMPILED *compiled)
return block_to_compiled(compiled_to_block(compiled)->forwarding);
}
void forward_frame_xt(F_STACK_FRAME *frame)
{
CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
F_COMPILED *forwarded = forward_xt(frame_code(frame));
frame->xt = (XT)(forwarded + 1);
FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
}
void forward_object_xts(void)
{
begin_scan();
@ -413,6 +423,11 @@ void forward_object_xts(void)
if(quot->compiledp != F)
set_quot_xt(quot,forward_xt(quot->code));
}
else if(type_of(obj) == CALLSTACK_TYPE)
{
F_CALLSTACK *stack = untag_object(obj);
iterate_callstack_object(stack,forward_frame_xt);
}
}
/* End the heap scan */

17
vm/cpu-arm.h
View File

@ -5,23 +5,6 @@ register CELL rs asm("r6");
#define F_FASTCALL
typedef struct
{
/* In compiled quotation frames, position within the array.
In compiled word frames, unused. */
CELL scan;
/* In compiled quotation frames, the quot->array slot.
In compiled word frames, unused. */
CELL array;
/* In all compiled frames, the XT on entry. */
XT xt;
/* Frame size in bytes */
CELL size;
} F_STACK_FRAME;
#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
void c_to_factor(CELL quot);

17
vm/cpu-ppc.h
View File

@ -1,20 +1,3 @@
typedef struct
{
/* In compiled quotation frames, position within the array.
In compiled word frames, unused. */
CELL scan;
/* In compiled quotation frames, the quot->array slot.
In compiled word frames, unused. */
CELL array;
/* In all compiled frames, the XT on entry. */
XT xt;
/* Frame size in bytes */
CELL size;
} F_STACK_FRAME;
#define FACTOR_CPU_STRING "ppc"
#define F_FASTCALL

17
vm/cpu-x86.h
View File

@ -1,22 +1,5 @@
#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
typedef struct
{
/* In compiled quotation frames, position within the array.
In compiled word frames, unused. */
CELL scan;
/* In compiled quotation frames, the quot->array slot.
In compiled word frames, unused. */
CELL array;
/* In all compiled frames, the XT on entry. */
XT xt;
/* Frame size in bytes */
CELL size;
} F_STACK_FRAME;
INLINE void flush_icache(CELL start, CELL len) {}
F_FASTCALL void c_to_factor(CELL quot);

17
vm/layouts.h
View File

@ -255,3 +255,20 @@ typedef struct {
/* tagged */
CELL length;
} F_CALLSTACK;
typedef struct
{
/* In compiled quotation frames, position within the array.
In compiled word frames, unused. */
CELL scan;
/* In compiled quotation frames, the quot->array slot.
In compiled word frames, unused. */
CELL array;
/* In all compiled frames, the XT on entry. */
XT xt;
/* Frame size in bytes */
CELL size;
} F_STACK_FRAME;

1117
vm/run.s
View File

File diff suppressed because it is too large Load Diff