Merge branch 'master' of git://factorcode.org/git/factor
commit
869434eb78
|
@ -157,7 +157,7 @@ GENERIC: ' ( obj -- ptr )
|
|||
#! n is positive or zero.
|
||||
[ dup 0 > ]
|
||||
[ dup bignum-bits neg shift swap bignum-radix bitand ]
|
||||
{ } unfold ;
|
||||
[ ] unfold nip ;
|
||||
|
||||
: emit-bignum ( n -- )
|
||||
dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel vocabs vocabs.loader sequences ;
|
||||
USING: kernel vocabs vocabs.loader sequences system ;
|
||||
|
||||
{ "ui" "help" "tools" }
|
||||
[ "bootstrap." swap append vocab ] all? [
|
||||
|
@ -8,3 +8,5 @@ USING: kernel vocabs vocabs.loader sequences ;
|
|||
"ui.cocoa.tools" require
|
||||
] when
|
||||
] when
|
||||
|
||||
macosx? [ "ui.tools.deploy" require ] when
|
||||
|
|
|
@ -12,5 +12,3 @@ vocabs vocabs.loader ;
|
|||
|
||||
"ui.freetype" require
|
||||
] when
|
||||
|
||||
macosx? [ "ui.tools.deploy" require ] when
|
||||
|
|
|
@ -133,7 +133,7 @@ PRIVATE>
|
|||
>vector
|
||||
[ dup empty? not ]
|
||||
[ dup largest-class >r over delete-nth r> ]
|
||||
{ } unfold ;
|
||||
[ ] unfold nip ;
|
||||
|
||||
: class-or ( class1 class2 -- class )
|
||||
{
|
||||
|
|
|
@ -0,0 +1,32 @@
|
|||
! Copyright 2007 Ryan Murphy
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: kernel math tools.test heaps heaps.private ;
|
||||
IN: temporary
|
||||
|
||||
[ <min-heap> pop-heap ] unit-test-fails
|
||||
[ <max-heap> pop-heap ] unit-test-fails
|
||||
|
||||
[ t ] [ <min-heap> heap-empty? ] unit-test
|
||||
[ f ] [ <min-heap> 1 over push-heap heap-empty? ] unit-test
|
||||
[ t ] [ <max-heap> heap-empty? ] unit-test
|
||||
[ f ] [ <max-heap> 1 over push-heap heap-empty? ] unit-test
|
||||
|
||||
! Binary Min Heap
|
||||
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
|
||||
{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test
|
||||
{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test
|
||||
|
||||
[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ]
|
||||
[ <min-heap> { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test
|
||||
|
||||
[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [
|
||||
<min-heap> { 3 5 4 6 5 7 6 8 } over push-heap*
|
||||
3 [ dup pop-heap* ] times
|
||||
] unit-test
|
||||
|
||||
[ 2 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test
|
||||
|
||||
[ 1 ] [ <min-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
|
||||
|
||||
[ 400 ] [ <max-heap> 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test
|
|
@ -0,0 +1,112 @@
|
|||
! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences ;
|
||||
IN: heaps
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: heap data ;
|
||||
|
||||
: <heap> ( -- obj )
|
||||
V{ } clone heap construct-boa ;
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: min-heap ;
|
||||
|
||||
: <min-heap> ( -- obj )
|
||||
<heap> min-heap construct-delegate ;
|
||||
|
||||
TUPLE: max-heap ;
|
||||
|
||||
: <max-heap> ( -- obj )
|
||||
<heap> max-heap construct-delegate ;
|
||||
|
||||
<PRIVATE
|
||||
: left ( n -- m ) 2 * 1+ ;
|
||||
: right ( n -- m ) 2 * 2 + ;
|
||||
: up ( n -- m ) 1- 2 /i ;
|
||||
: left-value ( n heap -- obj ) >r left r> nth ;
|
||||
: right-value ( n heap -- obj ) >r right r> nth ;
|
||||
: up-value ( n vec -- obj ) >r up r> nth ;
|
||||
: swap-up ( n vec -- ) >r dup up r> exchange ;
|
||||
: last-index ( vec -- n ) length 1- ;
|
||||
|
||||
GENERIC: heap-compare ( obj1 obj2 heap -- ? )
|
||||
|
||||
M: min-heap heap-compare drop <=> 0 > ;
|
||||
M: max-heap heap-compare drop <=> 0 < ;
|
||||
|
||||
: left-bounds-check? ( m heap -- ? )
|
||||
>r left r> heap-data length >= ;
|
||||
|
||||
: right-bounds-check? ( m heap -- ? )
|
||||
>r right r> heap-data length >= ;
|
||||
|
||||
: (up-heap) ( vec heap -- )
|
||||
[
|
||||
>r [ last-index ] keep [ up-value ] keep peek r> heap-compare
|
||||
] 2keep rot [
|
||||
>r dup last-index
|
||||
[ over swap-up ] keep
|
||||
up 1+ head-slice
|
||||
r> (up-heap)
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: up-heap ( heap -- )
|
||||
[ heap-data ] keep (up-heap) ;
|
||||
|
||||
: child ( m heap -- n )
|
||||
2dup right-bounds-check? [
|
||||
drop left
|
||||
] [
|
||||
dupd
|
||||
[ heap-data left-value ] 2keep
|
||||
[ heap-data right-value ] keep heap-compare [
|
||||
right
|
||||
] [
|
||||
left
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: swap-down ( m heap -- )
|
||||
[ child ] 2keep heap-data exchange ;
|
||||
|
||||
DEFER: down-heap
|
||||
|
||||
: (down-heap) ( m heap -- )
|
||||
2dup [ heap-data nth ] 2keep child pick
|
||||
dupd [ heap-data nth swapd ] keep
|
||||
heap-compare [
|
||||
-rot [ swap-down ] keep down-heap
|
||||
] [
|
||||
3drop
|
||||
] if ;
|
||||
|
||||
: down-heap ( m heap -- )
|
||||
2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: push-heap ( obj heap -- )
|
||||
tuck heap-data push up-heap ;
|
||||
|
||||
: push-heap* ( seq heap -- )
|
||||
swap [ swap push-heap ] curry* each ;
|
||||
|
||||
: peek-heap ( heap -- obj )
|
||||
heap-data first ;
|
||||
|
||||
: pop-heap* ( heap -- )
|
||||
dup heap-data length 1 > [
|
||||
[ heap-data pop 0 ] keep
|
||||
[ heap-data set-nth ] keep
|
||||
>r 0 r> down-heap
|
||||
] [
|
||||
heap-data pop*
|
||||
] if ;
|
||||
|
||||
: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ;
|
||||
|
||||
: heap-empty? ( heap -- ? )
|
||||
heap-data empty? ;
|
|
@ -86,7 +86,7 @@ SYMBOL: stdio
|
|||
presented associate format ;
|
||||
|
||||
: lines ( stream -- seq )
|
||||
[ [ readln dup ] [ ] { } unfold ] with-stream ;
|
||||
[ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
|
||||
|
||||
: contents ( stream -- str )
|
||||
2048 <sbuf> [ stream-copy ] keep >string ;
|
||||
|
|
|
@ -60,6 +60,8 @@ $nl
|
|||
"A pair of utility words built from " { $link 2apply } ":"
|
||||
{ $subsection both? }
|
||||
{ $subsection either? }
|
||||
"A looping combinator:"
|
||||
{ $subsection while }
|
||||
"Quotations can be composed using efficient quotation-specific operations:"
|
||||
{ $subsection curry }
|
||||
{ $subsection 2curry }
|
||||
|
@ -538,3 +540,15 @@ HELP: 3compose
|
|||
}
|
||||
"However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
|
||||
} ;
|
||||
|
||||
HELP: while
|
||||
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation" } { "tail" "a quotation" } }
|
||||
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
|
||||
{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
|
||||
$nl
|
||||
"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:"
|
||||
{ $code
|
||||
"[ P ] [ Q ] [ T ] while"
|
||||
"[ P ] [ Q ] [ ] while T"
|
||||
}
|
||||
"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ;
|
||||
|
|
|
@ -16,29 +16,3 @@ math strings combinators ;
|
|||
pusher >r each-object r> >array ; inline
|
||||
|
||||
: save ( -- ) image save-image ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: intern-objects ( predicate -- )
|
||||
instances
|
||||
dup H{ } clone [ [ ] cache ] curry map
|
||||
become ; inline
|
||||
|
||||
: prepare-compress-image ( -- seq )
|
||||
[ sbuf? ] instances [ underlying ] map ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: compress-image ( -- )
|
||||
prepare-compress-image "bad-strings" [
|
||||
[
|
||||
{
|
||||
{ [ dup quotation? ] [ t ] }
|
||||
{ [ dup wrapper? ] [ t ] }
|
||||
{ [ dup fixnum? ] [ f ] }
|
||||
{ [ dup number? ] [ t ] }
|
||||
{ [ dup string? ] [ dup "bad-strings" get memq? not ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip
|
||||
] intern-objects
|
||||
] with-variable ;
|
||||
|
|
|
@ -5,7 +5,7 @@ USING: alien arrays generic hashtables inference.dataflow
|
|||
inference.class kernel assocs math math.private kernel.private
|
||||
sequences words parser vectors strings sbufs io namespaces
|
||||
assocs quotations sequences.private io.binary io.crc32
|
||||
io.buffers io.streams.string layouts splitting math.intervals
|
||||
io.streams.string layouts splitting math.intervals
|
||||
math.floats.private tuples tuples.private classes
|
||||
optimizer.def-use optimizer.backend optimizer.pattern-match
|
||||
float-arrays combinators.private ;
|
||||
|
@ -148,5 +148,3 @@ float-arrays combinators.private ;
|
|||
\ >le { { fixnum bignum } fixnum } "specializer" set-word-prop
|
||||
|
||||
\ >be { { fixnum bignum } fixnum } "specializer" set-word-prop
|
||||
|
||||
\ search-buffer-until { fixnum fixnum simple-alien string } "specializer" set-word-prop
|
||||
|
|
|
@ -127,8 +127,9 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
|
|||
{ $subsection 2reduce }
|
||||
"Mapping:"
|
||||
{ $subsection map }
|
||||
{ $subsection accumulate }
|
||||
{ $subsection 2map }
|
||||
{ $subsection accumulate }
|
||||
{ $subsection unfold }
|
||||
"Filtering:"
|
||||
{ $subsection push-if }
|
||||
{ $subsection subset } ;
|
||||
|
@ -230,6 +231,7 @@ $nl
|
|||
{ $subsection "sequences-tests" }
|
||||
{ $subsection "sequences-search" }
|
||||
{ $subsection "sequences-comparing" }
|
||||
{ $subsection "sequences-split" }
|
||||
{ $subsection "sequences-destructive" }
|
||||
{ $subsection "sequences-stacks" }
|
||||
"For inner loops:"
|
||||
|
@ -961,3 +963,13 @@ HELP: supremum
|
|||
{ $values { "seq" "a sequence of real numbers" } { "n" "a number" } }
|
||||
{ $description "Outputs the greatest element of " { $snippet "seq" } "." }
|
||||
{ $errors "Throws an error if the sequence is empty." } ;
|
||||
|
||||
HELP: unfold
|
||||
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation with stack effect " { $snippet "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } }
|
||||
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." }
|
||||
{ $examples
|
||||
"The following example divides a number by two until we reach zero, and accumulates intermediate results:"
|
||||
{ $example "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" }
|
||||
"The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:"
|
||||
{ $unchecked-example "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" }
|
||||
} ;
|
||||
|
|
|
@ -414,12 +414,10 @@ PRIVATE>
|
|||
: interleave ( seq between quot -- )
|
||||
[ (interleave) ] 2curry iterate-seq 2each ; inline
|
||||
|
||||
: unfold ( obj pred quot exemplar -- seq )
|
||||
[
|
||||
10 swap new-resizable [
|
||||
[ push ] curry compose [ drop ] while
|
||||
] keep
|
||||
] keep like ; inline
|
||||
: unfold ( pred quot tail -- seq )
|
||||
V{ } clone [
|
||||
swap >r [ push ] curry compose r> while
|
||||
] keep { } like ; inline
|
||||
|
||||
: index ( obj seq -- n )
|
||||
[ = ] curry* find drop ;
|
||||
|
|
|
@ -107,7 +107,7 @@ M: tuple equal?
|
|||
[ dup , delegate (delegates) ] when* ;
|
||||
|
||||
: delegates ( obj -- seq )
|
||||
[ dup ] [ [ delegate ] keep ] { } unfold ;
|
||||
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
|
||||
|
||||
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
|
||||
|
||||
|
|
|
@ -60,7 +60,7 @@ PRIVATE>
|
|||
(mailbox-block-if-empty)
|
||||
[ dup mailbox-empty? ]
|
||||
[ dup mailbox-data dlist-pop-front ]
|
||||
{ } unfold ;
|
||||
[ ] unfold nip ;
|
||||
|
||||
: mailbox-get-all ( mailbox -- array )
|
||||
f mailbox-get-all* ;
|
||||
|
|
|
@ -4,8 +4,8 @@ IN: editors
|
|||
ARTICLE: "editor" "Editor integration"
|
||||
"Factor development is best done with one of the supported editors; this allows you to quickly jump to definitions from the Factor environment."
|
||||
{ $subsection edit }
|
||||
"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } "."
|
||||
$nl
|
||||
"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } ", for example:"
|
||||
{ $code "USE: editors.emacs" }
|
||||
"Editor integration vocabularies store a quotation in a global variable when loaded:"
|
||||
{ $subsection edit-hook }
|
||||
"If a syntax error was thrown while loading a source file, you can jump to the location of the error in your editor:"
|
||||
|
|
|
@ -14,7 +14,7 @@ M: link uses
|
|||
collect-elements [ \ f or ] map ;
|
||||
|
||||
: help-path ( topic -- seq )
|
||||
[ dup ] [ [ article-parent ] keep ] { } unfold 1 tail ;
|
||||
[ dup ] [ [ article-parent ] keep ] [ ] unfold nip 1 tail ;
|
||||
|
||||
: set-article-parents ( parent article -- )
|
||||
article-children [ set-article-parent ] curry* each ;
|
||||
|
|
|
@ -3,7 +3,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.buffers
|
||||
USING: alien alien.syntax kernel kernel.private libc math
|
||||
sequences strings ;
|
||||
sequences strings hints ;
|
||||
|
||||
TUPLE: buffer size ptr fill pos ;
|
||||
|
||||
|
@ -54,6 +54,8 @@ TUPLE: buffer size ptr fill pos ;
|
|||
: search-buffer-until ( start end alien separators -- n )
|
||||
[ >r swap alien-unsigned-1 r> memq? ] 2curry find* drop ;
|
||||
|
||||
HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
|
||||
|
||||
: finish-buffer-until ( buffer n -- string separator )
|
||||
[
|
||||
over buffer-pos -
|
|
@ -12,7 +12,10 @@ GENERIC: protocol-family ( addrspec -- af )
|
|||
|
||||
GENERIC: sockaddr-type ( addrspec -- type )
|
||||
|
||||
GENERIC: make-sockaddr ( addrspec -- sockaddr type )
|
||||
GENERIC: make-sockaddr ( addrspec -- sockaddr )
|
||||
|
||||
: make-sockaddr/size ( addrspec -- sockaddr size )
|
||||
dup make-sockaddr swap sockaddr-type heap-size ;
|
||||
|
||||
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
|
||||
|
||||
|
@ -36,16 +39,15 @@ M: inet4 address-size drop 4 ;
|
|||
|
||||
M: inet4 protocol-family drop PF_INET ;
|
||||
|
||||
M: inet4 sockaddr-type drop "sockaddr-in" ;
|
||||
M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
|
||||
|
||||
M: inet4 make-sockaddr ( inet -- sockaddr type )
|
||||
M: inet4 make-sockaddr ( inet -- sockaddr )
|
||||
"sockaddr-in" <c-object>
|
||||
AF_INET over set-sockaddr-in-family
|
||||
over inet4-port htons over set-sockaddr-in-port
|
||||
over inet4-host
|
||||
"0.0.0.0" or
|
||||
rot inet-pton *uint over set-sockaddr-in-addr
|
||||
"sockaddr-in" ;
|
||||
rot inet-pton *uint over set-sockaddr-in-addr ;
|
||||
|
||||
M: inet4 parse-sockaddr
|
||||
>r dup sockaddr-in-addr <uint> r> inet-ntop
|
||||
|
@ -65,15 +67,14 @@ M: inet6 address-size drop 16 ;
|
|||
|
||||
M: inet6 protocol-family drop PF_INET6 ;
|
||||
|
||||
M: inet6 sockaddr-type drop "sockaddr-in6" ;
|
||||
M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
|
||||
|
||||
M: inet6 make-sockaddr ( inet -- sockaddr type )
|
||||
M: inet6 make-sockaddr ( inet -- sockaddr )
|
||||
"sockaddr-in6" <c-object>
|
||||
AF_INET6 over set-sockaddr-in6-family
|
||||
over inet6-port htons over set-sockaddr-in6-port
|
||||
over inet6-host "::" or
|
||||
rot inet-pton over set-sockaddr-in6-addr
|
||||
"sockaddr-in6" ;
|
||||
rot inet-pton over set-sockaddr-in6-addr ;
|
||||
|
||||
M: inet6 parse-sockaddr
|
||||
>r dup sockaddr-in6-addr r> inet-ntop
|
||||
|
@ -97,7 +98,7 @@ M: f parse-sockaddr nip ;
|
|||
: parse-addrinfo-list ( addrinfo -- seq )
|
||||
[ dup ]
|
||||
[ dup addrinfo-next swap addrinfo>addrspec ]
|
||||
{ } unfold [ ] subset ;
|
||||
[ ] unfold nip [ ] subset ;
|
||||
|
||||
M: object resolve-host ( host serv passive? -- seq )
|
||||
>r dup integer? [ number>string ] when
|
||||
|
|
|
@ -45,9 +45,9 @@ M: connect-task task-container drop write-tasks get-global ;
|
|||
[ swap <connect-task> add-io-task stop ] callcc0 drop ;
|
||||
|
||||
M: unix-io (client) ( addrspec -- stream )
|
||||
dup make-sockaddr >r >r
|
||||
dup make-sockaddr/size >r >r
|
||||
protocol-family SOCK_STREAM socket-fd
|
||||
dup r> r> heap-size connect
|
||||
dup r> r> connect
|
||||
zero? err_no EINPROGRESS = or [
|
||||
dup init-client-socket
|
||||
dup handle>duplex-stream
|
||||
|
@ -92,7 +92,7 @@ USE: io.sockets
|
|||
: server-fd ( addrspec type -- fd )
|
||||
>r dup protocol-family r> socket-fd
|
||||
dup init-server-socket
|
||||
dup rot make-sockaddr heap-size bind
|
||||
dup rot make-sockaddr/size bind
|
||||
zero? [ dup close (io-error) ] unless ;
|
||||
|
||||
M: unix-io <server> ( addrspec -- stream )
|
||||
|
@ -190,20 +190,19 @@ M: send-task task-container drop write-tasks get ;
|
|||
|
||||
M: unix-io send ( packet addrspec datagram -- )
|
||||
3dup check-datagram-send
|
||||
[ >r make-sockaddr heap-size r> wait-send ] keep
|
||||
[ >r make-sockaddr/size r> wait-send ] keep
|
||||
pending-error ;
|
||||
|
||||
M: local protocol-family drop PF_UNIX ;
|
||||
|
||||
M: local sockaddr-type drop "sockaddr-un" ;
|
||||
M: local sockaddr-type drop "sockaddr-un" c-type ;
|
||||
|
||||
M: local make-sockaddr
|
||||
local-path
|
||||
dup length 1 + max-un-path > [ "Path too long" throw ] when
|
||||
"sockaddr-un" <c-object>
|
||||
AF_UNIX over set-sockaddr-un-family
|
||||
dup sockaddr-un-path rot string>char-alien dup length memcpy
|
||||
"sockaddr-un" ;
|
||||
dup sockaddr-un-path rot string>char-alien dup length memcpy ;
|
||||
|
||||
M: local parse-sockaddr
|
||||
drop
|
||||
|
|
|
@ -153,7 +153,7 @@ M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
|
|||
|
||||
: do-connect ( addrspec -- socket )
|
||||
[ tcp-socket dup ] keep
|
||||
make-sockaddr heap-size
|
||||
make-sockaddr/size
|
||||
f f f f windows.winsock:WSAConnect zero? [
|
||||
winsock-error-string throw
|
||||
] unless ;
|
||||
|
@ -227,7 +227,7 @@ M: windows-ce-io send ( packet addrspec datagram -- )
|
|||
[ windows.winsock:set-WSABUF-len ] keep
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
|
||||
rot make-sockaddr heap-size
|
||||
rot make-sockaddr/size
|
||||
>r >r 1 0 <uint> 0 r> r> f f
|
||||
windows.winsock:WSASendTo zero? [
|
||||
winsock-error-string throw
|
||||
|
|
|
@ -29,8 +29,7 @@ TUPLE: ConnectEx-args port
|
|||
s* name* namelen* lpSendBuffer* dwSendDataLength*
|
||||
lpdwBytesSent* lpOverlapped* ptr* ;
|
||||
|
||||
: init-connect ( sockaddr sockaddr-name ConnectEx -- )
|
||||
>r heap-size r>
|
||||
: init-connect ( sockaddr size ConnectEx -- )
|
||||
[ set-ConnectEx-args-namelen* ] keep
|
||||
[ set-ConnectEx-args-name* ] keep
|
||||
f over set-ConnectEx-args-lpSendBuffer*
|
||||
|
@ -55,7 +54,7 @@ TUPLE: ConnectEx-args port
|
|||
M: windows-nt-io (client) ( addrspec -- duplex-stream )
|
||||
[
|
||||
\ ConnectEx-args construct-empty
|
||||
over make-sockaddr pick init-connect
|
||||
over make-sockaddr/size pick init-connect
|
||||
over tcp-socket over set-ConnectEx-args-s*
|
||||
dup ConnectEx-args-s* add-completion
|
||||
dup ConnectEx-args-s* get-ConnectEx-ptr over set-ConnectEx-args-ptr*
|
||||
|
@ -229,9 +228,9 @@ TUPLE: WSASendTo-args port
|
|||
>r delegate port-handle delegate win32-file-handle r>
|
||||
set-WSASendTo-args-s*
|
||||
] keep [
|
||||
>r make-sockaddr >r
|
||||
>r make-sockaddr/size >r
|
||||
malloc-byte-array dup free-always
|
||||
r> heap-size r>
|
||||
r> r>
|
||||
[ set-WSASendTo-args-iToLen* ] keep
|
||||
set-WSASendTo-args-lpTo*
|
||||
] keep [
|
||||
|
|
|
@ -175,7 +175,7 @@ USE: windows.winsock
|
|||
: server-fd ( addrspec type -- fd )
|
||||
>r dup protocol-family r> open-socket
|
||||
dup close-socket-later
|
||||
dup rot make-sockaddr heap-size bind socket-error ;
|
||||
dup rot make-sockaddr/size bind socket-error ;
|
||||
|
||||
USE: namespaces
|
||||
|
||||
|
|
|
@ -52,7 +52,6 @@ VARS: buffer-start buffer-length output-callback-var ;
|
|||
|
||||
: output ( data header pcm -- mad_flow )
|
||||
"output" . flush
|
||||
break
|
||||
-rot 2drop output-callback-var> call
|
||||
[ MAD_FLOW_CONTINUE ] [ MAD_FLOW_STOP ] if ;
|
||||
|
||||
|
|
|
@ -47,7 +47,6 @@ VARS: openal-buffer ;
|
|||
malloc [ fill-data ] keep ;
|
||||
|
||||
: output-openal ( pcm -- ? )
|
||||
break
|
||||
openal-buffer> swap ! buffer pcm
|
||||
[ get-format ] keep ! buffer format pcm
|
||||
[ get-data ] keep ! buffer format size alien pcm
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
IN: temporary
|
||||
USING: arrays generic kernel math models namespaces sequences
|
||||
tools.test assocs ;
|
||||
USING: arrays generic kernel math models namespaces sequences assocs
|
||||
tools.test ;
|
||||
|
||||
TUPLE: model-tester hit? ;
|
||||
|
||||
|
@ -137,3 +137,38 @@ f <history> "history" set
|
|||
] unit-test
|
||||
|
||||
[ ] [ "m" get deactivate-model ] unit-test
|
||||
|
||||
! Test <range>
|
||||
: setup-range 0 0 0 255 <range> ;
|
||||
|
||||
! clamp-value should not go past range ends
|
||||
[ 0 ] [ -10 setup-range clamp-value ] unit-test
|
||||
[ 255 ] [ 2000 setup-range clamp-value ] unit-test
|
||||
[ 14 ] [ 14 setup-range clamp-value ] unit-test
|
||||
|
||||
! range min/max/page values should be correct
|
||||
[ 0 ] [ setup-range range-page-value ] unit-test
|
||||
[ 0 ] [ setup-range range-min-value ] unit-test
|
||||
[ 255 ] [ setup-range range-max-value ] unit-test
|
||||
|
||||
! should be able to set the value within the range and get back
|
||||
[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test
|
||||
[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test
|
||||
[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test
|
||||
|
||||
! should be able to change the range min/max/page value
|
||||
[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test
|
||||
[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test
|
||||
[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test
|
||||
|
||||
! should be able to move by positive and negative values
|
||||
[ 30 ] [ setup-range 30 over move-by range-value ] unit-test
|
||||
[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test
|
||||
|
||||
! should be able to move by a page of 10
|
||||
[ 10 ] [
|
||||
setup-range 10 over set-range-page-value
|
||||
1 over move-by-page range-value
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
|
@ -207,7 +207,8 @@ M: range range-max-value range-max model-value ;
|
|||
M: range range-max-value*
|
||||
dup range-max-value swap range-page-value [-] ;
|
||||
|
||||
M: range set-range-value range-model set-model ;
|
||||
M: range set-range-value
|
||||
[ clamp-value ] keep range-model set-model ;
|
||||
|
||||
M: range set-range-page-value range-page set-model ;
|
||||
|
||||
|
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Portions copyright (C) 2007 Eduardo Cavazos.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types io kernel math namespaces
|
||||
sequences math.vectors math.constants math.functions opengl.gl opengl.glu combinators arrays ;
|
||||
USING: alien alien.c-types kernel math namespaces sequences
|
||||
math.vectors math.constants math.functions opengl.gl opengl.glu
|
||||
combinators arrays ;
|
||||
IN: opengl
|
||||
|
||||
: coordinates [ first2 ] 2apply ;
|
||||
|
@ -19,7 +20,7 @@ IN: opengl
|
|||
|
||||
: gl-error ( -- )
|
||||
glGetError dup zero? [
|
||||
"GL error: " write dup gluErrorString print flush
|
||||
"GL error: " dup gluErrorString append throw
|
||||
] unless drop ;
|
||||
|
||||
: do-state ( what quot -- )
|
||||
|
|
|
@ -261,7 +261,7 @@ DEFER: (deserialize) ( -- obj )
|
|||
V{ } clone serialized rot with-variable ; inline
|
||||
|
||||
: deserialize-sequence ( -- seq )
|
||||
[ [ deserialize* ] [ ] { } unfold ] with-serialized ;
|
||||
[ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ;
|
||||
|
||||
: deserialize ( -- obj )
|
||||
[ (deserialize) ] with-serialized ;
|
||||
|
|
|
@ -17,7 +17,7 @@ SYMBOL: deploy-io
|
|||
{ 3 "Level 3 - Non-blocking streams and networking" }
|
||||
} ;
|
||||
|
||||
: strip-io? deploy-io get zero? ;
|
||||
: strip-io? deploy-io get 1 = ;
|
||||
|
||||
: native-io? deploy-io get 3 = ;
|
||||
|
||||
|
|
|
@ -37,8 +37,8 @@ IN: tools.deploy
|
|||
""
|
||||
deploy-math? get " math" ?append
|
||||
deploy-compiler? get " compiler" ?append
|
||||
native-io? " io" ?append
|
||||
deploy-ui? get " ui" ?append
|
||||
native-io? " io" ?append
|
||||
] bind ;
|
||||
|
||||
: deploy-command-line ( vm image vocab config -- vm flags )
|
||||
|
@ -49,7 +49,7 @@ IN: tools.deploy
|
|||
|
||||
"\"-output-image=" swap "\"" 3append ,
|
||||
|
||||
"-no-stack-traces" ,
|
||||
! "-no-stack-traces" ,
|
||||
|
||||
"-no-user-init" ,
|
||||
] { } make ;
|
||||
|
|
|
@ -5,7 +5,7 @@ assocs kernel vocabs words sequences memory io system arrays
|
|||
continuations math definitions mirrors splitting parser classes
|
||||
inspector layouts vocabs.loader prettyprint.config prettyprint
|
||||
debugger io.streams.c io.streams.duplex io.files io.backend
|
||||
quotations words.private tools.deploy.config ;
|
||||
quotations words.private tools.deploy.config compiler ;
|
||||
IN: tools.deploy.shaker
|
||||
|
||||
: show ( msg -- )
|
||||
|
@ -23,6 +23,15 @@ IN: tools.deploy.shaker
|
|||
"Stripping debugger" show
|
||||
"resource:extra/tools/deploy/shaker/strip-debugger.factor"
|
||||
run-file
|
||||
recompile
|
||||
] when ;
|
||||
|
||||
: strip-libc ( -- )
|
||||
"libc" vocab [
|
||||
"Stripping manual memory management debug code" show
|
||||
"resource:extra/tools/deploy/shaker/strip-libc.factor"
|
||||
run-file
|
||||
recompile
|
||||
] when ;
|
||||
|
||||
: strip-cocoa ( -- )
|
||||
|
@ -30,6 +39,7 @@ IN: tools.deploy.shaker
|
|||
"Stripping unused Cocoa methods" show
|
||||
"resource:extra/tools/deploy/shaker/strip-cocoa.factor"
|
||||
run-file
|
||||
recompile
|
||||
] when ;
|
||||
|
||||
: strip-assoc ( retained-keys assoc -- newassoc )
|
||||
|
@ -70,8 +80,8 @@ IN: tools.deploy.shaker
|
|||
strip-word-defs ;
|
||||
|
||||
: strip-environment ( retain-globals -- )
|
||||
"Stripping environment" show
|
||||
strip-globals? [
|
||||
"Stripping environment" show
|
||||
global strip-assoc 21 setenv
|
||||
] [ drop ] if ;
|
||||
|
||||
|
@ -126,7 +136,7 @@ SYMBOL: deploy-vocab
|
|||
} %
|
||||
] unless
|
||||
|
||||
deploy-c-types? get deploy-ui? get or [
|
||||
deploy-c-types? get [
|
||||
"c-types" "alien.c-types" lookup ,
|
||||
] when
|
||||
|
||||
|
@ -141,6 +151,7 @@ SYMBOL: deploy-vocab
|
|||
] { } make dup . ;
|
||||
|
||||
: strip ( -- )
|
||||
strip-libc
|
||||
strip-cocoa
|
||||
strip-debugger
|
||||
strip-init-hooks
|
||||
|
@ -160,8 +171,6 @@ SYMBOL: deploy-vocab
|
|||
deploy-vocab get require
|
||||
r> [ call ] when*
|
||||
strip
|
||||
"Compressing image" show
|
||||
compress-image
|
||||
finish-deploy
|
||||
] [
|
||||
print-error flush 1 exit
|
||||
|
|
|
@ -0,0 +1,8 @@
|
|||
USING: libc.private ;
|
||||
IN: libc
|
||||
|
||||
: malloc (malloc) ;
|
||||
|
||||
: free (free) ;
|
||||
|
||||
: realloc (realloc) ;
|
|
@ -20,7 +20,8 @@ M: border pref-dim*
|
|||
|
||||
: border-minor-rect ( major border -- rect )
|
||||
gadget-child pref-dim
|
||||
[ >r rect-bounds r> v- 2 v/n v+ ] keep <rect> ;
|
||||
[ >r rect-bounds r> v- [ 2 / >fixnum ] map v+ ] keep
|
||||
<rect> ;
|
||||
|
||||
: scale-rect ( rect vec -- loc dim )
|
||||
[ v* ] curry >r rect-bounds r> 2apply ;
|
||||
|
|
|
@ -4,7 +4,8 @@ USING: arrays ui.commands ui.gadgets ui.gadgets.borders
|
|||
ui.gadgets.controls ui.gadgets.labels ui.gadgets.theme
|
||||
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
|
||||
ui.render kernel math models namespaces sequences strings
|
||||
quotations assocs combinators classes colors tuples ;
|
||||
quotations assocs combinators classes colors tuples opengl
|
||||
math.vectors ;
|
||||
IN: ui.gadgets.buttons
|
||||
|
||||
TUPLE: button pressed? selected? quot ;
|
||||
|
@ -95,6 +96,18 @@ repeat-button H{
|
|||
repeat-button construct-empty
|
||||
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
|
||||
|
||||
TUPLE: checkmark-paint color ;
|
||||
|
||||
C: <checkmark-paint> checkmark-paint
|
||||
|
||||
M: checkmark-paint draw-interior
|
||||
checkmark-paint-color gl-color
|
||||
origin get [
|
||||
rect-dim
|
||||
{ 0 0 } over gl-line
|
||||
dup { 0 1 } v* swap { 1 0 } v* gl-line
|
||||
] with-translation ;
|
||||
|
||||
: checkmark-theme ( gadget -- )
|
||||
f
|
||||
f
|
||||
|
@ -125,6 +138,18 @@ repeat-button H{
|
|||
[ set-button-selected? ] <control>
|
||||
dup checkbox-theme ;
|
||||
|
||||
TUPLE: radio-paint color ;
|
||||
|
||||
C: <radio-paint> radio-paint
|
||||
|
||||
M: radio-paint draw-interior
|
||||
radio-paint-color gl-color
|
||||
origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
|
||||
|
||||
M: radio-paint draw-boundary
|
||||
radio-paint-color gl-color
|
||||
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
|
||||
|
||||
: radio-knob-theme ( gadget -- )
|
||||
f
|
||||
f
|
||||
|
|
|
@ -286,7 +286,7 @@ M: gadget ungraft* drop ;
|
|||
swap [ over (add-gadget) ] each relayout ;
|
||||
|
||||
: parents ( gadget -- seq )
|
||||
[ dup ] [ [ gadget-parent ] keep ] { } unfold ;
|
||||
[ dup ] [ [ gadget-parent ] keep ] [ ] unfold nip ;
|
||||
|
||||
: each-parent ( gadget quot -- ? )
|
||||
>r parents r> all? ; inline
|
||||
|
@ -333,7 +333,7 @@ M: f request-focus-on 2drop ;
|
|||
dup focusable-child swap request-focus-on ;
|
||||
|
||||
: focus-path ( world -- seq )
|
||||
[ dup ] [ [ gadget-focus ] keep ] { } unfold ;
|
||||
[ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ;
|
||||
|
||||
: make-gadget ( quot gadget -- gadget )
|
||||
[ \ make-gadget rot with-variable ] keep ; inline
|
||||
|
|
|
@ -140,32 +140,6 @@ M: polygon draw-interior
|
|||
>r <polygon> <gadget> r> over set-rect-dim
|
||||
[ set-gadget-interior ] keep ;
|
||||
|
||||
! Checkbox and radio button pens
|
||||
TUPLE: checkmark-paint color ;
|
||||
|
||||
C: <checkmark-paint> checkmark-paint
|
||||
|
||||
M: checkmark-paint draw-interior
|
||||
checkmark-paint-color gl-color
|
||||
origin get [
|
||||
rect-dim
|
||||
{ 0 0 } over gl-line
|
||||
dup { 0 1 } v* swap { 1 0 } v* gl-line
|
||||
] with-translation ;
|
||||
|
||||
|
||||
TUPLE: radio-paint color ;
|
||||
|
||||
C: <radio-paint> radio-paint
|
||||
|
||||
M: radio-paint draw-interior
|
||||
radio-paint-color gl-color
|
||||
origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
|
||||
|
||||
M: radio-paint draw-boundary
|
||||
radio-paint-color gl-color
|
||||
origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
|
||||
|
||||
! Font rendering
|
||||
SYMBOL: font-renderer
|
||||
|
||||
|
|
|
@ -107,6 +107,7 @@ FUNCTION: void close ( int fd ) ;
|
|||
FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ;
|
||||
FUNCTION: int dup2 ( int oldd, int newd ) ;
|
||||
! FUNCTION: int dup ( int oldd ) ;
|
||||
FUNCTION: int execv ( char* path, char** argv ) ;
|
||||
FUNCTION: int execvp ( char* path, char** argv ) ;
|
||||
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
|
||||
FUNCTION: int fchdir ( int fd ) ;
|
||||
|
@ -164,6 +165,18 @@ FUNCTION: int system ( char* command ) ;
|
|||
FUNCTION: time_t time ( time_t* t ) ;
|
||||
FUNCTION: int unlink ( char* path ) ;
|
||||
FUNCTION: int utimes ( char* path, timeval[2] times ) ;
|
||||
|
||||
! Flags for waitpid
|
||||
|
||||
: WNOHANG 1 ;
|
||||
: WUNTRACED 2 ;
|
||||
|
||||
: WSTOPPED 2 ;
|
||||
: WEXITED 4 ;
|
||||
: WCONTINUED 8 ;
|
||||
: WNOWAIT HEX: 1000000 ;
|
||||
|
||||
FUNCTION: pid_t wait ( int* status ) ;
|
||||
FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
|
||||
|
||||
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
|
||||
|
|
|
@ -51,8 +51,7 @@ void ffi_dlopen (F_DLL *dll, bool error)
|
|||
{
|
||||
dll->dll = NULL;
|
||||
if(error)
|
||||
general_error(ERROR_FFI,F,F,
|
||||
(void*)tag_object(get_error_message()));
|
||||
general_error(ERROR_FFI,F,tag_object(get_error_message()),NULL);
|
||||
else
|
||||
return;
|
||||
}
|
||||
|
|
Loading…
Reference in New Issue