diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 2c23ae95c1..8ee104d16e 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -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 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" + } +} ; diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index d9284573c4..ff002bb16c 100755 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -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 ; +: instant ( -- duration ) 0 0 0 0 0 0 ; : 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 ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor old mode 100644 new mode 100755 index 9d2b43c1df..f2a2255949 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -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 ) diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor old mode 100644 new mode 100755 index 3ea9139e5f..9ebf064f79 --- a/basis/compiler/tree/dead-code/simple/simple.factor +++ b/basis/compiler/tree/dead-code/simple/simple.factor @@ -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 ; diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 14d3420a68..b12dcaa807 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -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 -- ) diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index 699b2d398a..f53bdee9c7 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -16,7 +16,7 @@ IN: help.topics.tests SYMBOL: foo -[ ] [ { "test" "a" } "Test A" { { $subsection foo } }
add-article ] unit-test +[ ] [ "Test A" { { $subsection foo } }
{ "test" "a" } add-article ] unit-test ! Test article location recording diff --git a/basis/io/windows/launcher/launcher.factor b/basis/io/windows/launcher/launcher.factor index 9442fa9a72..ed9b53675b 100755 --- a/basis/io/windows/launcher/launcher.factor +++ b/basis/io/windows/launcher/launcher.factor @@ -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 [ diff --git a/basis/io/windows/nt/backend/backend.factor b/basis/io/windows/nt/backend/backend.factor index e9df2ddab9..7fbc1dbcf9 100755 --- a/basis/io/windows/nt/backend/backend.factor +++ b/basis/io/windows/nt/backend/backend.factor @@ -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 diff --git a/basis/io/windows/nt/sockets/sockets.factor b/basis/io/windows/nt/sockets/sockets.factor index a31c41942f..41c5e88f5f 100755 --- a/basis/io/windows/nt/sockets/sockets.factor +++ b/basis/io/windows/nt/sockets/sockets.factor @@ -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 : ( 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 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 : ( 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 0 f - [ 0 GetAcceptExSockaddrs ] keep *void* ; + [ 0 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*>> ] + [ sAcceptSocket>> ] [ 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 : ( 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 : ( 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 >>lpNumberOfBytesSent* - (make-overlapped) >>lpOverlapped* ; + r> [ >>lpTo ] [ >>iToLen ] bi* + swap make-send-buffer >>lpBuffers + 1 >>dwBufferCount + 0 >>dwFlags + 0 >>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 -- ) [ diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 5e888cd871..36fe015611 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -136,7 +136,6 @@ IN: tools.deploy.shaker "specializer" "step-into" "step-into?" - "superclass" "transform-n" "transform-quot" "tuple-dispatch-generic" diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index b5e8e8a1e1..a079781d69 100755 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -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 dup f >>boundary - { 0 1/2 } >>align ; inline + align-left ; inline : ( label quot -- button )