Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
645870c6c0
|
|
@ -184,7 +184,7 @@ HELP: time+
|
|||
{ $description "Adds two durations to produce a duration or adds a timestamp and a duration to produce a timestamp. The calculation takes timezones into account." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar math.order prettyprint ;"
|
||||
"10 months 2 months time+ 1 year <=> ."
|
||||
"10 months 2 months time+ 1 years <=> ."
|
||||
"+eq+"
|
||||
}
|
||||
{ $example "USING: accessors calendar math.order prettyprint ;"
|
||||
|
|
@ -193,3 +193,109 @@ HELP: time+
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: dt>years
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in years." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"6 months dt>years ."
|
||||
"1/2"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: dt>months
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in months." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"30 days dt>months ."
|
||||
"16000/16233"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: dt>days
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in days." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"6 hours dt>days ."
|
||||
"1/4"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: dt>hours
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in hours." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"3/4 days dt>hours ."
|
||||
"18"
|
||||
}
|
||||
} ;
|
||||
HELP: dt>minutes
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in minutes." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"6 hours dt>minutes ."
|
||||
"360"
|
||||
}
|
||||
} ;
|
||||
HELP: dt>seconds
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in seconds." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"6 minutes dt>seconds ."
|
||||
"360"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: dt>milliseconds
|
||||
{ $values { "duration" duration } { "x" number } }
|
||||
{ $description "Calculates the length of a duration in milliseconds." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar prettyprint ;"
|
||||
"6 seconds dt>milliseconds ."
|
||||
"6000"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ dt>years dt>months dt>days dt>hours dt>minutes dt>seconds dt>milliseconds } related-words
|
||||
|
||||
|
||||
HELP: time-
|
||||
{ $values { "time1" "timestamp or duration" } { "time2" "timestamp or duration" } { "time3" "timestamp or duration" } }
|
||||
{ $description "Subtracts two durations to produce a duration or subtracts a duration from a timestamp to produce a timestamp. The calculation takes timezones into account." }
|
||||
{ $examples
|
||||
{ $example "USING: calendar math.order prettyprint ;"
|
||||
"10 months 2 months time- 8 months <=> ."
|
||||
"+eq+"
|
||||
}
|
||||
{ $example "USING: accessors calendar math.order prettyprint ;"
|
||||
"2010 1 1 <date> 3 days time- day>> ."
|
||||
"29"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ time+ time- } related-words
|
||||
|
||||
HELP: convert-timezone
|
||||
{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp" timestamp } }
|
||||
{ $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: accessors calendar prettyprint ;"
|
||||
"gmt noon instant -5 >>hour convert-timezone gmt-offset>> hour>> ."
|
||||
"-5"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: >local-time
|
||||
{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
|
||||
{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
|
||||
{ $examples
|
||||
{ $example "USING: accessors calendar kernel prettyprint ;"
|
||||
"now gmt >local-time [ gmt-offset>> ] bi@ = ."
|
||||
"t"
|
||||
}
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -60,6 +60,8 @@ PRIVATE>
|
|||
: month-abbreviation ( n -- string )
|
||||
check-month 1- month-abbreviations nth ;
|
||||
|
||||
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
|
||||
|
||||
: day-names ( -- array )
|
||||
{
|
||||
"Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
|
||||
|
|
@ -116,7 +118,7 @@ PRIVATE>
|
|||
: >time< ( timestamp -- hour minute second )
|
||||
[ hour>> ] [ minute>> ] [ second>> ] tri ;
|
||||
|
||||
MEMO: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
|
||||
: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
|
||||
: years ( x -- duration ) instant clone swap >>year ;
|
||||
: months ( x -- duration ) instant clone swap >>month ;
|
||||
: days ( x -- duration ) instant clone swap >>day ;
|
||||
|
|
@ -258,7 +260,7 @@ M: duration <=> [ dt>years ] compare ;
|
|||
: dt>seconds ( duration -- x ) dt>years seconds-per-year * ;
|
||||
: dt>milliseconds ( duration -- x ) dt>seconds 1000 * ;
|
||||
|
||||
GENERIC: time- ( time1 time2 -- time )
|
||||
GENERIC: time- ( time1 time2 -- time3 )
|
||||
|
||||
: convert-timezone ( timestamp duration -- timestamp )
|
||||
over gmt-offset>> over = [ drop ] [
|
||||
|
|
@ -323,12 +325,9 @@ MEMO: unix-1970 ( -- timestamp )
|
|||
unix-1970 millis milliseconds time+ ;
|
||||
|
||||
: now ( -- timestamp ) gmt >local-time ;
|
||||
|
||||
: hence ( duration -- timestamp ) now swap time+ ;
|
||||
: ago ( duration -- timestamp ) now swap time- ;
|
||||
|
||||
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
|
||||
|
||||
: zeller-congruence ( year month day -- n )
|
||||
#! Zeller Congruence
|
||||
#! http://web.textfiles.com/computers/formulas.txt
|
||||
|
|
@ -395,7 +394,6 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
|
|||
: time-since-midnight ( timestamp -- duration )
|
||||
dup midnight time- ;
|
||||
|
||||
|
||||
M: timestamp sleep-until timestamp>millis sleep-until ;
|
||||
|
||||
M: duration sleep hence sleep-until ;
|
||||
|
|
|
|||
|
|
@ -84,6 +84,13 @@ FUNCTION: tiny ffi_test_17 int x ;
|
|||
|
||||
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
|
||||
|
||||
: indirect-test-1' ( ptr -- )
|
||||
"int" { } "cdecl" alien-indirect drop ;
|
||||
|
||||
{ 1 0 } [ indirect-test-1' ] must-infer-as
|
||||
|
||||
[ ] [ "ffi_test_1" f dlsym indirect-test-1' ] unit-test
|
||||
|
||||
[ -1 indirect-test-1 ] must-fail
|
||||
|
||||
: indirect-test-2 ( x y ptr -- result )
|
||||
|
|
|
|||
|
|
@ -81,11 +81,19 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
|
|||
drop-values
|
||||
] ;
|
||||
|
||||
: drop-dead-outputs ( node -- nodes )
|
||||
: drop-dead-outputs ( node -- #shuffle )
|
||||
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
|
||||
|
||||
: some-outputs-dead? ( #call -- ? )
|
||||
out-d>> [ live-value? not ] contains? ;
|
||||
|
||||
: maybe-drop-dead-outputs ( node -- nodes )
|
||||
dup some-outputs-dead? [
|
||||
dup drop-dead-outputs 2array
|
||||
] when ;
|
||||
|
||||
M: #introduce remove-dead-code* ( #introduce -- nodes )
|
||||
dup drop-dead-outputs 2array ;
|
||||
maybe-drop-dead-outputs ;
|
||||
|
||||
M: #>r remove-dead-code*
|
||||
[ filter-live ] change-out-r
|
||||
|
|
@ -110,17 +118,9 @@ M: #push remove-dead-code*
|
|||
[ in-d>> #drop remove-dead-code* ]
|
||||
bi ;
|
||||
|
||||
: some-outputs-dead? ( #call -- ? )
|
||||
out-d>> [ live-value? not ] contains? ;
|
||||
|
||||
M: #call remove-dead-code*
|
||||
dup dead-flushable-call? [
|
||||
remove-flushable-call
|
||||
] [
|
||||
dup some-outputs-dead? [
|
||||
dup drop-dead-outputs 2array
|
||||
] when
|
||||
] if ;
|
||||
dup dead-flushable-call?
|
||||
[ remove-flushable-call ] [ maybe-drop-dead-outputs ] if ;
|
||||
|
||||
M: #shuffle remove-dead-code*
|
||||
[ filter-live ] change-in-d
|
||||
|
|
@ -136,3 +136,9 @@ M: #copy remove-dead-code*
|
|||
M: #terminate remove-dead-code*
|
||||
[ filter-live ] change-in-d
|
||||
[ filter-live ] change-in-r ;
|
||||
|
||||
M: #alien-invoke remove-dead-code*
|
||||
maybe-drop-dead-outputs ;
|
||||
|
||||
M: #alien-indirect remove-dead-code*
|
||||
maybe-drop-dead-outputs ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors sequences parser kernel help help.markup
|
||||
USING: fry accessors sequences parser kernel help help.markup
|
||||
help.topics words strings classes tools.vocabs namespaces io
|
||||
io.streams.string prettyprint definitions arrays vectors
|
||||
combinators combinators.short-circuit splitting debugger
|
||||
|
|
@ -39,7 +39,7 @@ IN: help.lint
|
|||
$predicate
|
||||
$class-description
|
||||
$error-description
|
||||
} swap [ elements f like ] curry contains? ;
|
||||
} swap '[ , elements empty? not ] contains? ;
|
||||
|
||||
: check-values ( word element -- )
|
||||
{
|
||||
|
|
@ -108,12 +108,10 @@ M: help-error error.
|
|||
articles get keys
|
||||
vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
|
||||
H{ } clone [
|
||||
[
|
||||
[ dup >link where dup ] 2dip
|
||||
[ >r >r first r> at r> push-at ] 2curry
|
||||
[ 2drop ]
|
||||
if
|
||||
] 2curry each
|
||||
'[
|
||||
dup >link where dup
|
||||
[ first , at , push-at ] [ 2drop ] if
|
||||
] each
|
||||
] keep ;
|
||||
|
||||
: check-about ( vocab -- )
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ IN: help.topics.tests
|
|||
|
||||
SYMBOL: foo
|
||||
|
||||
[ ] [ { "test" "a" } "Test A" { { $subsection foo } } <article> add-article ] unit-test
|
||||
[ ] [ "Test A" { { $subsection foo } } <article> { "test" "a" } add-article ] unit-test
|
||||
|
||||
! Test article location recording
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ windows.types math windows.kernel32
|
|||
namespaces io.launcher kernel sequences windows.errors
|
||||
splitting system threads init strings combinators
|
||||
io.backend accessors concurrency.flags io.files assocs
|
||||
io.files.private windows destructors classes.tuple.lib ;
|
||||
io.files.private windows destructors ;
|
||||
IN: io.windows.launcher
|
||||
|
||||
TUPLE: CreateProcess-args
|
||||
|
|
@ -30,7 +30,19 @@ TUPLE: CreateProcess-args
|
|||
0 >>dwCreateFlags ;
|
||||
|
||||
: call-CreateProcess ( CreateProcess-args -- )
|
||||
CreateProcess-args >tuple< CreateProcess win32-error=0/f ;
|
||||
{
|
||||
[ lpApplicationName>> ]
|
||||
[ lpCommandLine>> ]
|
||||
[ lpProcessAttributes>> ]
|
||||
[ lpThreadAttributes>> ]
|
||||
[ bInheritHandles>> ]
|
||||
[ dwCreateFlags>> ]
|
||||
[ lpEnvironment>> ]
|
||||
[ lpCurrentDirectory>> ]
|
||||
[ lpStartupInfo>> ]
|
||||
[ lpProcessInformation>> ]
|
||||
} cleave
|
||||
CreateProcess win32-error=0/f ;
|
||||
|
||||
: count-trailing-backslashes ( str n -- str n )
|
||||
>r "\\" ?tail r> swap [
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
USING: alien alien.c-types arrays assocs combinators
|
||||
continuations destructors io io.backend io.ports io.timeouts
|
||||
io.windows io.windows.files libc kernel math namespaces
|
||||
sequences threads classes.tuple.lib windows windows.errors
|
||||
windows.kernel32 strings splitting io.files
|
||||
io.buffers qualified ascii system
|
||||
sequences threads windows windows.errors windows.kernel32
|
||||
strings splitting io.files io.buffers qualified ascii system
|
||||
accessors locals ;
|
||||
QUALIFIED: windows.winsock
|
||||
IN: io.windows.nt.backend
|
||||
|
|
|
|||
|
|
@ -1,9 +1,8 @@
|
|||
USING: alien alien.accessors alien.c-types byte-arrays
|
||||
continuations destructors io.ports io.timeouts io.sockets
|
||||
io.sockets io namespaces io.streams.duplex io.windows
|
||||
io.windows.sockets
|
||||
io.windows.nt.backend windows.winsock kernel libc math sequences
|
||||
threads classes.tuple.lib system combinators accessors ;
|
||||
io.windows.sockets io.windows.nt.backend windows.winsock kernel
|
||||
libc math sequences threads system combinators accessors ;
|
||||
IN: io.windows.nt.sockets
|
||||
|
||||
: malloc-int ( object -- object )
|
||||
|
|
@ -28,71 +27,89 @@ M: winnt WSASocket-flags ( -- DWORD )
|
|||
] keep *void* ;
|
||||
|
||||
TUPLE: ConnectEx-args port
|
||||
s* name* namelen* lpSendBuffer* dwSendDataLength*
|
||||
lpdwBytesSent* lpOverlapped* ptr* ;
|
||||
s name namelen lpSendBuffer dwSendDataLength
|
||||
lpdwBytesSent lpOverlapped ptr ;
|
||||
|
||||
: wait-for-socket ( args -- n )
|
||||
[ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
|
||||
[ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
|
||||
|
||||
: <ConnectEx-args> ( sockaddr size -- ConnectEx )
|
||||
ConnectEx-args new
|
||||
swap >>namelen*
|
||||
swap >>name*
|
||||
f >>lpSendBuffer*
|
||||
0 >>dwSendDataLength*
|
||||
f >>lpdwBytesSent*
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
swap >>namelen
|
||||
swap >>name
|
||||
f >>lpSendBuffer
|
||||
0 >>dwSendDataLength
|
||||
f >>lpdwBytesSent
|
||||
(make-overlapped) >>lpOverlapped ; inline
|
||||
|
||||
: call-ConnectEx ( ConnectEx -- )
|
||||
ConnectEx-args >tuple*<
|
||||
{
|
||||
[ s>> ]
|
||||
[ name>> ]
|
||||
[ namelen>> ]
|
||||
[ lpSendBuffer>> ]
|
||||
[ dwSendDataLength>> ]
|
||||
[ lpdwBytesSent>> ]
|
||||
[ lpOverlapped>> ]
|
||||
[ ptr>> ]
|
||||
} cleave
|
||||
"int"
|
||||
{ "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
|
||||
"stdcall" alien-indirect drop
|
||||
winsock-error-string [ throw ] when* ;
|
||||
winsock-error-string [ throw ] when* ; inline
|
||||
|
||||
M: object establish-connection ( client-out remote -- )
|
||||
make-sockaddr/size <ConnectEx-args>
|
||||
swap >>port
|
||||
dup port>> handle>> handle>> >>s*
|
||||
dup s*>> get-ConnectEx-ptr >>ptr*
|
||||
dup port>> handle>> handle>> >>s
|
||||
dup s>> get-ConnectEx-ptr >>ptr
|
||||
dup call-ConnectEx
|
||||
wait-for-socket drop ;
|
||||
|
||||
TUPLE: AcceptEx-args port
|
||||
sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
|
||||
dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ;
|
||||
sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
|
||||
dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
|
||||
|
||||
: init-accept-buffer ( addr AcceptEx -- )
|
||||
swap sockaddr-type heap-size 16 +
|
||||
[ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi
|
||||
dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer*
|
||||
drop ;
|
||||
[ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
|
||||
dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
|
||||
drop ; inline
|
||||
|
||||
: <AcceptEx-args> ( server addr -- AcceptEx )
|
||||
AcceptEx-args new
|
||||
2dup init-accept-buffer
|
||||
swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket*
|
||||
over handle>> handle>> >>sListenSocket*
|
||||
swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
|
||||
over handle>> handle>> >>sListenSocket
|
||||
swap >>port
|
||||
0 >>dwReceiveDataLength*
|
||||
f >>lpdwBytesReceived*
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
0 >>dwReceiveDataLength
|
||||
f >>lpdwBytesReceived
|
||||
(make-overlapped) >>lpOverlapped ; inline
|
||||
|
||||
: call-AcceptEx ( AcceptEx -- )
|
||||
AcceptEx-args >tuple*< AcceptEx drop
|
||||
winsock-error-string [ throw ] when* ;
|
||||
{
|
||||
[ sListenSocket>> ]
|
||||
[ sAcceptSocket>> ]
|
||||
[ lpOutputBuffer>> ]
|
||||
[ dwReceiveDataLength>> ]
|
||||
[ dwLocalAddressLength>> ]
|
||||
[ dwRemoteAddressLength>> ]
|
||||
[ lpdwBytesReceived>> ]
|
||||
[ lpOverlapped>> ]
|
||||
} cleave AcceptEx drop
|
||||
winsock-error-string [ throw ] when* ; inline
|
||||
|
||||
: extract-remote-address ( AcceptEx -- sockaddr )
|
||||
{
|
||||
[ lpOutputBuffer*>> ]
|
||||
[ dwReceiveDataLength*>> ]
|
||||
[ dwLocalAddressLength*>> ]
|
||||
[ dwRemoteAddressLength*>> ]
|
||||
[ lpOutputBuffer>> ]
|
||||
[ dwReceiveDataLength>> ]
|
||||
[ dwLocalAddressLength>> ]
|
||||
[ dwRemoteAddressLength>> ]
|
||||
} cleave
|
||||
f <void*>
|
||||
0 <int>
|
||||
f <void*>
|
||||
[ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
|
||||
[ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
|
||||
|
||||
M: object (accept) ( server addr -- handle sockaddr )
|
||||
[
|
||||
|
|
@ -100,39 +117,49 @@ M: object (accept) ( server addr -- handle sockaddr )
|
|||
{
|
||||
[ call-AcceptEx ]
|
||||
[ wait-for-socket drop ]
|
||||
[ sAcceptSocket*>> <win32-socket> ]
|
||||
[ sAcceptSocket>> <win32-socket> ]
|
||||
[ extract-remote-address ]
|
||||
} cleave
|
||||
] with-destructors ;
|
||||
|
||||
TUPLE: WSARecvFrom-args port
|
||||
s* lpBuffers* dwBufferCount* lpNumberOfBytesRecvd*
|
||||
lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ;
|
||||
s lpBuffers dwBufferCount lpNumberOfBytesRecvd
|
||||
lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
|
||||
|
||||
: make-receive-buffer ( -- WSABUF )
|
||||
"WSABUF" malloc-object &free
|
||||
default-buffer-size get over set-WSABUF-len
|
||||
default-buffer-size get malloc &free over set-WSABUF-buf ;
|
||||
default-buffer-size get malloc &free over set-WSABUF-buf ; inline
|
||||
|
||||
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
|
||||
WSARecvFrom-args new
|
||||
swap >>port
|
||||
dup port>> handle>> handle>> >>s*
|
||||
dup port>> handle>> handle>> >>s
|
||||
dup port>> addr>> sockaddr-type heap-size
|
||||
[ malloc &free >>lpFrom* ]
|
||||
[ malloc-int &free >>lpFromLen* ] bi
|
||||
make-receive-buffer >>lpBuffers*
|
||||
1 >>dwBufferCount*
|
||||
0 malloc-int &free >>lpFlags*
|
||||
0 malloc-int &free >>lpNumberOfBytesRecvd*
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
[ malloc &free >>lpFrom ]
|
||||
[ malloc-int &free >>lpFromLen ] bi
|
||||
make-receive-buffer >>lpBuffers
|
||||
1 >>dwBufferCount
|
||||
0 malloc-int &free >>lpFlags
|
||||
0 malloc-int &free >>lpNumberOfBytesRecvd
|
||||
(make-overlapped) >>lpOverlapped ; inline
|
||||
|
||||
: call-WSARecvFrom ( WSARecvFrom -- )
|
||||
WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
|
||||
{
|
||||
[ s>> ]
|
||||
[ lpBuffers>> ]
|
||||
[ dwBufferCount>> ]
|
||||
[ lpNumberOfBytesRecvd>> ]
|
||||
[ lpFlags>> ]
|
||||
[ lpFrom>> ]
|
||||
[ lpFromLen>> ]
|
||||
[ lpOverlapped>> ]
|
||||
[ lpCompletionRoutine>> ]
|
||||
} cleave WSARecvFrom socket-error* ; inline
|
||||
|
||||
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
|
||||
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ]
|
||||
[ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ;
|
||||
[ lpBuffers>> WSABUF-buf swap memory>byte-array ]
|
||||
[ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
|
||||
|
||||
M: winnt (receive) ( datagram -- packet addrspec )
|
||||
[
|
||||
|
|
@ -144,31 +171,41 @@ M: winnt (receive) ( datagram -- packet addrspec )
|
|||
] with-destructors ;
|
||||
|
||||
TUPLE: WSASendTo-args port
|
||||
s* lpBuffers* dwBufferCount* lpNumberOfBytesSent*
|
||||
dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ;
|
||||
s lpBuffers dwBufferCount lpNumberOfBytesSent
|
||||
dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
|
||||
|
||||
: make-send-buffer ( packet -- WSABUF )
|
||||
"WSABUF" malloc-object &free
|
||||
[ >r malloc-byte-array &free r> set-WSABUF-buf ]
|
||||
[ >r length r> set-WSABUF-len ]
|
||||
[ nip ]
|
||||
2tri ;
|
||||
2tri ; inline
|
||||
|
||||
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
|
||||
WSASendTo-args new
|
||||
swap >>port
|
||||
dup port>> handle>> handle>> >>s*
|
||||
dup port>> handle>> handle>> >>s
|
||||
swap make-sockaddr/size
|
||||
>r malloc-byte-array &free
|
||||
r> [ >>lpTo* ] [ >>iToLen* ] bi*
|
||||
swap make-send-buffer >>lpBuffers*
|
||||
1 >>dwBufferCount*
|
||||
0 >>dwFlags*
|
||||
0 <uint> >>lpNumberOfBytesSent*
|
||||
(make-overlapped) >>lpOverlapped* ;
|
||||
r> [ >>lpTo ] [ >>iToLen ] bi*
|
||||
swap make-send-buffer >>lpBuffers
|
||||
1 >>dwBufferCount
|
||||
0 >>dwFlags
|
||||
0 <uint> >>lpNumberOfBytesSent
|
||||
(make-overlapped) >>lpOverlapped ; inline
|
||||
|
||||
: call-WSASendTo ( WSASendTo -- )
|
||||
WSASendTo-args >tuple*< WSASendTo socket-error* ;
|
||||
{
|
||||
[ s>> ]
|
||||
[ lpBuffers>> ]
|
||||
[ dwBufferCount>> ]
|
||||
[ lpNumberOfBytesSent>> ]
|
||||
[ dwFlags>> ]
|
||||
[ lpTo>> ]
|
||||
[ iToLen>> ]
|
||||
[ lpOverlapped>> ]
|
||||
[ lpCompletionRoutine>> ]
|
||||
} cleave WSASendTo socket-error* ; inline
|
||||
|
||||
M: winnt (send) ( packet addrspec datagram -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -136,7 +136,6 @@ IN: tools.deploy.shaker
|
|||
"specializer"
|
||||
"step-into"
|
||||
"step-into?"
|
||||
"superclass"
|
||||
"transform-n"
|
||||
"transform-quot"
|
||||
"tuple-dispatch-generic"
|
||||
|
|
|
|||
|
|
@ -67,9 +67,12 @@ M: button-paint draw-interior
|
|||
M: button-paint draw-boundary
|
||||
button-paint draw-boundary ;
|
||||
|
||||
: align-left ( button -- button )
|
||||
{ 0 1/2 } >>align ; inline
|
||||
|
||||
: roll-button-theme ( button -- button )
|
||||
f black <solid> dup f <button-paint> >>boundary
|
||||
{ 0 1/2 } >>align ; inline
|
||||
align-left ; inline
|
||||
|
||||
: <roll-button> ( label quot -- button )
|
||||
<button> roll-button-theme ;
|
||||
|
|
@ -141,7 +144,8 @@ TUPLE: checkbox < button ;
|
|||
<checkmark> label-on-right checkbox-theme
|
||||
[ model>> toggle-model ]
|
||||
checkbox new-button
|
||||
swap >>model ;
|
||||
swap >>model
|
||||
align-left ;
|
||||
|
||||
M: checkbox model-changed
|
||||
swap model-value over (>>selected?) relayout-1 ;
|
||||
|
|
@ -179,7 +183,8 @@ TUPLE: radio-control < button value ;
|
|||
[ [ value>> ] keep set-control-value ]
|
||||
radio-control new-button
|
||||
swap >>model
|
||||
swap >>value ; inline
|
||||
swap >>value
|
||||
align-left ; inline
|
||||
|
||||
M: radio-control model-changed
|
||||
swap model-value
|
||||
|
|
|
|||
|
|
@ -30,13 +30,13 @@ HELP: motion
|
|||
{ $examples { $code "T{ motion }" } } ;
|
||||
|
||||
HELP: drag
|
||||
{ $class-description "Mouse drag gesture. The " { $link drag-# } " slot is either set to a mouse button number, or " { $link f } " indicating no specific button is expected." } ;
|
||||
{ $class-description "Mouse drag gesture. The " { $snippet "#" } " slot is either set to a mouse button number, or " { $link f } " indicating no specific button is expected." } ;
|
||||
|
||||
HELP: button-up
|
||||
{ $class-description "Mouse button up gesture. Instances have two slots:"
|
||||
{ $list
|
||||
{ { $link button-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
|
||||
{ { $link button-up-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
|
||||
{ { $snippet "mods" } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
|
||||
{ { $snippet "#" } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
|
||||
}
|
||||
}
|
||||
{ $examples { $code "T{ button-up f f 1 }" "T{ button-up }" } } ;
|
||||
|
|
@ -44,8 +44,8 @@ HELP: button-up
|
|||
HELP: button-down
|
||||
{ $class-description "Mouse button down gesture. Instances have two slots:"
|
||||
{ $list
|
||||
{ { $link button-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
|
||||
{ { $link button-down-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
|
||||
{ { $snippet "mods" } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
|
||||
{ { $snippet "#" } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
|
||||
}
|
||||
}
|
||||
{ $examples { $code "T{ button-down f f 1 }" "T{ button-down }" } } ;
|
||||
|
|
@ -109,8 +109,8 @@ HELP: S+
|
|||
HELP: key-down
|
||||
{ $class-description "Key down gesture. Instances have two slots:"
|
||||
{ $list
|
||||
{ { $link key-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
|
||||
{ { $link key-down-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
|
||||
{ { $snippet "mods" } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
|
||||
{ { $snippet "sym" } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
|
||||
}
|
||||
}
|
||||
{ $examples { $code "T{ key-down f { C+ } \"a\" }" "T{ key-down f f \"TAB\" }" } } ;
|
||||
|
|
@ -118,8 +118,8 @@ HELP: key-down
|
|||
HELP: key-up
|
||||
{ $class-description "Key up gesture. Instances have two slots:"
|
||||
{ $list
|
||||
{ { $link key-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
|
||||
{ { $link key-up-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
|
||||
{ { $snippet "mods" } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
|
||||
{ { $snippet "sym" } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
|
||||
}
|
||||
}
|
||||
{ $examples { $code "T{ key-up f { C+ } \"a\" }" "T{ key-up f f \"TAB\" }" } } ;
|
||||
|
|
|
|||
|
|
@ -226,14 +226,14 @@ SYMBOL: drag-timer
|
|||
: send-button-down ( gesture loc world -- )
|
||||
move-hand
|
||||
start-drag-timer
|
||||
dup button-down-#
|
||||
dup #>>
|
||||
dup update-click# hand-buttons get-global push
|
||||
update-clicked
|
||||
button-gesture ;
|
||||
|
||||
: send-button-up ( gesture loc world -- )
|
||||
move-hand
|
||||
dup button-up-# hand-buttons get-global delete
|
||||
dup #>> hand-buttons get-global delete
|
||||
stop-drag-timer
|
||||
button-gesture ;
|
||||
|
||||
|
|
@ -261,21 +261,21 @@ GENERIC: gesture>string ( gesture -- string/f )
|
|||
[ name>> ] map concat >string ;
|
||||
|
||||
M: key-down gesture>string
|
||||
dup key-down-mods modifiers>string
|
||||
swap key-down-sym append ;
|
||||
dup mods>> modifiers>string
|
||||
swap sym>> append ;
|
||||
|
||||
M: button-up gesture>string
|
||||
[
|
||||
dup button-up-mods modifiers>string %
|
||||
dup mods>> modifiers>string %
|
||||
"Click Button" %
|
||||
button-up-# [ " " % # ] when*
|
||||
#>> [ " " % # ] when*
|
||||
] "" make ;
|
||||
|
||||
M: button-down gesture>string
|
||||
[
|
||||
dup button-down-mods modifiers>string %
|
||||
dup mods>> modifiers>string %
|
||||
"Press Button" %
|
||||
button-down-# [ " " % # ] when*
|
||||
#>> [ " " % # ] when*
|
||||
] "" make ;
|
||||
|
||||
M: left-action gesture>string drop "Swipe left" ;
|
||||
|
|
|
|||
|
|
@ -22,11 +22,11 @@ HELP: operation
|
|||
$nl
|
||||
"Operations have the following slots:"
|
||||
{ $list
|
||||
{ { $link operation-predicate } " - a quotation with stack effect " { $snippet "( obj -- ? )" } }
|
||||
{ { $link operation-command } " - a " { $link word } }
|
||||
{ { $link operation-translator } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
|
||||
{ { $link operation-hook } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
|
||||
{ { $link operation-listener? } " - a boolean" }
|
||||
{ { $snippet "predicate" } " - a quotation with stack effect " { $snippet "( obj -- ? )" } }
|
||||
{ { $snippet "command" } " - a " { $link word } }
|
||||
{ { $snippet "translator" } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
|
||||
{ { $snippet "hook" } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
|
||||
{ { $snippet "listener?" } " - a boolean" }
|
||||
} } ;
|
||||
|
||||
HELP: operation-gesture
|
||||
|
|
@ -38,7 +38,7 @@ HELP: operations
|
|||
|
||||
HELP: object-operations
|
||||
{ $values { "obj" object } { "operations" "a sequence of " { $link operation } " instances" } }
|
||||
{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $link operation-predicate } " quotation in turn." } ;
|
||||
{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $snippet "predicate" } " quotation in turn." } ;
|
||||
|
||||
HELP: primary-operation
|
||||
{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
|
||||
|
|
|
|||
|
|
@ -19,34 +19,34 @@ TUPLE: operation predicate command translator hook listener? ;
|
|||
swap >>predicate ;
|
||||
|
||||
PREDICATE: listener-operation < operation
|
||||
dup operation-command listener-command?
|
||||
swap operation-listener? or ;
|
||||
dup command>> listener-command?
|
||||
swap listener?>> or ;
|
||||
|
||||
M: operation command-name
|
||||
operation-command command-name ;
|
||||
command>> command-name ;
|
||||
|
||||
M: operation command-description
|
||||
operation-command command-description ;
|
||||
command>> command-description ;
|
||||
|
||||
M: operation command-word operation-command command-word ;
|
||||
M: operation command-word command>> command-word ;
|
||||
|
||||
: operation-gesture ( operation -- gesture )
|
||||
operation-command +keyboard+ word-prop ;
|
||||
command>> +keyboard+ word-prop ;
|
||||
|
||||
SYMBOL: operations
|
||||
|
||||
: object-operations ( obj -- operations )
|
||||
operations get [ operation-predicate call ] with filter ;
|
||||
operations get [ predicate>> call ] with filter ;
|
||||
|
||||
: find-operation ( obj quot -- command )
|
||||
>r object-operations r> find-last nip ; inline
|
||||
|
||||
: primary-operation ( obj -- operation )
|
||||
[ operation-command +primary+ word-prop ] find-operation ;
|
||||
[ command>> +primary+ word-prop ] find-operation ;
|
||||
|
||||
: secondary-operation ( obj -- operation )
|
||||
dup
|
||||
[ operation-command +secondary+ word-prop ] find-operation
|
||||
[ command>> +secondary+ word-prop ] find-operation
|
||||
[ ] [ primary-operation ] ?if ;
|
||||
|
||||
: default-flags ( -- assoc )
|
||||
|
|
@ -59,9 +59,9 @@ SYMBOL: operations
|
|||
|
||||
: modify-operation ( hook translator operation -- operation )
|
||||
clone
|
||||
tuck set-operation-translator
|
||||
tuck set-operation-hook
|
||||
t over set-operation-listener? ;
|
||||
tuck (>>translator)
|
||||
tuck (>>hook)
|
||||
t over (>>listener?) ;
|
||||
|
||||
: modify-operations ( operations hook translator -- operations )
|
||||
rot [ >r 2dup r> modify-operation ] map 2nip ;
|
||||
|
|
@ -76,9 +76,9 @@ SYMBOL: operations
|
|||
: operation-quot ( target command -- quot )
|
||||
[
|
||||
swap literalize ,
|
||||
dup operation-translator %
|
||||
operation-command ,
|
||||
dup translator>> %
|
||||
command>> ,
|
||||
] [ ] make ;
|
||||
|
||||
M: operation invoke-command ( target command -- )
|
||||
[ operation-hook call ] keep operation-quot call ;
|
||||
[ hook>> call ] keep operation-quot call ;
|
||||
|
|
|
|||
|
|
@ -38,16 +38,16 @@ HELP: draw-boundary
|
|||
{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ;
|
||||
|
||||
HELP: solid
|
||||
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $link solid-color } " slot stores a color specifier." } ;
|
||||
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $snippet "color" } " slot stores a color specifier." } ;
|
||||
|
||||
HELP: gradient
|
||||
{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $link gradient-colors } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." } ;
|
||||
{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $snippet "colors" } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." } ;
|
||||
|
||||
HELP: polygon
|
||||
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
|
||||
{ $list
|
||||
{ { $link polygon-color } " - a color specifier" }
|
||||
{ { $link polygon-points } " - a sequence of points" }
|
||||
{ { $snippet "color" } " - a color specifier" }
|
||||
{ { $snippet "points" } " - a sequence of points" }
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ C: <solid> solid
|
|||
|
||||
! Solid pen
|
||||
: (solid) ( gadget paint -- loc dim )
|
||||
solid-color set-color rect-dim >r origin get dup r> v+ ;
|
||||
color>> set-color rect-dim >r origin get dup r> v+ ;
|
||||
|
||||
M: solid draw-interior (solid) gl-fill-rect ;
|
||||
|
||||
|
|
@ -109,7 +109,7 @@ C: <gradient> gradient
|
|||
M: gradient draw-interior
|
||||
origin get [
|
||||
over orientation>>
|
||||
swap gradient-colors
|
||||
swap colors>>
|
||||
rot rect-dim
|
||||
gl-gradient
|
||||
] with-translation ;
|
||||
|
|
@ -121,7 +121,7 @@ C: <polygon> polygon
|
|||
|
||||
: draw-polygon ( polygon quot -- )
|
||||
origin get [
|
||||
>r dup polygon-color set-color polygon-points r> call
|
||||
>r dup color>> set-color points>> r> call
|
||||
] with-translation ; inline
|
||||
|
||||
M: polygon draw-boundary
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ TUPLE: debugger < track restarts ;
|
|||
-rot <restart-list> >>restarts
|
||||
dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
|
||||
|
||||
M: debugger focusable-child* debugger-restarts ;
|
||||
M: debugger focusable-child* restarts>> ;
|
||||
|
||||
: debugger-window ( error -- )
|
||||
#! No restarts for the debugger window
|
||||
|
|
|
|||
|
|
@ -65,13 +65,13 @@ TUPLE: deploy-gadget < pack vocab settings ;
|
|||
[ deploy-gadget? ] find-parent ;
|
||||
|
||||
: find-deploy-vocab ( gadget -- vocab )
|
||||
find-deploy-gadget deploy-gadget-vocab ;
|
||||
find-deploy-gadget vocab>> ;
|
||||
|
||||
: find-deploy-config ( gadget -- config )
|
||||
find-deploy-vocab deploy-config ;
|
||||
|
||||
: find-deploy-settings ( gadget -- settings )
|
||||
find-deploy-gadget deploy-gadget-settings ;
|
||||
find-deploy-gadget settings>> ;
|
||||
|
||||
: com-revert ( gadget -- )
|
||||
dup find-deploy-config
|
||||
|
|
|
|||
|
|
@ -47,4 +47,4 @@ inspector-gadget "multi-touch" f {
|
|||
} define-command-map
|
||||
|
||||
M: inspector-gadget tool-scroller
|
||||
inspector-gadget-pane find-scroller ;
|
||||
pane>> find-scroller ;
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ M: interactor model-changed
|
|||
] with-output-stream* ;
|
||||
|
||||
: add-interactor-history ( str interactor -- )
|
||||
over empty? [ 2drop ] [ interactor-history adjoin ] if ;
|
||||
over empty? [ 2drop ] [ history>> adjoin ] if ;
|
||||
|
||||
: interactor-continue ( obj interactor -- )
|
||||
mailbox>> mailbox-put ;
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ M: listener-command invoke-command ( target command -- )
|
|||
command-quot call-listener ;
|
||||
|
||||
M: listener-operation invoke-command ( target command -- )
|
||||
[ operation-hook call ] keep operation-quot call-listener ;
|
||||
[ hook>> call ] keep operation-quot call-listener ;
|
||||
|
||||
: eval-listener ( string -- )
|
||||
get-workspace
|
||||
|
|
@ -110,7 +110,7 @@ M: engine-word word-completion-string
|
|||
] [ 2drop ] if ;
|
||||
|
||||
: insert-word ( word -- )
|
||||
get-workspace workspace-listener input>>
|
||||
get-workspace listener>> input>>
|
||||
[ >r word-completion-string r> user-input ]
|
||||
[ interactor-use use-if-necessary ]
|
||||
2bi ;
|
||||
|
|
@ -131,10 +131,10 @@ TUPLE: stack-display < track ;
|
|||
1 track-add ;
|
||||
|
||||
M: stack-display tool-scroller
|
||||
find-workspace workspace-listener tool-scroller ;
|
||||
find-workspace listener>> tool-scroller ;
|
||||
|
||||
: ui-listener-hook ( listener -- )
|
||||
>r datastack r> listener-gadget-stack set-model ;
|
||||
>r datastack r> stack>> set-model ;
|
||||
|
||||
: ui-error-hook ( error listener -- )
|
||||
find-workspace debugger-popup ;
|
||||
|
|
@ -168,7 +168,7 @@ M: stack-display tool-scroller
|
|||
} cleave ;
|
||||
|
||||
: init-listener ( listener -- )
|
||||
f <model> swap set-listener-gadget-stack ;
|
||||
f <model> swap (>>stack) ;
|
||||
|
||||
: <listener-gadget> ( -- gadget )
|
||||
{ 0 1 } listener-gadget new-track
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ TUPLE: profiler-gadget < track pane ;
|
|||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
: with-profiler-pane ( gadget quot -- )
|
||||
>r profiler-gadget-pane r> with-pane ;
|
||||
>r pane>> r> with-pane ;
|
||||
|
||||
: com-full-profile ( gadget -- )
|
||||
[ profile. ] with-profiler-pane ;
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: ui.tools.search
|
|||
TUPLE: live-search < track field list ;
|
||||
|
||||
: search-value ( live-search -- value )
|
||||
live-search-list list-value ;
|
||||
list>> list-value ;
|
||||
|
||||
: search-gesture ( gesture live-search -- operation/f )
|
||||
search-value object-operations
|
||||
|
|
@ -32,7 +32,7 @@ M: live-search handle-gesture ( gesture live-search -- ? )
|
|||
[ live-search? ] find-parent ;
|
||||
|
||||
: find-search-list ( gadget -- list )
|
||||
find-live-search live-search-list ;
|
||||
find-live-search list>> ;
|
||||
|
||||
TUPLE: search-field < editor ;
|
||||
|
||||
|
|
@ -70,12 +70,12 @@ search-field H{
|
|||
over field>> set-editor-string
|
||||
dup field>> end-of-document ;
|
||||
|
||||
M: live-search focusable-child* live-search-field ;
|
||||
M: live-search focusable-child* field>> ;
|
||||
|
||||
M: live-search pref-dim* drop { 400 200 } ;
|
||||
|
||||
: current-word ( workspace -- string )
|
||||
workspace-listener listener-gadget-input selected-word ;
|
||||
listener>> input>> selected-word ;
|
||||
|
||||
: definition-candidates ( words -- candidates )
|
||||
[ dup synopsis >lower ] { } map>assoc sort-values ;
|
||||
|
|
@ -149,10 +149,10 @@ M: live-search pref-dim* drop { 400 200 } ;
|
|||
f [ string>> ] <live-search> ;
|
||||
|
||||
: listener-history ( listener -- seq )
|
||||
listener-gadget-input interactor-history <reversed> ;
|
||||
input>> history>> <reversed> ;
|
||||
|
||||
: com-history ( workspace -- )
|
||||
"" over workspace-listener listener-history <history-search>
|
||||
"" over listener>> listener-history <history-search>
|
||||
"History search" show-titled-popup ;
|
||||
|
||||
workspace "toolbar" f {
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ IN: ui.tools
|
|||
|
||||
M: workspace model-changed
|
||||
nip
|
||||
dup workspace-listener listener-gadget-output scroll>bottom
|
||||
dup listener>> output>> scroll>bottom
|
||||
dup resize-workspace
|
||||
request-focus ;
|
||||
|
||||
|
|
|
|||
|
|
@ -84,7 +84,7 @@ walker-gadget "toolbar" f {
|
|||
: walker-for-thread? ( thread gadget -- ? )
|
||||
{
|
||||
{ [ dup walker-gadget? not ] [ 2drop f ] }
|
||||
{ [ dup walker-gadget-closing? ] [ 2drop f ] }
|
||||
{ [ dup closing?>> ] [ 2drop f ] }
|
||||
[ thread>> eq? ]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ M: gadget tool-scroller drop f ;
|
|||
book>> children>> [ class eq? ] with find ;
|
||||
|
||||
: show-tool ( class workspace -- tool )
|
||||
[ find-tool swap ] keep workspace-book model>>
|
||||
[ find-tool swap ] keep book>> model>>
|
||||
set-model ;
|
||||
|
||||
: select-tool ( workspace class -- ) swap show-tool drop ;
|
||||
|
|
@ -81,10 +81,10 @@ SYMBOL: workspace-dim
|
|||
M: workspace pref-dim* drop workspace-dim get ;
|
||||
|
||||
M: workspace focusable-child*
|
||||
dup workspace-popup [ ] [ workspace-listener ] ?if ;
|
||||
dup popup>> [ ] [ listener>> ] ?if ;
|
||||
|
||||
: workspace-page ( workspace -- gadget )
|
||||
workspace-book current-page ;
|
||||
book>> current-page ;
|
||||
|
||||
M: workspace tool-scroller ( workspace -- scroller )
|
||||
workspace-page tool-scroller ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,11 @@
|
|||
IN: ui.traverse.tests
|
||||
USING: ui.gadgets ui.gadgets.labels namespaces sequences kernel
|
||||
|
||||
USING: accessors ui.gadgets ui.gadgets.labels namespaces sequences kernel
|
||||
math arrays tools.test io ui.gadgets.panes ui.traverse
|
||||
definitions compiler.units ;
|
||||
|
||||
M: array gadget-children ;
|
||||
IN: ui.traverse.tests
|
||||
|
||||
M: array children>> ;
|
||||
|
||||
GENERIC: (flatten-tree) ( node -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -105,6 +105,10 @@ M: method-body crossref?
|
|||
drop [ <method> dup ] 2keep reveal-method
|
||||
] if ;
|
||||
|
||||
PREDICATE: default-method < word "default" word-prop ;
|
||||
|
||||
M: default-method irrelevant? drop t ;
|
||||
|
||||
: <default-method> ( generic combination -- method )
|
||||
[ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
|
||||
[ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
|
||||
|
|
@ -137,7 +141,7 @@ M: method-body definer
|
|||
M: method-body forget*
|
||||
dup "forgotten" word-prop [ drop ] [
|
||||
[
|
||||
dup "default" word-prop [ drop ] [
|
||||
dup default-method? [ drop ] [
|
||||
[
|
||||
[ "method-class" word-prop ]
|
||||
[ "method-generic" word-prop ] bi
|
||||
|
|
|
|||
|
|
@ -26,10 +26,6 @@ ERROR: no-method object generic ;
|
|||
: error-method ( word -- quot )
|
||||
picker swap [ no-method ] curry append ;
|
||||
|
||||
: default-method ( word -- pair )
|
||||
"default-method" word-prop
|
||||
object bootstrap-word swap 2array ;
|
||||
|
||||
: push-method ( method specializer atomic assoc -- )
|
||||
[
|
||||
[ H{ } clone <predicate-dispatch-engine> ] unless*
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
USING: help.syntax help.markup kernel prettyprint sequences ;
|
||||
IN: classes.tuple.lib
|
||||
|
||||
HELP: >tuple<
|
||||
{ $values { "class" "a tuple class" } }
|
||||
{ $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." }
|
||||
{ $example
|
||||
"USING: kernel prettyprint classes.tuple.lib ;"
|
||||
"IN: scratchpad"
|
||||
"TUPLE: foo a b c ;"
|
||||
"1 2 3 \\ foo boa \\ foo >tuple< .s"
|
||||
"1\n2\n3"
|
||||
}
|
||||
{ $notes "Words using " { $snippet ">tuple<" } " may be compiled." }
|
||||
{ $see-also >tuple*< } ;
|
||||
|
||||
HELP: >tuple*<
|
||||
{ $values { "class" "a tuple class" } }
|
||||
{ $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." }
|
||||
{ $example
|
||||
"USING: kernel prettyprint classes.tuple.lib ;"
|
||||
"IN: scratchpad"
|
||||
"TUPLE: foo a bb* ccc dddd* ;"
|
||||
"1 2 3 4 \\ foo boa \\ foo >tuple*< .s"
|
||||
"2\n4"
|
||||
}
|
||||
{ $notes "Words using " { $snippet ">tuple*<" } " may be compiled." }
|
||||
{ $see-also >tuple< } ;
|
||||
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
USING: kernel tools.test classes.tuple.lib ;
|
||||
IN: classes.tuple.lib.tests
|
||||
|
||||
TUPLE: foo a b* c d* e f* ;
|
||||
|
||||
[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple< ] unit-test
|
||||
[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple*< ] unit-test
|
||||
|
||||
|
|
@ -1,18 +0,0 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel macros sequences slots words classes.tuple
|
||||
quotations combinators accessors ;
|
||||
IN: classes.tuple.lib
|
||||
|
||||
: reader-slots ( seq -- quot )
|
||||
[ reader>> 1quotation ] map [ cleave ] curry ;
|
||||
|
||||
MACRO: >tuple< ( class -- )
|
||||
all-slots rest-slice reader-slots ;
|
||||
|
||||
MACRO: >tuple*< ( class -- )
|
||||
all-slots
|
||||
[ slot-spec-name "*" tail? ] filter
|
||||
reader-slots ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,83 @@
|
|||
|
||||
USING: kernel sequences sets combinators.cleave
|
||||
obj obj.view obj.util obj.print ;
|
||||
|
||||
IN: obj.examples.todo
|
||||
|
||||
SYM: person types adjoin
|
||||
SYM: todo types adjoin
|
||||
|
||||
SYM: owners properties adjoin
|
||||
SYM: eta properties adjoin
|
||||
SYM: notes properties adjoin
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYM: slava { type person } define-object
|
||||
SYM: doug { type person } define-object
|
||||
SYM: ed { type person } define-object
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYM: compiler-bugs
|
||||
{
|
||||
type todo
|
||||
owners { slava }
|
||||
notes {
|
||||
"Investitage FEP on Terrorist"
|
||||
"Problem with cutler in VirtualBox?"
|
||||
}
|
||||
}
|
||||
define-object
|
||||
|
||||
SYM: remove-old-accessors-from-core
|
||||
{
|
||||
type todo
|
||||
owners { slava }
|
||||
}
|
||||
define-object
|
||||
|
||||
SYM: move-db-and-web-framework-to-basis
|
||||
{
|
||||
type todo
|
||||
owners { slava }
|
||||
}
|
||||
define-object
|
||||
|
||||
SYM: remove-old-accessors-from-basis
|
||||
{
|
||||
type todo
|
||||
owners { doug ed }
|
||||
}
|
||||
define-object
|
||||
|
||||
SYM: blas-on-bsd
|
||||
{
|
||||
type todo
|
||||
owners { slava doug }
|
||||
}
|
||||
define-object
|
||||
|
||||
SYM: multi-methods-backend
|
||||
{
|
||||
type todo
|
||||
owners { slava }
|
||||
}
|
||||
define-object
|
||||
|
||||
SYM: update-core-for-multi-methods { type todo owners { slava } } define-object
|
||||
SYM: update-basis-for-multi-methods { type todo } define-object
|
||||
SYM: update-extra-for-multi-methods { type todo } define-object
|
||||
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: todo-list ( -- )
|
||||
objects [ type -> todo = ] filter
|
||||
[ { [ self -> ] [ owners -> ] [ eta -> ] } 1arr ]
|
||||
map
|
||||
{ "ITEM" "OWNERS" "ETA" } prefix
|
||||
print-table ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -40,7 +40,13 @@ PREDICATE: obj-list < word \ objects = ;
|
|||
|
||||
M: obj-list article-title ( objects -- title ) drop "Objects" ;
|
||||
|
||||
! M: obj-list article-content ( objects -- title )
|
||||
! execute
|
||||
! [ [ type -> ] [ ] bi 2array ] map
|
||||
! { $tab , } bake ;
|
||||
|
||||
M: obj-list article-content ( objects -- title )
|
||||
execute
|
||||
drop
|
||||
objects
|
||||
[ [ type -> ] [ ] bi 2array ] map
|
||||
{ $tab , } bake ;
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-random? t }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-name "Spheres" }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-threads? t }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-ui? t }
|
||||
{ deploy-c-types? f }
|
||||
}
|
||||
Loading…
Reference in New Issue