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 alien-invoke-library library
[ library-abi ] [ "cdecl" ] if* ; [ 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 ) : stdcall-mangle ( symbol node -- symbol )
"@" "@"
swap alien-node-parameters parameter-sizes drop swap alien-node-parameters parameter-sizes drop
@ -219,11 +225,6 @@ M: no-such-symbol summary
[ no-such-symbol ] unless [ no-such-symbol ] unless
] unless rot drop ; ] 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 [ \ alien-invoke [
! Four literals ! Four literals
4 ensure-values 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-function
pop-literal nip over set-alien-invoke-library pop-literal nip over set-alien-invoke-library
pop-literal nip over set-alien-invoke-return 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 ! If symbol doesn't resolve, no stack effect, no compile
dup alien-invoke-dlsym 2drop 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 ! Add node to IR
dup node, dup node,
! Magic #: consume exactly the number of inputs ! 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 alien-node-abi alien-indirect-abi ;
M: alien-indirect-error summary 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 [ \ alien-indirect [
! Three literals and function pointer ! 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 alien-node-abi alien-callback-abi ;
M: alien-callback-error summary 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 -- ) : callback-bottom ( node -- )
alien-callback-xt [ word-xt <alien> ] curry 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.integers" require
"math.floats" require "math.floats" require
"memory" require "memory" require
! this must add its init hook before io.backend does
"libc" require
"io.streams.c" require "io.streams.c" require
"vocabs.loader" require "vocabs.loader" require
"syntax" 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 USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences inference words namespaces namespaces tools.test sequences inference words
arrays parser quotations continuations inference.backend effects 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 ; FUNCTION: void ffi_test_0 ;
[ ] [ ffi_test_0 ] unit-test [ ] [ ffi_test_0 ] unit-test
@ -79,10 +80,7 @@ FUNCTION: tiny ffi_test_17 int x ;
: indirect-test-1 : indirect-test-1
"int" { } "cdecl" alien-indirect ; "int" { } "cdecl" alien-indirect ;
: short-effect { 1 1 } [ indirect-test-1 ] unit-test-effect
dup effect-in length swap effect-out length 2array ;
[ { 1 1 } ] [ [ indirect-test-1 ] infer short-effect ] unit-test
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test [ 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 : indirect-test-2
"int" { "int" "int" } "cdecl" alien-indirect data-gc ; "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 ] [ 5 ]
[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]

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

@ -1,29 +1,26 @@
USING: compiler definitions generic assocs inference math USING: compiler definitions generic assocs inference math
namespaces parser tools.test words kernel sequences arrays io namespaces parser tools.test words kernel sequences arrays io
effects ; effects tools.test.inference ;
IN: temporary IN: temporary
parse-hook get [ parse-hook get [
DEFER: foo \ foo reset-generic DEFER: foo \ foo reset-generic
DEFER: bar \ bar 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 [ ] [ \ foo [ 1 2 ] define-compound ] unit-test
[ { 0 2 } ] [ [ foo ] infer short-effect ] unit-test { 0 2 } [ foo ] unit-test-effect
[ ] [ \ foo compile ] unit-test [ ] [ \ foo compile ] unit-test
[ ] [ \ bar [ foo foo ] define-compound ] unit-test [ ] [ \ bar [ foo foo ] define-compound ] unit-test
[ ] [ \ bar compile ] unit-test [ ] [ \ bar compile ] unit-test
[ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test [ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test
[ t ] [ \ bar changed-words get key? ] unit-test [ t ] [ \ bar changed-words get key? ] unit-test
[ ] [ recompile ] unit-test [ ] [ recompile ] unit-test
[ { 0 3 } ] [ [ foo ] infer short-effect ] unit-test { 0 3 } [ foo ] unit-test-effect
[ f ] [ \ bar changed-words get key? ] unit-test [ f ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ bar [ 1 2 ] define-compound ] unit-test [ ] [ \ bar [ 1 2 ] define-compound ] unit-test
[ t ] [ \ bar changed-words get key? ] unit-test [ t ] [ \ bar changed-words get key? ] unit-test
[ ] [ recompile ] unit-test [ ] [ recompile ] unit-test
[ { 0 2 } ] [ [ bar ] infer short-effect ] unit-test { 0 2 } [ bar ] unit-test-effect
[ f ] [ \ bar changed-words get key? ] unit-test [ f ] [ \ bar changed-words get key? ] unit-test
[ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test [ ] [ \ foo [ 1 2 3 ] define-compound ] unit-test
[ f ] [ \ bar changed-words get key? ] unit-test [ f ] [ \ bar changed-words get key? ] unit-test

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 IN: temporary
[ t ] [ <dlist> dlist-empty? ] unit-test [ t ] [ <dlist> dlist-empty? ] unit-test
@ -59,3 +61,37 @@ IN: temporary
[ 0 ] [ <dlist> dlist-length ] unit-test [ 0 ] [ <dlist> dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front 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 [ 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 nip t
] [ ] [
drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if* drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
] if ; ] if ; inline
: dlist-find-node ( quot dlist -- node/f ? ) : 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 -- ) : (dlist-each-node) ( quot dlist -- )
over over
[ 2dup call >r dlist-node-next r> (dlist-each-node) ] [ 2dup call >r dlist-node-next r> (dlist-each-node) ]
[ 2drop ] if ; [ 2drop ] if ; inline
: dlist-each-node ( quot dlist -- ) : dlist-each-node ( quot dlist -- )
>r dlist-front r> (dlist-each-node) ; inline >r dlist-front r> (dlist-each-node) ; inline
@ -98,17 +98,20 @@ PRIVATE>
: pop-back* ( dlist -- ) pop-back drop ; : pop-back* ( dlist -- ) pop-back drop ;
: dlist-find ( quot dlist -- obj/f ? ) : 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-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 -- ) : (delete-node) ( dlist dlist-node -- )
{ {
{ [ 2dup >r dlist-front r> = ] [ drop pop-front* ] } { [ over dlist-front over eq? ] [ drop pop-front* ] }
{ [ 2dup >r dlist-back r> = ] [ drop pop-back* ] } { [ over dlist-back over eq? ] [ drop pop-back* ] }
{ [ t ] [ dup dlist-node-prev swap dlist-node-next set-prev-when { [ t ] [ unlink-node dec-length ] }
dec-length ] }
} cond ; } cond ;
: delete-node* ( quot dlist -- obj/f ? ) : delete-node* ( quot dlist -- obj/f ? )
@ -116,10 +119,13 @@ PRIVATE>
[ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if* [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if*
] [ ] [
2drop f f 2drop f f
] if ; ] if ; inline
: delete-node ( quot dlist -- obj/f ) : 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-each ( dlist quot -- )
[ dlist-node-obj ] swap compose dlist-each-node ; inline [ dlist-node-obj ] swap compose dlist-each-node ; inline

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

@ -6,46 +6,40 @@ continuations generic.standard sorting assocs definitions
prettyprint io inspector bootstrap.image tuples prettyprint io inspector bootstrap.image tuples
classes.union classes.predicate debugger bootstrap.image classes.union classes.predicate debugger bootstrap.image
bootstrap.image.private io.launcher threads.private bootstrap.image.private io.launcher threads.private
io.streams.string combinators.private ; io.streams.string combinators.private tools.test.inference ;
IN: temporary IN: temporary
: short-effect { 0 2 } [ 2 "Hello" ] unit-test-effect
dup effect-in length swap effect-out length 2array ; { 1 2 } [ dup ] unit-test-effect
[ { 0 2 } ] [ [ 2 "Hello" ] infer short-effect ] unit-test { 1 2 } [ [ dup ] call ] unit-test-effect
[ { 1 2 } ] [ [ dup ] infer short-effect ] unit-test [ [ call ] infer ] unit-test-fails
[ { 1 2 } ] [ [ [ dup ] call ] infer short-effect ] unit-test { 2 4 } [ 2dup ] unit-test-effect
[ [ call ] infer short-effect ] unit-test-fails
[ { 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 { 4 3 } [
[ [ 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 } ] [
[
[ [
[ swap 3 ] [ nip 5 5 ] if [ swap 3 ] [ nip 5 5 ] if
] [ ] [
-rot -rot
] if ] if
] infer short-effect ] unit-test-effect
] unit-test
[ { 1 1 } ] [ [ dup [ ] when ] infer short-effect ] unit-test { 1 1 } [ dup [ ] when ] unit-test-effect
[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer short-effect ] unit-test { 1 1 } [ dup [ dup fixnum* ] when ] unit-test-effect
[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer short-effect ] unit-test { 2 1 } [ [ dup fixnum* ] when ] unit-test-effect
[ { 1 0 } ] [ [ [ drop ] when* ] infer short-effect ] unit-test { 1 0 } [ [ drop ] when* ] unit-test-effect
[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer short-effect ] unit-test { 1 1 } [ [ { { [ ] } } ] unless* ] unit-test-effect
[ { 0 1 } ] [ { 0 1 }
[ [ 2 2 fixnum+ ] dup [ ] when call ] infer short-effect [ [ 2 2 fixnum+ ] dup [ ] when call ] unit-test-effect
] unit-test
[ [
[ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
@ -57,37 +51,37 @@ IN: temporary
: termination-test-2 [ termination-test-1 ] [ 3 ] if ; : 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 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 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 ) : simple-recursion-1 ( obj -- obj )
dup [ simple-recursion-1 ] [ ] if ; 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 ) : simple-recursion-2 ( obj -- obj )
dup [ ] [ simple-recursion-2 ] if ; 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 ) : bad-recursion-2 ( obj -- obj )
dup [ dup first swap second bad-recursion-2 ] [ ] if ; 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 ) : funny-recursion ( obj -- obj )
dup [ funny-recursion 1 ] [ 2 ] if drop ; 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 ! Simple combinators
[ { 1 2 } ] [ [ [ first ] keep second ] infer short-effect ] unit-test { 1 2 } [ [ first ] keep second ] unit-test-effect
! Mutual recursion ! Mutual recursion
DEFER: foe DEFER: foe
@ -110,8 +104,8 @@ DEFER: foe
2drop f 2drop f
] if ; ] if ;
[ { 2 1 } ] [ [ fie ] infer short-effect ] unit-test { 2 1 } [ fie ] unit-test-effect
[ { 2 1 } ] [ [ foe ] infer short-effect ] unit-test { 2 1 } [ foe ] unit-test-effect
: nested-when ( -- ) : nested-when ( -- )
t [ t [
@ -120,7 +114,7 @@ DEFER: foe
] when ] when
] when ; ] when ;
[ { 0 0 } ] [ [ nested-when ] infer short-effect ] unit-test { 0 0 } [ nested-when ] unit-test-effect
: nested-when* ( obj -- ) : nested-when* ( obj -- )
[ [
@ -129,11 +123,11 @@ DEFER: foe
] when* ] when*
] when* ; ] when* ;
[ { 1 0 } ] [ [ nested-when* ] infer short-effect ] unit-test { 1 0 } [ nested-when* ] unit-test-effect
SYMBOL: sym-test SYMBOL: sym-test
[ { 0 1 } ] [ [ sym-test ] infer short-effect ] unit-test { 0 1 } [ sym-test ] unit-test-effect
: terminator-branch : terminator-branch
dup [ dup [
@ -142,7 +136,7 @@ SYMBOL: sym-test
"foo" throw "foo" throw
] if ; ] if ;
[ { 1 1 } ] [ [ terminator-branch ] infer short-effect ] unit-test { 1 1 } [ terminator-branch ] unit-test-effect
: recursive-terminator ( obj -- ) : recursive-terminator ( obj -- )
dup [ dup [
@ -151,12 +145,12 @@ SYMBOL: sym-test
"Hi" throw "Hi" throw
] if ; ] if ;
[ { 1 0 } ] [ [ recursive-terminator ] infer short-effect ] unit-test { 1 0 } [ recursive-terminator ] unit-test-effect
GENERIC: potential-hang ( obj -- obj ) GENERIC: potential-hang ( obj -- obj )
M: fixnum potential-hang dup [ potential-hang ] when ; 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 ; TUPLE: funny-cons car cdr ;
GENERIC: iterate ( obj -- ) GENERIC: iterate ( obj -- )
@ -164,24 +158,24 @@ M: funny-cons iterate funny-cons-cdr iterate ;
M: f iterate drop ; M: f iterate drop ;
M: real iterate drop ; M: real iterate drop ;
[ { 1 0 } ] [ [ iterate ] infer short-effect ] unit-test { 1 0 } [ iterate ] unit-test-effect
! Regression ! Regression
: cat ( obj -- * ) dup [ throw ] [ throw ] if ; : cat ( obj -- * ) dup [ throw ] [ throw ] if ;
: dog ( a b c -- ) dup [ cat ] [ 3drop ] if ; : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
[ { 3 0 } ] [ [ dog ] infer short-effect ] unit-test { 3 0 } [ dog ] unit-test-effect
! Regression ! Regression
DEFER: monkey DEFER: monkey
: friend ( a b c -- ) dup [ friend ] [ monkey ] if ; : friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
: monkey ( a b c -- ) dup [ 3drop ] [ friend ] 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 DEFER: blah2
: blah ( a b c -- ) dup [ blah ] [ blah2 ] if ; : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
: blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ; : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
[ { 3 0 } ] [ [ blah2 ] infer short-effect ] unit-test { 3 0 } [ blah2 ] unit-test-effect
! Regression ! Regression
DEFER: blah4 DEFER: blah4
@ -189,7 +183,7 @@ DEFER: blah4
dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ; dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
: blah4 ( a b c -- ) : blah4 ( a b c -- )
dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ; dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
[ { 3 0 } ] [ [ blah4 ] infer short-effect ] unit-test { 3 0 } [ blah4 ] unit-test-effect
! Regression ! Regression
: bad-combinator ( obj quot -- ) : bad-combinator ( obj quot -- )
@ -199,14 +193,14 @@ DEFER: blah4
[ swap slip ] keep swap bad-combinator [ swap slip ] keep swap bad-combinator
] if ; inline ] if ; inline
[ [ [ 1 ] [ ] bad-combinator ] infer short-effect ] unit-test-fails [ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
! Regression ! Regression
: bad-input# : bad-input#
dup string? [ 2array throw ] unless dup string? [ 2array throw ] unless
over 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 ! Regression
@ -214,18 +208,18 @@ DEFER: blah4
DEFER: do-crap DEFER: do-crap
: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ; : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] 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 ! This one does not
DEFER: do-crap* DEFER: do-crap*
: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ; : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] 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 ! Regression
: too-deep ( a b -- c ) : too-deep ( a b -- c )
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline 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 ! Error reporting is wrong
MATH: xyz MATH: xyz
@ -233,7 +227,7 @@ M: fixnum xyz 2array ;
M: float xyz M: float xyz
[ 3 ] 2apply swapd >r 2array swap r> 2array swap ; [ 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 ! Doug Coleman discovered this one while working on the
! calendar library ! calendar library
@ -265,17 +259,17 @@ DEFER: C
[ dup B C ] [ dup B C ]
} dispatch ; } dispatch ;
[ { 1 0 } ] [ [ A ] infer short-effect ] unit-test { 1 0 } [ A ] unit-test-effect
[ { 1 0 } ] [ [ B ] infer short-effect ] unit-test { 1 0 } [ B ] unit-test-effect
[ { 1 0 } ] [ [ C ] infer short-effect ] unit-test { 1 0 } [ C ] unit-test-effect
! I found this bug by thinking hard about the previous one ! I found this bug by thinking hard about the previous one
DEFER: Y DEFER: Y
: X ( a b -- c d ) dup [ swap Y ] [ ] if ; : X ( a b -- c d ) dup [ swap Y ] [ ] if ;
: Y ( a b -- c d ) X ; : Y ( a b -- c d ) X ;
[ { 2 2 } ] [ [ X ] infer short-effect ] unit-test { 2 2 } [ X ] unit-test-effect
[ { 2 2 } ] [ [ Y ] infer short-effect ] unit-test { 2 2 } [ Y ] unit-test-effect
! This one comes from UI code ! This one comes from UI code
DEFER: #1 DEFER: #1
@ -284,17 +278,17 @@ DEFER: #1
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ; : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ; : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
[ \ #4 word-def infer short-effect ] unit-test-fails [ \ #4 word-def infer ] unit-test-fails
[ [ #1 ] infer short-effect ] unit-test-fails [ [ #1 ] infer ] unit-test-fails
! Similar ! Similar
DEFER: bar DEFER: bar
: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ; : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ; : 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 ! This used to hang
[ t ] [ [ t ] [
@ -340,128 +334,128 @@ DEFER: bar
: bad-recursion-1 ( a -- b ) : bad-recursion-1 ( a -- b )
dup [ drop bad-recursion-1 5 ] [ ] if ; 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 ( 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 ! Regression
[ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test [ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test
! Test some curry stuff ! 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 [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails
! Test number protocol ! Test number protocol
[ { 2 1 } ] [ [ bitor ] infer short-effect ] unit-test { 2 1 } [ bitor ] unit-test-effect
[ { 2 1 } ] [ [ bitand ] infer short-effect ] unit-test { 2 1 } [ bitand ] unit-test-effect
[ { 2 1 } ] [ [ bitxor ] infer short-effect ] unit-test { 2 1 } [ bitxor ] unit-test-effect
[ { 2 1 } ] [ [ mod ] infer short-effect ] unit-test { 2 1 } [ mod ] unit-test-effect
[ { 2 1 } ] [ [ /i ] infer short-effect ] unit-test { 2 1 } [ /i ] unit-test-effect
[ { 2 1 } ] [ [ /f ] infer short-effect ] unit-test { 2 1 } [ /f ] unit-test-effect
[ { 2 2 } ] [ [ /mod ] infer short-effect ] unit-test { 2 2 } [ /mod ] unit-test-effect
[ { 2 1 } ] [ [ + ] infer short-effect ] unit-test { 2 1 } [ + ] unit-test-effect
[ { 2 1 } ] [ [ - ] infer short-effect ] unit-test { 2 1 } [ - ] unit-test-effect
[ { 2 1 } ] [ [ * ] infer short-effect ] unit-test { 2 1 } [ * ] unit-test-effect
[ { 2 1 } ] [ [ / ] infer short-effect ] unit-test { 2 1 } [ / ] unit-test-effect
[ { 2 1 } ] [ [ < ] infer short-effect ] unit-test { 2 1 } [ < ] unit-test-effect
[ { 2 1 } ] [ [ <= ] infer short-effect ] unit-test { 2 1 } [ <= ] unit-test-effect
[ { 2 1 } ] [ [ > ] infer short-effect ] unit-test { 2 1 } [ > ] unit-test-effect
[ { 2 1 } ] [ [ >= ] infer short-effect ] unit-test { 2 1 } [ >= ] unit-test-effect
[ { 2 1 } ] [ [ number= ] infer short-effect ] unit-test { 2 1 } [ number= ] unit-test-effect
! Test object protocol ! Test object protocol
[ { 2 1 } ] [ [ = ] infer short-effect ] unit-test { 2 1 } [ = ] unit-test-effect
[ { 1 1 } ] [ [ clone ] infer short-effect ] unit-test { 1 1 } [ clone ] unit-test-effect
[ { 2 1 } ] [ [ hashcode* ] infer short-effect ] unit-test { 2 1 } [ hashcode* ] unit-test-effect
! Test sequence protocol ! Test sequence protocol
[ { 1 1 } ] [ [ length ] infer short-effect ] unit-test { 1 1 } [ length ] unit-test-effect
[ { 2 1 } ] [ [ nth ] infer short-effect ] unit-test { 2 1 } [ nth ] unit-test-effect
[ { 2 0 } ] [ [ set-length ] infer short-effect ] unit-test { 2 0 } [ set-length ] unit-test-effect
[ { 3 0 } ] [ [ set-nth ] infer short-effect ] unit-test { 3 0 } [ set-nth ] unit-test-effect
[ { 2 1 } ] [ [ new ] infer short-effect ] unit-test { 2 1 } [ new ] unit-test-effect
[ { 2 1 } ] [ [ new-resizable ] infer short-effect ] unit-test { 2 1 } [ new-resizable ] unit-test-effect
[ { 2 1 } ] [ [ like ] infer short-effect ] unit-test { 2 1 } [ like ] unit-test-effect
[ { 2 0 } ] [ [ lengthen ] infer short-effect ] unit-test { 2 0 } [ lengthen ] unit-test-effect
! Test assoc protocol ! Test assoc protocol
[ { 2 2 } ] [ [ at* ] infer short-effect ] unit-test { 2 2 } [ at* ] unit-test-effect
[ { 3 0 } ] [ [ set-at ] infer short-effect ] unit-test { 3 0 } [ set-at ] unit-test-effect
[ { 2 1 } ] [ [ new-assoc ] infer short-effect ] unit-test { 2 1 } [ new-assoc ] unit-test-effect
[ { 2 0 } ] [ [ delete-at ] infer short-effect ] unit-test { 2 0 } [ delete-at ] unit-test-effect
[ { 1 0 } ] [ [ clear-assoc ] infer short-effect ] unit-test { 1 0 } [ clear-assoc ] unit-test-effect
[ { 1 1 } ] [ [ assoc-size ] infer short-effect ] unit-test { 1 1 } [ assoc-size ] unit-test-effect
[ { 2 1 } ] [ [ assoc-like ] infer short-effect ] unit-test { 2 1 } [ assoc-like ] unit-test-effect
[ { 2 1 } ] [ [ assoc-clone-like ] infer short-effect ] unit-test { 2 1 } [ assoc-clone-like ] unit-test-effect
[ { 1 1 } ] [ [ >alist ] infer short-effect ] unit-test { 1 1 } [ >alist ] unit-test-effect
[ { 1 3 } ] [ [ [ 2drop f ] assoc-find ] infer short-effect ] unit-test { 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect
! Test some random library words ! Test some random library words
[ { 1 1 } ] [ [ 1quotation ] infer short-effect ] unit-test { 1 1 } [ 1quotation ] unit-test-effect
[ { 1 1 } ] [ [ string>number ] infer short-effect ] unit-test { 1 1 } [ string>number ] unit-test-effect
[ { 1 1 } ] [ [ get ] infer short-effect ] unit-test { 1 1 } [ get ] unit-test-effect
[ { 2 0 } ] [ [ push ] infer short-effect ] unit-test { 2 0 } [ push ] unit-test-effect
[ { 2 1 } ] [ [ append ] infer short-effect ] unit-test { 2 1 } [ append ] unit-test-effect
[ { 1 1 } ] [ [ peek ] infer short-effect ] unit-test { 1 1 } [ peek ] unit-test-effect
[ { 1 1 } ] [ [ reverse ] infer short-effect ] unit-test { 1 1 } [ reverse ] unit-test-effect
[ { 2 1 } ] [ [ member? ] infer short-effect ] unit-test { 2 1 } [ member? ] unit-test-effect
[ { 2 1 } ] [ [ remove ] infer short-effect ] unit-test { 2 1 } [ remove ] unit-test-effect
[ { 1 1 } ] [ [ natural-sort ] infer short-effect ] unit-test { 1 1 } [ natural-sort ] unit-test-effect
[ { 1 0 } ] [ [ forget ] infer short-effect ] unit-test { 1 0 } [ forget ] unit-test-effect
[ { 4 0 } ] [ [ define-class ] infer short-effect ] unit-test { 4 0 } [ define-class ] unit-test-effect
[ { 2 0 } ] [ [ define-tuple-class ] infer short-effect ] unit-test { 2 0 } [ define-tuple-class ] unit-test-effect
[ { 2 0 } ] [ [ define-union-class ] infer short-effect ] unit-test { 2 0 } [ define-union-class ] unit-test-effect
[ { 3 0 } ] [ [ define-predicate-class ] infer short-effect ] unit-test { 3 0 } [ define-predicate-class ] unit-test-effect
! Test words with continuations ! Test words with continuations
[ { 0 0 } ] [ [ [ drop ] callcc0 ] infer short-effect ] unit-test { 0 0 } [ [ drop ] callcc0 ] unit-test-effect
[ { 0 1 } ] [ [ [ 4 swap continue-with ] callcc1 ] infer short-effect ] unit-test { 0 1 } [ [ 4 swap continue-with ] callcc1 ] unit-test-effect
[ { 2 1 } ] [ [ [ + ] [ ] [ ] cleanup ] infer short-effect ] unit-test { 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect
[ { 2 1 } ] [ [ [ + ] [ 3drop 0 ] recover ] infer short-effect ] unit-test { 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect
! Test stream protocol ! Test stream protocol
[ { 2 0 } ] [ [ set-timeout ] infer short-effect ] unit-test { 2 0 } [ set-timeout ] unit-test-effect
[ { 2 1 } ] [ [ stream-read ] infer short-effect ] unit-test { 2 1 } [ stream-read ] unit-test-effect
[ { 1 1 } ] [ [ stream-read1 ] infer short-effect ] unit-test { 1 1 } [ stream-read1 ] unit-test-effect
[ { 1 1 } ] [ [ stream-readln ] infer short-effect ] unit-test { 1 1 } [ stream-readln ] unit-test-effect
[ { 2 2 } ] [ [ stream-read-until ] infer short-effect ] unit-test { 2 2 } [ stream-read-until ] unit-test-effect
[ { 2 0 } ] [ [ stream-write ] infer short-effect ] unit-test { 2 0 } [ stream-write ] unit-test-effect
[ { 2 0 } ] [ [ stream-write1 ] infer short-effect ] unit-test { 2 0 } [ stream-write1 ] unit-test-effect
[ { 1 0 } ] [ [ stream-nl ] infer short-effect ] unit-test { 1 0 } [ stream-nl ] unit-test-effect
[ { 1 0 } ] [ [ stream-close ] infer short-effect ] unit-test { 1 0 } [ stream-close ] unit-test-effect
[ { 3 0 } ] [ [ stream-format ] infer short-effect ] unit-test { 3 0 } [ stream-format ] unit-test-effect
[ { 3 0 } ] [ [ stream-write-table ] infer short-effect ] unit-test { 3 0 } [ stream-write-table ] unit-test-effect
[ { 1 0 } ] [ [ stream-flush ] infer short-effect ] unit-test { 1 0 } [ stream-flush ] unit-test-effect
[ { 2 1 } ] [ [ make-span-stream ] infer short-effect ] unit-test { 2 1 } [ make-span-stream ] unit-test-effect
[ { 2 1 } ] [ [ make-block-stream ] infer short-effect ] unit-test { 2 1 } [ make-block-stream ] unit-test-effect
[ { 2 1 } ] [ [ make-cell-stream ] infer short-effect ] unit-test { 2 1 } [ make-cell-stream ] unit-test-effect
! Test stream utilities ! Test stream utilities
[ { 1 1 } ] [ [ lines ] infer short-effect ] unit-test { 1 1 } [ lines ] unit-test-effect
[ { 1 1 } ] [ [ contents ] infer short-effect ] unit-test { 1 1 } [ contents ] unit-test-effect
! Test prettyprinting ! Test prettyprinting
[ { 1 0 } ] [ [ . ] infer short-effect ] unit-test { 1 0 } [ . ] unit-test-effect
[ { 1 0 } ] [ [ short. ] infer short-effect ] unit-test { 1 0 } [ short. ] unit-test-effect
[ { 1 1 } ] [ [ unparse ] infer short-effect ] unit-test { 1 1 } [ unparse ] unit-test-effect
[ { 1 0 } ] [ [ describe ] infer short-effect ] unit-test { 1 0 } [ describe ] unit-test-effect
[ { 1 0 } ] [ [ error. ] infer short-effect ] unit-test { 1 0 } [ error. ] unit-test-effect
! Test odds and ends ! Test odds and ends
[ { 1 1 } ] [ [ ' ] infer short-effect ] unit-test { 1 1 } [ ' ] unit-test-effect
[ { 2 0 } ] [ [ write-image ] infer short-effect ] unit-test { 2 0 } [ write-image ] unit-test-effect
[ { 1 1 } ] [ [ <process-stream> ] infer short-effect ] unit-test { 1 1 } [ <process-stream> ] unit-test-effect
[ { 0 0 } ] [ [ idle-thread ] infer short-effect ] unit-test { 0 0 } [ idle-thread ] unit-test-effect
! Incorrect stack declarations on inline recursive words should ! Incorrect stack declarations on inline recursive words should
! be caught ! be caught
@ -471,13 +465,13 @@ DEFER: bar
[ [ barxxx ] infer ] unit-test-fails [ [ barxxx ] infer ] unit-test-fails
! A typo ! A typo
[ { 1 0 } ] [ [ { [ ] } dispatch ] infer short-effect ] unit-test { 1 0 } [ { [ ] } dispatch ] unit-test-effect
DEFER: inline-recursive-2 DEFER: inline-recursive-2
: inline-recursive-1 ( -- ) inline-recursive-2 ; : inline-recursive-1 ( -- ) inline-recursive-2 ;
: inline-recursive-2 ( -- ) inline-recursive-1 ; : 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 ! Hooks
SYMBOL: my-var SYMBOL: my-var
@ -486,23 +480,22 @@ HOOK: my-hook my-var ( -- x )
M: integer my-hook "an integer" ; M: integer my-hook "an integer" ;
M: string my-hook "a string" ; 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 DEFER: deferred-word
: calls-deferred-word [ deferred-word ] [ 3 ] if ; : 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 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 } ] [ { 1 0 }
[ [
[ [ iterate-next ] iterate-nodes ] with-node-iterator [ [ iterate-next ] iterate-nodes ] with-node-iterator
] infer short-effect ] unit-test-effect
] unit-test
: nilpotent ( quot -- ) : nilpotent ( quot -- )
t [ [ call ] keep nilpotent ] [ drop ] if ; inline t [ [ call ] keep nilpotent ] [ drop ] if ; inline
@ -510,14 +503,13 @@ USE: inference.dataflow
: semisimple ( quot -- ) : semisimple ( quot -- )
[ call ] keep [ [ semisimple ] keep ] nilpotent drop ; inline [ call ] keep [ [ semisimple ] keep ] nilpotent drop ; inline
[ { 0 1 } ] [ { 0 1 }
[ [ ] [ call ] keep [ [ call ] keep ] nilpotent ] [ [ ] [ call ] keep [ [ call ] keep ] nilpotent ]
infer short-effect unit-test-effect
] unit-test
[ { 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 DEFER: an-inline-word
@ -533,9 +525,9 @@ DEFER: an-inline-word
: an-inline-word ( obj quot -- ) : an-inline-word ( obj quot -- )
>r normal-word r> call ; inline >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 ; TUPLE: custom-error ;
@ -559,4 +551,4 @@ TUPLE: custom-error ;
! This was a false trigger of the undecidable quotation ! This was a false trigger of the undecidable quotation
! recursion bug ! 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-write ] keep stream-nl ;
: (stream-copy) ( in out -- ) : (stream-copy) ( in out -- )
64 1024 * pick stream-read 64 1024 * pick stream-read-partial
[ over stream-write (stream-copy) ] [ 2drop ] if* ; [ over stream-write (stream-copy) ] [ 2drop ] if* ;
: stream-copy ( in out -- ) : 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 USING: generic help.markup help.syntax kernel math memory
namespaces sequences kernel.private io.files ; namespaces sequences kernel.private io.files strings ;
IN: system IN: system
ARTICLE: "os" "System interface" ARTICLE: "os" "System interface"
@ -21,23 +21,27 @@ ARTICLE: "os" "System interface"
{ $subsection cell-bits } { $subsection cell-bits }
"Reading environment variables:" "Reading environment variables:"
{ $subsection os-env } { $subsection os-env }
{ $subsection os-envs }
"Getting the path to the Factor VM and image:" "Getting the path to the Factor VM and image:"
{ $subsection vm } { $subsection vm }
{ $subsection image } { $subsection image }
"Getting the current time:"
{ $subsection millis }
"Exiting the Factor VM:" "Exiting the Factor VM:"
{ $subsection exit } ; { $subsection exit }
{ $see-also "file-streams" "network-streams" "io.launcher" "io.mmap" } ;
ABOUT: "os" ABOUT: "os"
HELP: cpu HELP: cpu
{ $values { "cpu" "a string" } } { $values { "cpu" string } }
{ $description { $description
"Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:" "Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:"
{ $code "x86.32" "x86.64" "ppc" "arm" } { $code "x86.32" "x86.64" "ppc" "arm" }
} ; } ;
HELP: os HELP: os
{ $values { "os" "a string" } } { $values { "os" string } }
{ $description { $description
"Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:" "Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:"
{ $code { $code
@ -87,17 +91,28 @@ HELP: exit ( n -- )
{ $description "Exits the Factor process." } ; { $description "Exits the Factor process." } ;
HELP: millis ( -- n ) HELP: millis ( -- n )
{ $values { "n" "an integer" } } { $values { "n" integer } }
{ $description "Outputs the number of milliseconds ellapsed since midnight January 1, 1970." } ; { $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 ) 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." } { $description "Looks up the value of a shell environment variable." }
{ $examples { $examples
"This is an operating system-specific feature. On Unix, you can do:" "This is an operating system-specific feature. On Unix, you can do:"
{ $unchecked-example "\"USER\" os-env print" "jane" } { $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? HELP: win32?
{ $values { "?" "a boolean" } } { $values { "?" "a boolean" } }
@ -124,11 +139,11 @@ HELP: cell
{ $description "Outputs the pointer size in bytes of the current CPU architecture." } ; { $description "Outputs the pointer size in bytes of the current CPU architecture." } ;
HELP: cells 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." } ; { $description "Computes the number of bytes used by " { $snippet "m" } " CPU operand-sized cells." } ;
HELP: cell-bits HELP: cell-bits
{ $values { "n" "an integer" } } { $values { "n" integer } }
{ $description "Outputs the number of bits in one CPU operand-sized cell." } ; { $description "Outputs the number of bits in one CPU operand-sized cell." } ;
HELP: bootstrap-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)." } ; { $description "Outputs the pointer size in bytes for the target image (if bootstrapping) or the current CPU architecture (otherwise)." } ;
HELP: bootstrap-cells 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)." } ; { $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 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)." } ; { $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 word? }
{ $subsection "interned-words" } { $subsection "interned-words" }
{ $subsection "word-definition" } { $subsection "word-definition" }
{ $subsection "word-props" }
{ $subsection "word.private" } { $subsection "word.private" }
{ $see-also "vocabularies" "vocabs.loader" "definitions" } ; { $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 ; { 100 100 } over set-rect-dim ;
M: color-preview model-changed 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 ) : <color-model> ( model -- model )
[ [ 256 /f ] map 1 add <solid> ] <filter> ; [ [ 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" 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 $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." "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 $nl

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

@ -131,7 +131,7 @@ ARTICLE: "collections" "Collections"
{ $subsection "graphs" } { $subsection "graphs" }
{ $subsection "buffers" } ; { $subsection "buffers" } ;
USE: io.sockets USING: io.sockets io.launcher io.mmap ;
ARTICLE: "io" "Input and output" ARTICLE: "io" "Input and output"
{ $subsection "streams" } { $subsection "streams" }
@ -144,7 +144,9 @@ ARTICLE: "io" "Input and output"
"Advanced features:" "Advanced features:"
{ $subsection "stream-binary" } { $subsection "stream-binary" }
{ $subsection "styles" } { $subsection "styles" }
{ $subsection "network-streams" } ; { $subsection "network-streams" }
{ $subsection "io.launcher" }
{ $subsection "io.mmap" } ;
ARTICLE: "tools" "Developer tools" ARTICLE: "tools" "Developer tools"
{ $subsection "tools.annotations" } { $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 ; system alien sequences.private ;
IN: io.mmap 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 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 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 INSTANCE: mapped-file sequence
HOOK: <mapped-file> io-backend ( path length -- mmap ) 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 -- ) : with-mapped-file ( path length quot -- )
>r <mapped-file> r> >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 dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
r> mmap-open \ mapped-file construct-boa ; 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-address ] keep
[ mapped-file-length munmap ] keep [ mapped-file-length munmap ] keep
mapped-file-handle close mapped-file-handle close

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

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

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

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

@ -3,10 +3,10 @@
USING: generic kernel math sequences timers arrays assocs ; USING: generic kernel math sequences timers arrays assocs ;
IN: models IN: models
TUPLE: model value connections dependencies ref ; TUPLE: model value connections dependencies ref locked? ;
: <model> ( value -- model ) : <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 ; M: model equal? 2drop f ;
@ -49,7 +49,7 @@ DEFER: remove-connection
drop drop
] if ; ] if ;
GENERIC: model-changed ( observer -- ) GENERIC: model-changed ( model observer -- )
: add-connection ( observer model -- ) : add-connection ( observer model -- )
dup model-connections empty? [ dup activate-model ] when dup model-connections empty? [ dup activate-model ] when
@ -60,11 +60,26 @@ GENERIC: model-changed ( observer -- )
dup model-connections empty? [ dup deactivate-model ] when dup model-connections empty? [ dup deactivate-model ] when
drop ; 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 GENERIC: update-model ( model -- )
M: model update-model drop ;
: set-model ( value model -- )
dup model-locked? [
2drop
] [
dup [
[ set-model-value ] keep [ set-model-value ] keep
model-connections [ model-changed ] each ; [ update-model ] keep
dup model-connections [ model-changed ] curry* each
] with-locked-model
] if ;
: ((change-model)) ( model quot -- newvalue model ) : ((change-model)) ( model quot -- newvalue model )
over >r >r model-value r> call r> ; inline over >r >r model-value r> call r> ; inline
@ -87,10 +102,10 @@ TUPLE: filter model quot ;
[ add-dependency ] keep ; [ add-dependency ] keep ;
M: filter model-changed M: filter model-changed
dup filter-model model-value over filter-quot call swap model-value over filter-quot call
swap set-model ; swap set-model ;
M: filter model-activated model-changed ; M: filter model-activated dup filter-model swap model-changed ;
TUPLE: compose ; TUPLE: compose ;
@ -103,11 +118,13 @@ TUPLE: compose ;
: set-composed-value >r model-dependencies r> 2each ; inline : set-composed-value >r model-dependencies r> 2each ; inline
M: compose model-changed M: compose model-changed
nip
dup [ model-value ] composed-value swap delegate set-model ; 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 ; TUPLE: mapping assoc ;
@ -117,13 +134,15 @@ TUPLE: mapping assoc ;
tuck set-mapping-assoc ; tuck set-mapping-assoc ;
M: mapping model-changed M: mapping model-changed
nip
dup mapping-assoc [ model-value ] assoc-map dup mapping-assoc [ model-value ] assoc-map
swap delegate set-model ; swap delegate set-model ;
M: mapping model-activated model-changed ; M: mapping model-activated dup model-changed ;
M: mapping set-model M: mapping update-model
mapping-assoc [ swapd at set-model ] curry assoc-each ; dup model-value swap mapping-assoc
[ swapd at set-model ] curry assoc-each ;
TUPLE: history back forward ; TUPLE: history back forward ;
@ -161,10 +180,9 @@ TUPLE: delay model timeout ;
f delay construct-model f delay construct-model
[ set-delay-timeout ] keep [ set-delay-timeout ] keep
[ set-delay-model ] 2keep [ set-delay-model ] 2keep
[ add-dependency ] keep [ add-dependency ] keep ;
dup update-delay-model ;
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 ; 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 -- ) M: cocoa-ui-backend (open-world-window) ( world -- )
dup gadget-window dup gadget-window
dup start-world
dup auto-position dup auto-position
world-handle second f -> makeKeyAndOrderFront: ; 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 ) : current-page ( book -- gadget )
[ control-value ] keep nth-gadget ; [ control-value ] keep nth-gadget ;
M: book model-changed ( book -- ) M: book model-changed
nip
dup hide-all dup hide-all
dup current-page show-gadget dup current-page show-gadget
relayout ; relayout ;
: <book> ( pages model -- book ) : <book> ( pages model -- book )
<gadget> book construct-control <gadget> book construct-control [ add-gadgets ] keep ;
[ add-gadgets ] keep
[ model-changed ] keep ;
M: book pref-dim* gadget-children pref-dims max-dim ; 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 IN: temporary
USING: ui.commands ui.gadgets.buttons ui.gadgets.labels 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 ; TUPLE: foo-gadget ;
@ -27,6 +28,12 @@ T{ foo-gadget } <toolbar> "t" set
} <radio-buttons> "religion" set } <radio-buttons> "religion" set
] unit-test ] unit-test
{ 2 1 } [ <radio-buttons> ] unit-test-effect
{ 2 1 } [ <toggle-buttons> ] unit-test-effect
{ 2 1 } [ <checkbox> ] unit-test-effect
[ 0 ] [ [ 0 ] [
"religion" get gadget-child radio-control-value "religion" get gadget-child radio-control-value
] unit-test ] unit-test

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

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

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

@ -16,9 +16,6 @@ $nl
{ { $link editor-focused? } " - a boolean." } { { $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> HELP: <editor>
{ $values { "editor" "a new " { $link editor } } } { $values { "editor" "a new " { $link editor } } }
{ $description "Creates a new " { $link editor } " with an empty document." } ; { $description "Creates a new " { $link editor } " with an empty document." } ;

27
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 USING: ui.gadgets.editors tools.test kernel io io.streams.plain
io.streams.string definitions namespaces ui.gadgets definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures ; ui.gadgets.grids prettyprint documents ui.gestures
tools.test.inference tools.test.ui ;
[ 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
[ "foo bar" ] [ [ "foo bar" ] [
<editor> "editor" set <editor> "editor" set
"editor" get graft* "editor" get [
"foo bar" "editor" get set-editor-string "foo bar" "editor" get set-editor-string
"editor" get T{ one-line-elt } select-elt "editor" get T{ one-line-elt } select-elt
"editor" get gadget-selection "editor" get gadget-selection
"editor" get ungraft* ] with-grafted-gadget
] unit-test ] unit-test
[ "baz quux" ] [ [ "baz quux" ] [
<editor> "editor" set <editor> "editor" set
"editor" get graft* "editor" get [
"foo bar\nbaz quux" "editor" get set-editor-string "foo bar\nbaz quux" "editor" get set-editor-string
"editor" get T{ one-line-elt } select-elt "editor" get T{ one-line-elt } select-elt
"editor" get gadget-selection "editor" get gadget-selection
"editor" get ungraft* ] with-grafted-gadget
] unit-test ] unit-test
[ ] [ [ ] [
<editor> "editor" set <editor> "editor" set
"editor" get graft* "editor" get [
"foo bar\nbaz quux" "editor" get set-editor-string "foo bar\nbaz quux" "editor" get set-editor-string
4 hand-click# set 4 hand-click# set
"editor" get position-caret "editor" get position-caret
"editor" get ungraft* ] with-grafted-gadget
] unit-test ] 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. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays documents ui.clipboards ui.commands ui.gadgets USING: arrays documents ui.clipboards ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io
ui.render ui.gestures io kernel math models namespaces opengl kernel math models namespaces opengl opengl.gl sequences strings
opengl.gl sequences strings io.styles math.vectors sorting io.styles math.vectors sorting colors combinators ;
colors combinators ;
IN: ui.gadgets.editors IN: ui.gadgets.editors
TUPLE: editor TUPLE: editor
@ -14,15 +13,11 @@ font color caret-color selection-color
caret mark caret mark
focused? ; focused? ;
TUPLE: loc-monitor editor ; : <loc> ( -- loc ) { 0 0 } <model> ;
: <loc> ( editor -- loc )
loc-monitor construct-boa
{ 0 0 } <model> [ add-connection ] keep ;
: init-editor-locs ( editor -- ) : init-editor-locs ( editor -- )
dup <loc> over set-editor-caret <loc> over set-editor-caret
dup <loc> swap set-editor-mark ; <loc> swap set-editor-mark ;
: editor-theme ( editor -- ) : editor-theme ( editor -- )
black over set-editor-color black over set-editor-color
@ -48,10 +43,14 @@ TUPLE: source-editor ;
: <source-editor> source-editor construct-editor ; : <source-editor> source-editor construct-editor ;
: activate-editor-model ( editor model -- ) : 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 -- ) : 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* M: editor graft*
dup dup
@ -63,12 +62,6 @@ M: editor ungraft*
dup editor-caret deactivate-editor-model dup editor-caret deactivate-editor-model
dup editor-mark 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-caret* ( editor -- loc ) editor-caret model-value ;
: editor-mark* ( editor -- loc ) editor-mark model-value ; : editor-mark* ( editor -- loc ) editor-mark model-value ;
@ -129,15 +122,11 @@ M: editor model-changed
line-height 0 swap 2array ; line-height 0 swap 2array ;
: scroll>caret ( editor -- ) : scroll>caret ( editor -- )
dup gadget-grafted? [ dup gadget-graft-state second [
dup caret-loc over caret-dim { 1 0 } v+ <rect> dup caret-loc over caret-dim { 1 0 } v+ <rect>
over scroll>rect over scroll>rect
] when drop ; ] when drop ;
M: loc-monitor model-changed
loc-monitor-editor editor-self
dup relayout-1 scroll>caret ;
: draw-caret ( -- ) : draw-caret ( -- )
editor get editor-focused? [ editor get editor-focused? [
editor get editor get
@ -219,6 +208,22 @@ M: editor draw-gadget*
M: editor pref-dim* M: editor pref-dim*
dup editor-font* swap control-value text-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? M: editor gadget-selection?
selection-start/end = not ; selection-start/end = not ;
@ -421,16 +426,6 @@ editor "selection" f {
{ T{ key-down f { S+ C+ } "END" } select-end-of-document } { T{ key-down f { S+ C+ } "END" } select-end-of-document }
} define-command-map } 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 ! Fields are like editors except they edit an external model
TUPLE: field model editor ; TUPLE: field model editor ;
@ -453,5 +448,6 @@ M: field ungraft*
dup field-editor gadget-model remove-connection ; dup field-editor gadget-model remove-connection ;
M: field model-changed M: field model-changed
nip
dup field-editor editor-string dup field-editor editor-string
swap field-model set-model ; swap field-model set-model ;

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

@ -1,6 +1,8 @@
IN: temporary IN: temporary
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test 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 } } ] [ T{ rect f { 10 10 } { 20 20 } } ]
[ [
@ -108,3 +110,95 @@ C: <fooey> fooey
{ 1 1 } "g4" get set-rect-dim { 1 1 } "g4" get set-rect-dim
[ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test [ 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> ; (rect-union) <extent-rect> ;
TUPLE: gadget TUPLE: gadget
pref-dim parent children orientation state focus pref-dim parent children orientation focus
visible? root? clipped? grafted? visible? root? clipped? layout-state graft-state
interior boundary interior boundary
model ; model ;
@ -50,7 +50,7 @@ M: gadget equal? 2drop f ;
M: gadget hashcode* drop gadget hashcode* ; M: gadget hashcode* drop gadget hashcode* ;
M: gadget model-changed drop ; M: gadget model-changed 2drop ;
: gadget-child ( gadget -- child ) gadget-children first ; : gadget-child ( gadget -- child ) gadget-children first ;
@ -59,10 +59,11 @@ M: gadget model-changed drop ;
: <zero-rect> ( -- rect ) { 0 0 } dup <rect> ; : <zero-rect> ( -- rect ) { 0 0 } dup <rect> ;
: <gadget> ( -- gadget ) : <gadget> ( -- gadget )
<zero-rect> { 0 1 } t { <zero-rect> { 0 1 } t { f f } {
set-delegate set-delegate
set-gadget-orientation set-gadget-orientation
set-gadget-visible? set-gadget-visible?
set-gadget-graft-state
} gadget construct ; } gadget construct ;
: construct-gadget ( class -- tuple ) : construct-gadget ( class -- tuple )
@ -70,7 +71,7 @@ M: gadget model-changed drop ;
: activate-control ( gadget -- ) : activate-control ( gadget -- )
dup gadget-model dup [ 2dup add-connection ] when drop dup gadget-model dup [ 2dup add-connection ] when drop
model-changed ; dup gadget-model swap model-changed ;
: deactivate-control ( gadget -- ) : deactivate-control ( gadget -- )
dup gadget-model dup [ 2dup remove-connection ] when 2drop ; dup gadget-model dup [ 2dup remove-connection ] when 2drop ;
@ -169,33 +170,33 @@ M: array gadget-text*
: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ; : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
: invalidate ( gadget -- ) : invalidate ( gadget -- )
\ invalidate swap set-gadget-state ; \ invalidate swap set-gadget-layout-state ;
: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ; : 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 #! When unit testing gadgets without the UI running, the
#! invalid queue is not initialized and we simply ignore #! invalid queue is not initialized and we simply ignore
#! invalidation requests. #! invalidation requests.
invalid [ push-front ] [ drop ] if* ; layout-queue [ push-front ] [ drop ] if* ;
DEFER: relayout DEFER: relayout
: invalidate* ( gadget -- ) : invalidate* ( gadget -- )
\ invalidate* over set-gadget-state \ invalidate* over set-gadget-layout-state
dup forget-pref-dim dup forget-pref-dim
dup gadget-root? dup gadget-root?
[ add-invalid ] [ gadget-parent [ relayout ] when* ] if ; [ layout-later ] [ gadget-parent [ relayout ] when* ] if ;
: relayout ( gadget -- ) : relayout ( gadget -- )
dup gadget-state \ invalidate* eq? dup gadget-layout-state \ invalidate* eq?
[ drop ] [ invalidate* ] if ; [ drop ] [ invalidate* ] if ;
: relayout-1 ( gadget -- ) : relayout-1 ( gadget -- )
dup gadget-state dup gadget-layout-state
[ drop ] [ dup invalidate add-invalid ] if ; [ drop ] [ dup invalidate layout-later ] if ;
: show-gadget t swap set-gadget-visible? ; : show-gadget t swap set-gadget-visible? ;
@ -215,7 +216,8 @@ DEFER: relayout
GENERIC: pref-dim* ( gadget -- dim ) GENERIC: pref-dim* ( gadget -- dim )
: ?set-gadget-pref-dim ( dim gadget -- ) : ?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 ) : pref-dim ( gadget -- dim )
dup gadget-pref-dim [ ] [ dup gadget-pref-dim [ ] [
@ -232,36 +234,59 @@ M: gadget layout* drop ;
: prefer ( gadget -- ) dup pref-dim swap set-layout-dim ; : 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 -- ) : layout ( gadget -- )
dup gadget-state [ dup gadget-layout-state [
dup validate dup validate
dup layout* dup layout*
dup [ layout ] each-child dup [ layout ] each-child
] when drop ; ] 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 -- ) GENERIC: graft* ( gadget -- )
M: gadget graft* drop ; M: gadget graft* drop ;
: graft ( gadget -- ) : graft ( gadget -- )
t over set-gadget-grafted? dup graft-later [ graft ] each-child ;
dup graft*
dup activate-control
[ graft ] each-child ;
GENERIC: ungraft* ( gadget -- ) GENERIC: ungraft* ( gadget -- )
M: gadget ungraft* drop ; M: gadget ungraft* drop ;
: ungraft ( gadget -- ) : ungraft ( gadget -- )
dup gadget-grafted? [ dup [ ungraft ] each-child ungraft-later ;
dup [ ungraft ] each-child
dup deactivate-control
dup ungraft*
f over set-gadget-grafted?
] when drop ;
: (unparent) ( gadget -- ) : (unparent) ( gadget -- )
dup ungraft dup ungraft
@ -272,7 +297,14 @@ M: gadget ungraft* drop ;
tuck gadget-focus eq? tuck gadget-focus eq?
[ f swap set-gadget-focus ] [ drop ] if ; [ 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 -- ) : unparent ( gadget -- )
not-in-layout
[ [
dup gadget-parent dup [ dup gadget-parent dup [
over (unparent) over (unparent)
@ -290,6 +322,7 @@ M: gadget ungraft* drop ;
f swap set-gadget-children ; f swap set-gadget-children ;
: clear-gadget ( gadget -- ) : clear-gadget ( gadget -- )
not-in-layout
dup (clear-gadget) relayout ; dup (clear-gadget) relayout ;
: ((add-gadget)) ( gadget box -- ) : ((add-gadget)) ( gadget box -- )
@ -299,12 +332,14 @@ M: gadget ungraft* drop ;
over unparent over unparent
dup pick set-gadget-parent dup pick set-gadget-parent
[ ((add-gadget)) ] 2keep [ ((add-gadget)) ] 2keep
gadget-grafted? [ graft ] [ drop ] if ; gadget-graft-state second [ graft ] [ drop ] if ;
: add-gadget ( gadget parent -- ) : add-gadget ( gadget parent -- )
not-in-layout
[ (add-gadget) ] keep relayout ; [ (add-gadget) ] keep relayout ;
: add-gadgets ( seq parent -- ) : add-gadgets ( seq parent -- )
not-in-layout
swap [ over (add-gadget) ] each relayout ; swap [ over (add-gadget) ] each relayout ;
: parents ( gadget -- seq ) : 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. ! pack-gap.
! The cursor is the current size of the incremental pack. ! 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 ; TUPLE: incremental cursor ;
: <incremental> ( pack -- incremental ) : <incremental> ( pack -- incremental )
incremental construct-empty dup pref-dim
[ set-gadget-delegate ] keep { set-gadget-delegate set-incremental-cursor }
dup delegate pref-dim over set-incremental-cursor ; incremental construct ;
M: incremental pref-dim* M: incremental pref-dim*
dup gadget-state [ dup gadget-layout-state [
dup delegate pref-dim over set-incremental-cursor dup delegate pref-dim over set-incremental-cursor
] when incremental-cursor ; ] when incremental-cursor ;
@ -39,9 +40,11 @@ M: incremental pref-dim*
swap set-rect-loc ; swap set-rect-loc ;
: prefer-incremental ( gadget -- ) : 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 -- ) : add-incremental ( gadget incremental -- )
not-in-layout
2dup (add-gadget) 2dup (add-gadget)
over prefer-incremental over prefer-incremental
2dup incremental-loc 2dup incremental-loc
@ -50,6 +53,8 @@ M: incremental pref-dim*
gadget-parent [ invalidate* ] when* ; gadget-parent [ invalidate* ] when* ;
: clear-incremental ( incremental -- ) : 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 { 0 0 } over set-incremental-cursor
gadget-parent [ relayout ] when* ; 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 ; TUPLE: label-control ;
M: label-control model-changed 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-control> ( model -- gadget )
"" <label> label-control construct-control ; "" <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 ; ] map 2nip ;
M: list model-changed M: list model-changed
nip
dup clear-gadget dup clear-gadget
dup <list-items> over add-gadgets dup <list-items> over add-gadgets
bound-index ; bound-index ;

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

@ -1,7 +1,8 @@
IN: temporary IN: temporary
USING: alien ui.gadgets.panes ui.gadgets namespaces USING: alien ui.gadgets.panes ui.gadgets namespaces
kernel sequences io io.streams.string tools.test prettyprint 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 ; : #children "pane" get gadget-children length ;
@ -33,3 +34,7 @@ ARTICLE: "test-article" "This is a test article"
<pane> [ \ = see ] with-pane <pane> [ \ = see ] with-pane
<pane> [ \ = help ] 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 ; TUPLE: pane-control quot ;
M: pane-control model-changed 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 ) : <pane-control> ( model quot -- pane )
>r <pane> pane-control construct-control r> >r <pane> pane-control construct-control r>

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

@ -2,7 +2,8 @@ IN: temporary
USING: ui.gadgets ui.gadgets.scrollers USING: ui.gadgets ui.gadgets.scrollers
namespaces tools.test kernel models ui.gadgets.viewports namespaces tools.test kernel models ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames 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 <gadget> "g" set
@ -23,9 +24,11 @@ ui.gadgets.sliders math math.vectors arrays sequences ;
<viewport> "v" set <viewport> "v" set
] unit-test ] unit-test
"v" get [
[ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test [ { 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 <gadget> { 100 100 } over set-rect-dim
@ -36,8 +39,7 @@ ui.gadgets.sliders math math.vectors arrays sequences ;
[ ] [ "s" get layout ] unit-test [ ] [ "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
@ -55,8 +57,7 @@ ui.gadgets.sliders math math.vectors arrays sequences ;
[ { 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 [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
] with-grafted-gadget
[ ] [ "s" get ungraft ] unit-test
<gadget> { 600 400 } over set-rect-dim "g1" set <gadget> { 600 400 } over set-rect-dim "g1" set
<gadget> { 600 10 } over set-rect-dim "g2" 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 [ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
[ t ] [ "s" get @right grid-child slider? ] unit-test [ t ] [ "s" get @right grid-child slider? ] unit-test
[ f ] [ "s" get @right grid-child find-scroller* ] 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 ] } { T{ mouse-scroll } [ do-mouse-scroll ] }
} set-gestures } set-gestures
: viewport, ( -- ) : viewport, ( child -- )
g gadget-model <viewport> g gadget-model <viewport>
g-> set-scroller-viewport @center frame, ; g-> set-scroller-viewport @center frame, ;
@ -106,7 +106,7 @@ scroller H{
dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ; dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
: scroll>bottom ( gadget -- ) : scroll>bottom ( gadget -- )
find-scroller* [ find-scroller [
t over set-scroller-follows relayout-1 t over set-scroller-follows relayout-1
] when* ; ] when* ;
@ -115,10 +115,10 @@ scroller H{
: update-scroller ( scroller follows -- ) : update-scroller ( scroller follows -- )
{ {
{ [ dup t eq? ] [ drop (scroll>bottom) "A" drop ] } { [ dup t eq? ] [ drop (scroll>bottom) ] }
{ [ dup rect? ] [ swap (scroll>rect) "B" drop ] } { [ dup rect? ] [ swap (scroll>rect) ] }
{ [ dup ] [ swap (scroll>gadget) "C" drop ] } { [ dup ] [ swap (scroll>gadget) ] }
{ [ t ] [ drop dup scroller-value swap scroll "D" drop ] } { [ t ] [ drop dup scroller-value swap scroll ] }
} cond ; } cond ;
M: scroller layout* M: scroller layout*
@ -131,4 +131,4 @@ M: scroller focusable-child*
scroller-viewport ; scroller-viewport ;
M: scroller model-changed 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 / ; : screen>slider slider-scale / ;
M: slider model-changed slider-elevator relayout-1 ; M: slider model-changed nip slider-elevator relayout-1 ;
TUPLE: thumb ; TUPLE: thumb ;
@ -131,7 +131,7 @@ M: elevator layout*
: slide-by-line ( amount slider -- ) : slide-by-line ( amount slider -- )
[ slider-line * ] keep slide-by ; [ slider-line * ] keep slide-by ;
: <slide-button> ( vector polygon amount -- ) : <slide-button> ( vector polygon amount -- button )
>r gray swap <polygon-gadget> r> >r gray swap <polygon-gadget> r>
[ swap find-slider slide-by-line ] curry <repeat-button> [ swap find-slider slide-by-line ] curry <repeat-button>
[ set-gadget-orientation ] keep ; [ set-gadget-orientation ] keep ;
@ -144,7 +144,7 @@ M: elevator layout*
: <left-button> { 0 1 } arrow-left -1 <slide-button> ; : <left-button> { 0 1 } arrow-left -1 <slide-button> ;
: <right-button> { 0 1 } arrow-right 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, <left-button> @left frame,
{ 0 1 } elevator, { 0 1 } elevator,
@ -154,7 +154,7 @@ M: elevator layout*
: <up-button> { 1 0 } arrow-up -1 <slide-button> ; : <up-button> { 1 0 } arrow-up -1 <slide-button> ;
: <down-button> { 1 0 } arrow-down 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, <up-button> @top frame,
{ 1 0 } elevator, { 1 0 } elevator,

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

@ -16,8 +16,7 @@ TUPLE: viewport ;
: <viewport> ( content model -- viewport ) : <viewport> ( content model -- viewport )
<gadget> viewport construct-control <gadget> viewport construct-control
t over set-gadget-clipped? t over set-gadget-clipped?
[ add-gadget ] keep [ add-gadget ] keep ;
[ model-changed ] keep ;
M: viewport layout* M: viewport layout*
dup rect-dim viewport-gap 2 v*n v- 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 ; gadget-model range-value [ >fixnum ] map ;
M: viewport model-changed M: viewport model-changed
nip
dup relayout-1 dup relayout-1
dup scroller-value dup scroller-value
vneg viewport-gap v+ 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 ] } { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
} set-gestures } set-gestures
: start-world ( world -- )
dup graft
dup relayout
dup world-title over set-title
request-focus ;
: close-global ( world global -- ) : close-global ( world global -- )
dup get-global find-world rot eq? dup get-global find-world rot eq?
[ f swap set-global ] [ drop ] if ; [ f swap set-global ] [ drop ] if ;
@ -126,3 +120,8 @@ world H{
drop-prefix <reversed> drop-prefix <reversed>
T{ lose-focus } swap each-gesture T{ lose-focus } swap each-gesture
T{ gain-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-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-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-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-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-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-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-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-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." } "Gadgets delegate to " { $link rect } " instances holding their location and dimensions." }
{ $notes { $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 2drop f
] if ; ] 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 -- ) : init-caret-help ( interactor -- )
dup <caret-help> swap set-interactor-help ; dup editor-caret 100 <delay> swap set-interactor-help ;
: init-interactor-history ( interactor -- ) : init-interactor-history ( interactor -- )
V{ } clone swap set-interactor-history ; V{ } clone swap set-interactor-history ;
@ -52,13 +41,20 @@ M: caret-help model-changed
M: interactor graft* M: interactor graft*
dup delegate graft* dup delegate graft*
dup interactor-help caret-help-model activate-model dup dup interactor-help add-connection
f swap set-interactor-busy? ; f swap set-interactor-busy? ;
M: interactor ungraft* M: interactor ungraft*
dup interactor-help caret-help-model deactivate-model dup dup interactor-help remove-connection
delegate ungraft* ; 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 -- ) : write-input ( string input -- )
<input> presented associate <input> presented associate
[ H{ { font-style bold } } format ] with-nesting ; [ H{ { font-style bold } } format ] with-nesting ;

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

@ -1,15 +1,18 @@
USING: continuations documents ui.tools.interactor USING: continuations documents ui.tools.interactor
ui.tools.listener hashtables kernel namespaces parser sequences ui.tools.listener hashtables kernel namespaces parser sequences
timers tools.test ui.commands ui.gadgets ui.gadgets.editors 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 IN: temporary
timers [ init-timers ] unless timers [ init-timers ] unless
[ f ] [ "word" source-editor command-map empty? ] unit-test [ f ] [ "word" source-editor command-map empty? ] unit-test
<listener-gadget> "listener" set [ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
[ ] [ <listener-gadget> "listener" set ] unit-test
"listener" get [
{ "kernel" } [ vocab-words ] map use associate { "kernel" } [ vocab-words ] map use associate
"listener" get listener-gadget-input set-interactor-vars "listener" get listener-gadget-input set-interactor-vars
@ -33,3 +36,4 @@ H{ } "i" get set-interactor-vars
"i" get gadget-model doc-end "i" get gadget-model doc-end
"i" get editor-caret* = "i" get editor-caret* =
] unit-test ] unit-test
] with-grafted-gadget

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

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

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

@ -2,7 +2,7 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
ui.tools.search ui.tools.workspace kernel models namespaces ui.tools.search ui.tools.workspace kernel models namespaces
sequences timers tools.test ui.gadgets ui.gadgets.buttons sequences timers tools.test ui.gadgets ui.gadgets.buttons
ui.gadgets.labelled ui.gadgets.presentations ui.gadgets.labelled ui.gadgets.presentations
ui.gadgets.scrollers vocabs ; ui.gadgets.scrollers vocabs tools.test.ui ui ;
IN: temporary IN: temporary
[ [
@ -31,18 +31,22 @@ timers get [ init-timers ] unless
"w" get hide-popup "w" get hide-popup
] unit-test ] unit-test
[ ] [ [ ] [ <workspace> [ ] with-grafted-gadget ] unit-test
<workspace> "w" set
"w" get graft
"w" get "kernel" vocab show-vocab-words
] unit-test
"w" get workspace-popup closable-gadget-content "w" get [
live-search-list gadget-child "p" set
[ ] [ "w" get "kernel" vocab show-vocab-words ] unit-test
[ ] [ notify-queued ] unit-test
[ ] [ "w" get workspace-popup closable-gadget-content
live-search-list gadget-child "p" set ] unit-test
[ t ] [ "p" get presentation? ] unit-test [ t ] [ "p" get presentation? ] unit-test
"p" get <operations-menu> gadget-child gadget-child "c" set [ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
[ ] [ notify-queued ] unit-test
[ t ] [ "c" get button? ] unit-test [ t ] [ "c" get button? ] unit-test
@ -51,4 +55,5 @@ live-search-list gadget-child "p" set
3 handle-parse-error 3 handle-parse-error
] unit-test ] unit-test
[ ] [ "w" get ungraft ] 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 ; ui.gadgets.status-bar mirrors ;
IN: ui.tools IN: ui.tools
: workspace-tabs ( -- seq )
{
<stack-display>
<browser-gadget>
<inspector-gadget>
<walker>
<profiler-gadget>
} ;
: <workspace-tabs> ( -- tabs ) : <workspace-tabs> ( -- tabs )
g gadget-model g gadget-model
"tool-switching" workspace command-map "tool-switching" workspace command-map
@ -28,7 +19,13 @@ IN: ui.tools
<toggle-buttons> ; <toggle-buttons> ;
: <workspace-book> ( -- gadget ) : <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 ) : <workspace> ( -- workspace )
0 <model> { 0 1 } <track> workspace construct-control [ 0 <model> { 0 1 } <track> workspace construct-control [
@ -52,6 +49,7 @@ IN: ui.tools
] if relayout ; ] if relayout ;
M: workspace model-changed M: workspace model-changed
nip
dup workspace-listener listener-gadget-output scroll>bottom dup workspace-listener listener-gadget-output scroll>bottom
dup resize-workspace dup resize-workspace
request-focus ; 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 ; ui.gadgets.tracks ui.gestures ;
IN: ui.tools.traceback IN: ui.tools.traceback
: <callstack-display> ( model -- ) : <callstack-display> ( model -- gadget )
[ [ continuation-call callstack. ] when* ] [ [ continuation-call callstack. ] when* ]
"Call stack" <labelled-pane> ; "Call stack" <labelled-pane> ;
: <datastack-display> ( model -- ) : <datastack-display> ( model -- gadget )
[ [ continuation-data stack. ] when* ] [ [ continuation-data stack. ] when* ]
"Data stack" <labelled-pane> ; "Data stack" <labelled-pane> ;
: <retainstack-display> ( model -- ) : <retainstack-display> ( model -- gadget )
[ [ continuation-retain stack. ] when* ] [ [ continuation-retain stack. ] when* ]
"Retain stack" <labelled-pane> ; "Retain stack" <labelled-pane> ;

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

@ -2,11 +2,14 @@ USING: arrays continuations ui.tools.listener ui.tools.walker
ui.tools.workspace inspector kernel namespaces sequences threads ui.tools.workspace inspector kernel namespaces sequences threads
listener tools.test ui ui.gadgets ui.gadgets.worlds listener tools.test ui ui.gadgets ui.gadgets.worlds
ui.gadgets.packs vectors ui.tools tools.interpreter ui.gadgets.packs vectors ui.tools tools.interpreter
tools.interpreter.debug ; tools.interpreter.debug tools.test.inference tools.test.ui ;
IN: temporary IN: temporary
{ 0 1 } [ <walker> ] unit-test-effect
[ ] [ <walker> "walker" set ] unit-test [ ] [ <walker> "walker" set ] unit-test
"walker" get [
! Make sure the toolbar buttons don't throw if we're ! Make sure the toolbar buttons don't throw if we're
! not actually walking. ! not actually walking.
@ -17,12 +20,12 @@ IN: temporary
[ ] [ "walker" get com-inspect ] unit-test [ ] [ "walker" get com-inspect ] unit-test
[ ] [ "walker" get reset-walker ] unit-test [ ] [ "walker" get reset-walker ] unit-test
[ ] [ "walker" get com-continue ] unit-test [ ] [ "walker" get com-continue ] unit-test
] with-grafted-gadget
: <test-world> ( gadget -- world ) : <test-world> ( gadget -- world )
[ gadget, ] make-pile "Hi" f <world> ; [ gadget, ] make-pile "Hi" f <world> ;
[ f <workspace> dup [
f <workspace>
[ <test-world> 2array 1vector windows set ] keep [ <test-world> 2array 1vector windows set ] keep
"ok" off "ok" off
@ -37,7 +40,7 @@ IN: temporary
[ t ] [ "ok" get ] unit-test [ t ] [ "ok" get ] unit-test
[ ] [ <walker> "w" set ] unit-test [ ] [ walker get-tool "w" set ] unit-test
continuation "c" set continuation "c" set
[ ] [ "c" get "w" get call-tool* ] unit-test [ ] [ "c" get "w" get call-tool* ] unit-test
@ -51,10 +54,11 @@ IN: temporary
"q" get dup first continuation? "q" get dup first continuation?
swap second \ inspect eq? and swap second \ inspect eq? and
] unit-test ] 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 [ 2 3 break 4 ] quot>cont f swap 2array walker call-tool
@ -71,4 +75,5 @@ IN: temporary
[ ] [ "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 ] 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 V{ } clone over set-walker-history
update-stacks ; update-stacks ;
M: walker graft* dup delegate graft* reset-walker ;
: <walker> ( -- gadget ) : <walker> ( -- gadget )
f <model> f f walker construct-boa [ f <model> f f walker construct-boa [
toolbar, toolbar,
g walker-model <traceback-gadget> 1 track, g walker-model <traceback-gadget> 1 track,
] { 0 1 } build-track ] { 0 1 } build-track ;
dup reset-walker ;
M: walker call-tool* ( continuation walker -- ) M: walker call-tool* ( continuation walker -- )
[ restore ] with-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 } } } { $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." } ; { $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 HELP: register-window
{ $values { "world" world } { "handle" "a baackend-specific handle" } } { $values { "world" world } { "handle" "a baackend-specific handle" } }
{ $description "Adds a window to the global " { $link windows } " variable." } { $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 } { $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:" "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 register-window }
{ $subsection start-world }
"The following words must also be implemented:" "The following words must also be implemented:"
{ $subsection set-title } { $subsection set-title }
{ $subsection raise-window } { $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 USING: arrays assocs io kernel math models namespaces
prettyprint dlists sequences threads sequences words timers prettyprint dlists sequences threads sequences words timers
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks 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 IN: ui
! Assoc mapping aliens to gadgets ! Assoc mapping aliens to gadgets
@ -53,25 +54,23 @@ SYMBOL: windows
reset-world ; reset-world ;
: open-world-window ( world -- ) : open-world-window ( world -- )
dup pref-dim over set-gadget-dim dup pref-dim over set-gadget-dim dup relayout graft ;
dup (open-world-window)
draw-world ;
: open-window ( gadget title -- ) : open-window ( gadget title -- )
>r [ 1 track, ] { 0 1 } make-track r> >r [ 1 track, ] { 0 1 } make-track r>
f <world> open-world-window ; f <world> open-world-window ;
: find-window ( quot -- world ) : find-window ( quot -- world )
windows get 1 <column> windows get values
[ gadget-child swap call ] curry* find-last nip ; inline [ gadget-child swap call ] curry* find-last nip ; inline
: restore-windows ( -- ) : restore-windows ( -- )
windows get [ 1 <column> >array ] keep delete-all windows get [ values ] keep delete-all
[ dup reset-world (open-world-window) ] each [ dup reset-world (open-world-window) ] each
forget-rollover ; forget-rollover ;
: restore-windows? ( -- ? ) : restore-windows? ( -- ? )
windows get [ empty? not ] [ f ] if* ; windows get empty? not ;
: update-hand ( world -- ) : update-hand ( world -- )
dup hand-world get-global eq? dup hand-world get-global eq?
@ -79,7 +78,8 @@ SYMBOL: windows
: layout-queued ( -- seq ) : layout-queued ( -- seq )
[ [
invalid [ in-layout? on
layout-queue [
dup layout find-world [ , ] when* dup layout find-world [ , ] when*
] dlist-slurp ] dlist-slurp
] { } make ; ] { } make ;
@ -87,24 +87,40 @@ SYMBOL: windows
SYMBOL: ui-hook SYMBOL: ui-hook
: init-ui ( -- ) : init-ui ( -- )
<dlist> \ invalid set-global <dlist> \ graft-queue set-global
<dlist> \ layout-queue set-global
V{ } clone windows 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 ( -- ) : start-ui ( -- )
init-timers init-timers
restore-windows? [ restore-windows? [
restore-windows restore-windows
] [ ] [
init-ui ui-hook get call init-ui ui-hook get call
] if ; ] if ui-step ;
: redraw-worlds ( seq -- )
[ dup update-hand draw-world ] each ;
: ui-step ( -- )
[
do-timers layout-queued redraw-worlds 10 sleep
] assert-depth ;
: ui-running ( quot -- ) : ui-running ( quot -- )
t \ ui-running set-global t \ ui-running set-global

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

@ -340,18 +340,19 @@ SYMBOL: hWnd
] ui-try ] ui-try
] alien-callback ; ] alien-callback ;
: do-events ( -- ) : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
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 ;
: event-loop ( -- ) : event-loop ( msg -- )
windows get empty? [ {
[ do-events ui-step ] ui-try event-loop { [ windows get empty? ] [ drop ] }
] unless ; { [ 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 ) : register-wndclassex ( -- class )
"WNDCLASSEX" <c-object> "WNDCLASSEX" <c-object>
@ -414,8 +415,8 @@ M: windows-ui-backend (open-world-window) ( world -- )
[ rect-dim first2 create-window dup setup-gl ] keep [ rect-dim first2 create-window dup setup-gl ] keep
[ f <win> ] keep [ f <win> ] keep
[ swap win-hWnd register-window ] 2keep [ swap win-hWnd register-window ] 2keep
[ set-world-handle ] 2keep dupd set-world-handle
start-world win-hWnd show-window ; win-hWnd show-window ;
M: windows-ui-backend select-gl-context ( handle -- ) M: windows-ui-backend select-gl-context ( handle -- )
[ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ; [ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ;
@ -442,7 +443,7 @@ M: windows-ui-backend ui
init-clipboard init-clipboard
init-win32-ui init-win32-ui
start-ui start-ui
event-loop msg-obj get event-loop
] [ cleanup-win32-ui ] [ ] cleanup ] [ cleanup-win32-ui ] [ ] cleanup
] ui-running ; ] 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 -- ) M: x11-ui-backend (open-world-window) ( world -- )
dup gadget-window dup gadget-window
dup start-world
world-handle x11-handle-window dup set-closable map-window ; world-handle x11-handle-window dup set-closable map-window ;
M: x11-ui-backend raise-window ( world -- ) 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; scan->forwarding = (F_BLOCK *)address;
address += scan->size; address += scan->size;
} }
else if(scan->status == B_MARKED)
critical_error("Why is the block marked?",0);
scan = next_block(heap,scan); 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); 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) void forward_object_xts(void)
{ {
begin_scan(); begin_scan();
@ -413,6 +423,11 @@ void forward_object_xts(void)
if(quot->compiledp != F) if(quot->compiledp != F)
set_quot_xt(quot,forward_xt(quot->code)); 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 */ /* End the heap scan */

17
vm/cpu-arm.h
View File

@ -5,23 +5,6 @@ register CELL rs asm("r6");
#define F_FASTCALL #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) #define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
void c_to_factor(CELL quot); 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 FACTOR_CPU_STRING "ppc"
#define F_FASTCALL #define F_FASTCALL

17
vm/cpu-x86.h
View File

@ -1,22 +1,5 @@
#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1) #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) {} INLINE void flush_icache(CELL start, CELL len) {}
F_FASTCALL void c_to_factor(CELL quot); F_FASTCALL void c_to_factor(CELL quot);

17
vm/layouts.h
View File

@ -255,3 +255,20 @@ typedef struct {
/* tagged */ /* tagged */
CELL length; CELL length;
} F_CALLSTACK; } 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