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

Merge git://factorcode.org/git/factor

release
Doug Coleman 2007-11-12 09:33:08 -06:00
parent ee64716368 9ebd234e98
commit 537563eade
14 changed files with 301 additions and 191 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
core/flow-chart/flow-chart.factor Normal file
View File

@ -0,0 +1,74 @@
USING: kernel words math inference.dataflow sequences
optimizer.def-use combinators.private namespaces arrays
math.parser assocs prettyprint io strings inference hashtables ;
IN: flow-chart
GENERIC: flow-chart* ( n word -- value nodes )
M: word flow-chart*
2drop f f ;
M: compound flow-chart*
word-def swap 1+ [ drop <computed> ] map
[ dataflow-with compute-def-use ] keep
first dup used-by prune [ t eq? not ] subset ;
GENERIC: node-word ( node -- word )
M: #call node-word node-param ;
M: #if node-word drop \ if ;
M: #dispatch node-word drop \ dispatch ;
DEFER: flow-chart
: flow-chart-node ( value node -- )
[ node-in-d <reversed> index ] keep
node-word flow-chart , ;
SYMBOL: pruned
SYMBOL: nesting
SYMBOL: max-nesting
2 max-nesting set
: flow-chart ( n word -- seq )
[
2dup 2array ,
nesting dup inc get max-nesting get > [
2drop pruned ,
] [
flow-chart* dup length 5 > [
2drop pruned ,
] [
[ flow-chart-node ] curry* each
] if
] if
] { } make ;
: th ( n -- )
dup number>string write
100 mod dup 20 > [ 10 mod ] when
H{ { 1 "st" } { 2 "nd" } { 3 "rd" } } at "th" or write ;
: chart-heading. ( pair -- )
first2 >r 1+ th " argument to " write r> . ;
GENERIC# show-chart 1 ( seq n -- )
: indent CHAR: \s <string> write ;
M: sequence show-chart
dup indent
>r unclip chart-heading. r>
2 + [ show-chart ] curry each ;
M: word show-chart
dup indent
"... pruned" print ;
: flow-chart. ( n word -- )
flow-chart 2 show-chart ;

66
core/io/files/files.factor
View File

@ -19,17 +19,17 @@ HOOK: make-directory io-backend ( path -- )
HOOK: delete-directory io-backend ( path -- )
: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
HOOK: root-directory? io-backend ( path -- ? )
M: object root-directory? ( path -- ? ) "/" = ;
M: object root-directory? ( path -- ? ) path-separator? ;
! Words for accessing filesystem meta-data.
: path-separator? ( ch -- ? )
"/\\" member? ;
: trim-path-separators ( str -- newstr )
[ path-separator? ] right-trim ;
: path+ ( str1 str2 -- str )
>r [ path-separator? ] right-trim "/" r>
>r trim-path-separators "/" r>
[ path-separator? ] left-trim 3append ;
: stat ( path -- directory? permissions length modified )
@ -39,12 +39,15 @@ M: object root-directory? ( path -- ? ) "/" = ;
: directory? ( path -- ? ) stat 3drop ;
: special-directory? ( name -- ? )
{ "." ".." } member? ;
: fixup-directory ( path seq -- newseq )
[
dup string?
[ tuck path+ directory? 2array ] [ nip ] if
] curry* map
[ first { "." ".." } member? not ] subset ;
[ first special-directory? not ] subset ;
: directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ;
@ -62,17 +65,19 @@ TUPLE: no-parent-directory path ;
\ no-parent-directory construct-boa throw ;
: parent-directory ( path -- parent )
{
{ [ dup root-directory? ] [ ] }
{ [ dup "/\\" split ".." over member? "." rot member? or ]
[ no-parent-directory ] }
{ [ t ] [ dup last-path-separator
[ 1+ head ] [ 2drop "." ] if ] }
} cond ;
trim-path-separators
dup empty? [ drop "/" ] [
dup root-directory? [ ] [
dup last-path-separator drop [
1+ cut
special-directory?
[ no-parent-directory ] when
] when*
] if
] if ;
: file-name ( path -- string )
dup last-path-separator
[ 1+ tail ] [ drop ] if ;
dup last-path-separator [ 1+ tail ] [ drop ] if ;
: resource-path ( path -- newpath )
\ resource-path get [ image parent-directory ] unless*
@ -82,8 +87,7 @@ TUPLE: no-parent-directory path ;
"resource:" ?head [ resource-path ] when ;
: make-directories ( path -- )
normalize-pathname
{
normalize-pathname trim-path-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
@ -94,19 +98,6 @@ TUPLE: no-parent-directory path ;
] }
} cond drop ;
TUPLE: pathname string ;
C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;
: home ( -- dir )
{
{ [ winnt? ] [ "USERPROFILE" os-env ] }
{ [ wince? ] [ "" resource-path ] }
{ [ unix? ] [ "HOME" os-env ] }
} cond ;
: copy-file ( from to -- )
dup parent-directory make-directories
<file-writer> [
@ -121,3 +112,16 @@ M: pathname <=> [ pathname-string ] compare ;
>r dup directory swap r> [
>r >r first r> over path+ r> rot path+ copy-file
] 2curry each ;
: home ( -- dir )
{
{ [ winnt? ] [ "USERPROFILE" os-env ] }
{ [ wince? ] [ "" resource-path ] }
{ [ unix? ] [ "HOME" os-env ] }
} cond ;
TUPLE: pathname string ;
C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;

2
core/vocabs/loader/loader.factor
View File

@ -145,7 +145,7 @@ SYMBOL: load-help?
: update-roots ( vocabs -- )
[ dup find-vocab-root swap vocab set-vocab-root ] each ;
: to-refresh ( prefix -- seq )
: to-refresh ( prefix -- modified-sources modified-docs )
child-vocabs
dup update-roots
dup modified-sources swap modified-docs ;

5
extra/io/server/server.factor Normal file → Executable file
View File

@ -80,7 +80,8 @@ SYMBOL: log-stream
: datagram-loop ( quot datagram -- )
[
[ receive dup log-datagram >r swap call r> ] keep send
[ receive dup log-datagram >r swap call r> ] keep
pick [ send ] [ 3drop ] keep
] 2keep datagram-loop ; inline
: spawn-datagrams ( quot addrspec -- )
@ -91,4 +92,4 @@ SYMBOL: log-stream
: with-datagrams ( seq service quot -- )
[
[ swap spawn-datagrams ] curry concurrency:parallel-each
] with-logging ; inline
] curry with-logging ; inline

3
extra/io/unix/files/files.factor Normal file → Executable file
View File

@ -4,9 +4,6 @@ USING: io.backend io.nonblocking io.unix.backend io.files io
unix kernel math continuations ;
IN: io.unix.files
M: unix-io root-directory? ( path -- ? )
"/" = ;
: open-read ( path -- fd )
O_RDONLY file-mode open dup io-error ;

25
extra/io/unix/launcher/launcher.factor
View File

@ -1,36 +1,13 @@
USING: io io.launcher io.unix.backend io.nonblocking
sequences kernel namespaces math system alien.c-types
debugger continuations combinators.lib threads ;
debugger continuations ;
IN: io.unix.launcher
! Search unix first
USE: unix
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Factor friendly versions of the exec functions
: >argv ( seq -- alien ) [ malloc-char-string ] map f add >c-void*-array ;
: execv* ( pathname argv -- int ) [ malloc-char-string ] [ >argv ] bi* execv ;
: execvp* ( filename argv -- int ) [ malloc-char-string ] [ >argv ] bi* execvp ;
: execve* ( pathname argv envp -- int )
[ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Wait for a pid to finish without freezing up all the Factor threads.
! Need to find a less kludgy way to do this.
: wait-for-pid ( pid -- )
dup "int" <c-object> WNOHANG waitpid
0 = [ 100 sleep wait-for-pid ] [ drop ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: with-fork ( child parent -- pid )
fork [ zero? -rot if ] keep ; inline

153
extra/io/windows/ce/sockets/sockets.factor
View File

@ -8,89 +8,16 @@ IN: io.windows.ce
M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
TUPLE: WSAArgs
s
lpBuffers
dwBufferCount
lpNumberOfBytesRet
lpFlags
lpOverlapped
lpCompletionRoutine ;
C: <WSAArgs> WSAArgs
: make-WSAArgs ( port -- <WSARecv> )
[ port-handle win32-file-handle ] keep
1 "DWORD" <c-object> f f f <WSAArgs> ;
: setup-WSARecv ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
[ WSAArgs-s ] keep
[
WSAArgs-lpBuffers [ buffer-capacity ] keep
buffer-end
"WSABUF" <c-object>
[ windows.winsock:set-WSABUF-buf ] keep
[ windows.winsock:set-WSABUF-len ] keep
] keep
[ WSAArgs-dwBufferCount ] keep
[ WSAArgs-lpNumberOfBytesRet ] keep
[ WSAArgs-lpFlags ] keep
[ WSAArgs-lpOverlapped ] keep
WSAArgs-lpCompletionRoutine ;
! M: win32-socket wince-read ( port port-handle -- )
! drop dup make-WSAArgs dup setup-WSARecv WSARecv zero? [
! drop port-errored
! ] [
! WSAArgs-lpNumberOfBytesRet *uint dup zero? [
! drop
! t swap set-port-eof?
! ] [
! swap n>buffer
! ] if
! ] if ;
M: win32-socket wince-read ( port port-handle -- )
win32-file-handle over buffer-end pick buffer-capacity 0
windows.winsock:recv
dup windows.winsock:SOCKET_ERROR = [
drop port-errored
] [
dup zero? [
drop
t swap set-port-eof?
] [
swap n>buffer
] if
dup zero?
[ drop t swap set-port-eof? ] [ swap n>buffer ] if
] if ;
: setup-WSASend ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
[ WSAArgs-s ] keep
[
WSAArgs-lpBuffers [ buffer-length ] keep
buffer@
"WSABUF" <c-object>
[ windows.winsock:set-WSABUF-buf ] keep
[ windows.winsock:set-WSABUF-len ] keep
] keep
[ WSAArgs-dwBufferCount ] keep
[ WSAArgs-lpNumberOfBytesRet ] keep
[ WSAArgs-lpFlags ] keep
[ WSAArgs-lpOverlapped ] keep
WSAArgs-lpCompletionRoutine ;
! M: win32-socket wince-write ( port port-handle -- )
! drop dup make-WSAArgs dup setup-WSASend WSASend zero? [
! drop port-errored
! ] [
! FileArgs-lpNumberOfBytesRet *uint ! *DWORD
! over delegate [ buffer-consume ] keep
! buffer-length 0 > [
! flush-output
! ] [
! drop
! ] if
! ] if ;
M: win32-socket wince-write ( port port-handle -- )
win32-file-handle over buffer@ pick buffer-length 0
windows.winsock:send
@ -100,8 +27,9 @@ M: win32-socket wince-write ( port port-handle -- )
: do-connect ( addrspec -- socket )
[ tcp-socket dup ] keep
make-sockaddr/size
f f f f windows.winsock:WSAConnect zero?
[ windows.winsock:winsock-error ] unless ;
f f f f
windows.winsock:WSAConnect
windows.winsock:winsock-error!=0/f ;
M: windows-ce-io (client) ( addrspec -- duplex-stream )
do-connect <win32-socket> dup handle>duplex-stream ;
@ -121,7 +49,8 @@ M: windows-ce-io accept ( server -- client )
swap server-port-addr sockaddr-type heap-size
dup <byte-array> [
swap <int> f 0
windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET =
windows.winsock:WSAAccept
dup windows.winsock:INVALID_SOCKET =
[ windows.winsock:winsock-error ] when
] keep
] keep server-port-addr parse-sockaddr swap
@ -132,39 +61,55 @@ M: windows-ce-io <datagram> ( addrspec -- datagram )
windows.winsock:SOCK_DGRAM server-fd <win32-socket> f <port>
] keep <datagram-port> ;
: packet-size 65536 ; inline
: receive-buffer ( -- buf )
\ receive-buffer get-global expired? [
packet-size malloc \ receive-buffer set-global
] when
\ receive-buffer get-global ;
: make-WSABUF ( len buf -- ptr )
"WSABUF" <c-object>
[ windows.winsock:set-WSABUF-buf ] keep
[ windows.winsock:set-WSABUF-len ] keep ;
: receive-WSABUF ( -- buf )
packet-size receive-buffer make-WSABUF ;
: packet-data ( len -- byte-array )
receive-buffer swap memory>string >byte-array ;
packet-size <byte-array> receive-buffer set-global
M: windows-ce-io receive ( datagram -- packet addrspec )
dup check-datagram-port
[
port-handle win32-file-handle
"WSABUF" <c-object>
default-buffer-size get over windows.winsock:set-WSABUF-len
default-buffer-size get <byte-array> over windows.winsock:set-WSABUF-buf
[
1
0 <uint> [
0 <uint>
64 "char" <c-array> [
64 <int>
f
f
windows.winsock:WSARecvFrom zero?
[ windows.winsock:winsock-error ] unless
] keep
] keep *uint
] keep
] keep
! sockaddr count buf datagram
>r windows.winsock:WSABUF-buf swap memory>string swap r>
datagram-port-addr parse-sockaddr ;
receive-WSABUF
1
0 <uint> [
0 <uint>
64 "char" <c-array> [
64 <int>
f
f
windows.winsock:WSARecvFrom
windows.winsock:winsock-error!=0/f
] keep
] keep *uint packet-data swap
] keep datagram-port-addr parse-sockaddr ;
: send-WSABUF ( byte-array -- ptr )
dup length packet-size > [ "UDP packet too long" throw ] when
dup length receive-buffer rot pick memcpy
receive-buffer make-WSABUF ;
M: windows-ce-io send ( packet addrspec datagram -- )
3dup check-datagram-send
port-handle win32-file-handle
rot dup length "WSABUF" <c-object>
[ windows.winsock:set-WSABUF-len ] keep
[ windows.winsock:set-WSABUF-buf ] keep
rot send-WSABUF
rot make-sockaddr/size
>r >r 1 0 <uint> 0 r> r> f f
windows.winsock:WSASendTo zero?
[ windows.winsock:winsock-error ] unless ;
windows.winsock:WSASendTo
windows.winsock:winsock-error!=0/f ;

8
extra/io/windows/nt/backend/backend.factor
View File

@ -8,6 +8,14 @@ IN: io.windows.nt.backend
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
M: windows-nt-io root-directory? ( path -- ? )
dup length 2 = [
dup first Letter?
swap second CHAR: : = and
] [
drop f
] if ;
M: windows-nt-io normalize-pathname ( string -- string )
dup string? [ "pathname must be a string" throw ] unless
"/" split "\\" join

8
extra/io/windows/windows-tests.factor → extra/io/windows/nt/nt-tests.factor
View File

@ -5,12 +5,12 @@ IN: temporary
[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
[ "c:" ] [ "c:\\" parent-directory ] unit-test
[ "Z:" ] [ "Z:\\" parent-directory ] unit-test
[ "c:" ] [ "c:" parent-directory ] unit-test
[ "Z:" ] [ "Z:" parent-directory ] unit-test
[ t ] [ "c:\\" root-directory? ] unit-test
[ t ] [ "Z:\\" root-directory? ] unit-test
[ t ] [ "c:\\" trim-path-separators root-directory? ] unit-test
[ t ] [ "Z:\\" trim-path-separators root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test

37
extra/io/windows/windows.factor
View File

@ -1,9 +1,8 @@
USING: alien alien.c-types arrays destructors io
io.backend io.buffers io.files io.nonblocking io.sockets
io.sockets.impl windows.errors strings io.streams.duplex
kernel math namespaces sequences windows
windows.kernel32 windows.winsock windows.winsock.private ;
USE: prettyprint
USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.nonblocking io.sockets io.binary
io.sockets.impl windows.errors strings io.streams.duplex kernel
math namespaces sequences windows windows.kernel32
windows.winsock windows.winsock.private ;
IN: io.windows
TUPLE: windows-nt-io ;
@ -16,15 +15,6 @@ M: windows-io (handle-destructor) ( obj -- )
M: windows-io (socket-destructor) ( obj -- )
destructor-obj closesocket drop ;
M: windows-io root-directory? ( path -- ? )
[ path-separator? ] right-trim
dup length 2 = [
dup first Letter?
swap second CHAR: : = and
] [
drop f
] if ;
TUPLE: win32-file handle ptr overlapped ;
: <win32-file> ( handle ptr -- obj )
@ -67,9 +57,18 @@ M: win32-file close-handle ( handle -- )
: (open-append) ( path -- handle )
normalize-pathname GENERIC_WRITE OPEN_ALWAYS open-file ;
: set-file-pointer ( handle length -- )
dupd d>w/w <uint> FILE_BEGIN SetFilePointer
INVALID_SET_FILE_POINTER = [
CloseHandle "SetFilePointer failed" throw
] when drop ;
: open-append ( path -- handle length )
dup file-length dup
[ >r (open-append) r> ] [ drop open-write ] if ;
dup file-length dup [
>r (open-append) r> 2dup set-file-pointer
] [
drop open-write
] if ;
TUPLE: FileArgs
hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;
@ -160,13 +159,13 @@ USE: namespaces
: listen-backlog ( -- n ) HEX: 7fffffff ; inline
: listen-on-socket ( socket -- )
listen-backlog listen winsock-error!=0/f ;
listen-backlog listen winsock-return-check ;
M: win32-socket stream-close ( stream -- )
win32-file-handle closesocket drop ;
M: windows-io addrinfo-error ( n -- )
winsock-error!=0/f ;
winsock-return-check ;
: tcp-socket ( addrspec -- socket )
protocol-family SOCK_STREAM open-socket ;

99
extra/network-clipboard/network-clipboard.factor Normal file
View File

@ -0,0 +1,99 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.server io.sockets io strings parser byte-arrays
namespaces ui.clipboards ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.buttons ui.gadgets.tracks ui.gadgets ui.operations
ui.commands ui kernel splitting combinators continuations
sequences io.streams.duplex models ;
IN: network-clipboard
: clipboard-port 4444 ;
: get-request
clipboard get clipboard-contents write ;
: contents ( -- str )
[ 1024 read dup ] [ ] [ drop ] unfold concat ;
: set-request
contents clipboard get set-clipboard-contents ;
: clipboard-server ( -- )
clipboard-port internet-server "clip-server" [
readln {
{ "GET" [ get-request ] }
{ "SET" [ set-request ] }
} case
] with-server ;
\ clipboard-server H{
{ +nullary+ t }
{ +listener+ t }
} define-command
: <client-datagram> ( -- datagram )
"0.0.0.0" 0 <inet4> <datagram> ;
: with-client ( addrspec quot -- )
>r <client> r> with-stream ; inline
: send-text ( text host -- )
clipboard-port <inet4> [ write ] with-client ;
TUPLE: host name ;
C: <host> host
M: string host-name ;
: send-clipboard ( host -- )
host-name
"SET\n" clipboard get clipboard-contents append swap send-text ;
[ host? ] \ send-clipboard H{ } define-operation
: ask-text ( text host -- )
clipboard-port <inet4>
[ write flush contents ] with-client ;
: receive-clipboard ( host -- )
host-name
"GET\n" swap ask-text
clipboard get set-clipboard-contents ;
[ host? ] \ receive-clipboard H{ } define-operation
: hosts. ( seq -- )
"Hosts:" print
[ dup <host> write-object nl ] each ;
TUPLE: network-clipboard-tool ;
\ network-clipboard-tool "toolbar" f {
{ f clipboard-server }
} define-command-map
: <network-clipboard-tool> ( model -- gadget )
\ network-clipboard-tool construct-empty [
toolbar,
[ hosts. ] <pane-control> <scroller> 1 track,
] { 0 1 } build-track ;
SYMBOL: network-clipboards
{ } <model> network-clipboards set-global
: set-network-clipboards ( seq -- )
network-clipboards get set-model ;
: add-network-clipboard ( host -- )
network-clipboards get [ swap add ] change-model ;
: network-clipboard-tool ( -- )
[
network-clipboards get
<network-clipboard-tool>
"Network clipboard" open-window
] with-ui ;
MAIN: network-clipboard-tool

4
extra/webapps/planet/planet.factor
View File

@ -1,7 +1,7 @@
USING: sequences rss arrays concurrency kernel sorting
html.elements io assocs namespaces math threads vocabs html
furnace http.server.templating calendar math.parser splitting
continuations debugger system ;
continuations debugger system http.server.responders ;
IN: webapps.planet
TUPLE: posting author title date link body ;
@ -92,7 +92,7 @@ SYMBOL: cached-postings
cached-postings get 4 head print-posting-summaries ;
: planet-factor ( -- )
[
serving-html [
"resource:extra/webapps/planet/planet.fhtml"
run-template-file
] with-html-stream ;

1
extra/windows/kernel32/kernel32.factor Normal file → Executable file
View File

@ -96,6 +96,7 @@ TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
: INVALID_HANDLE_VALUE -1 <alien> ; inline
: INVALID_FILE_SIZE HEX: FFFFFFFF ; inline
: INVALID_SET_FILE_POINTER HEX: ffffffff ; inline
: FILE_BEGIN 0 ; inline
: FILE_CURRENT 1 ; inline

7
extra/windows/winsock/winsock.factor
View File

@ -413,6 +413,11 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
] when ;
: winsock-error!=0/f ( n/f -- )
{ 0 f } member? [
winsock-error-string throw
] unless ;
: winsock-return-check ( n/f -- )
dup { 0 f } member? [
drop
] [
@ -433,5 +438,5 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
SOCKET_ERROR = [ winsock-error ] when ;
: init-winsock ( -- )
HEX: 0202 <wsadata> WSAStartup winsock-error!=0/f ;
HEX: 0202 <wsadata> WSAStartup winsock-return-check ;