diff --git a/core/libc/libc-docs.factor b/core/libc/libc-docs.factor index 9596b98292..ba870560d6 100644 --- a/core/libc/libc-docs.factor +++ b/core/libc/libc-docs.factor @@ -26,8 +26,7 @@ HELP: memcpy HELP: check-ptr { $values { "c-ptr" "an alien address, byte array, or " { $link f } } { "checked" "an alien address or byte array with non-zero address" } } -{ $description "Throws an error if the input is " { $link f } ". Otherwise the object remains on the data stack. This word should be used to check the return values of " { $link malloc } " and " { $link realloc } " before use." } -{ $error-description "Callers of " { $link malloc } " and " { $link realloc } " should use " { $link check-ptr } " to throw an error in the case of a memory allocation failure." } ; +{ $description "Throws an error if the input is " { $link f } ". Otherwise the object remains on the data stack." } ; HELP: free { $values { "alien" c-ptr } } diff --git a/core/libc/libc.factor b/core/libc/libc.factor index 71b49e940a..88c5070d1f 100644 --- a/core/libc/libc.factor +++ b/core/libc/libc.factor @@ -84,4 +84,4 @@ PRIVATE> "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ; : with-malloc ( size quot -- ) - swap 1 calloc check-ptr swap keep free ; inline + swap 1 calloc swap keep free ; inline diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor old mode 100644 new mode 100755 index 8aa7861d5a..64d5e929b2 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -1,8 +1,12 @@ -USING: system vocabs vocabs.loader kernel ; +USING: system vocabs vocabs.loader kernel combinators +namespaces sequences ; IN: bootstrap.io "bootstrap.compiler" vocab [ - unix? [ "io.unix" require ] when - winnt? [ "io.windows.nt" require ] when - wince? [ "io.windows.ce" require ] when + "io." { + { [ "io-backend" get ] [ "io-backend" get ] } + { [ unix? ] [ "unix" ] } + { [ winnt? ] [ "windows.nt" ] } + { [ wince? ] [ "windows.ce" ] } + } cond append require ] when diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index e58cf3ead0..5d6eaebe6f 100644 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -79,7 +79,7 @@ HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; buffer-fill zero? ; : extend-buffer ( n buffer -- ) - 2dup buffer-ptr swap realloc check-ptr + 2dup buffer-ptr swap realloc over set-buffer-ptr set-buffer-size ; : check-overflow ( n buffer -- ) diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 7231bb6402..8af2702c69 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -3,7 +3,8 @@ IN: io.nonblocking USING: math kernel io sequences io.buffers generic sbufs system io.streams.lines io.streams.plain io.streams.duplex -continuations debugger classes byte-arrays namespaces ; +continuations debugger classes byte-arrays namespaces +splitting ; SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global @@ -137,11 +138,7 @@ M: input-port stream-read-partial ( max stream -- string/f ) >r 0 max >fixnum r> read-step ; : can-write? ( len writer -- ? ) - dup buffer-empty? [ - 2drop t - ] [ - [ buffer-fill + ] keep buffer-capacity <= - ] if ; + [ buffer-fill + ] keep buffer-capacity <= ; : wait-to-write ( len port -- ) tuck can-write? [ drop ] [ stream-flush ] if ; @@ -150,7 +147,12 @@ M: output-port stream-write1 1 over wait-to-write ch>buffer ; M: output-port stream-write - over length over wait-to-write >buffer ; + over length over buffer-size > [ + [ buffer-size ] keep + [ stream-write ] curry each + ] [ + over length over wait-to-write >buffer + ] if ; GENERIC: port-flush ( port -- ) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 486fe46866..76eeff74a9 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -159,7 +159,7 @@ TUPLE: write-task ; : ( port -- task ) write-task ; M: write-task do-io-task - io-task-port dup buffer-length zero? over port-error or + io-task-port dup buffer-empty? over port-error or [ 0 swap buffer-reset t ] [ write-step ] if ; M: write-task task-container drop write-tasks get-global ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 7b286feae1..61a6f706f6 100644 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -1,12 +1,37 @@ -IN: io.unix.launcher + USING: io io.launcher io.unix.backend io.nonblocking sequences kernel namespaces math system alien.c-types -debugger continuations ; +debugger continuations combinators.lib threads ; + +IN: io.unix.launcher ! Search unix first USE: unix -: with-fork ( quot -- pid ) +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! 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" WNOHANG waitpid + 0 = [ 100 sleep wait-for-pid ] [ drop ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: with-fork ( child parent -- pid ) fork [ zero? -rot if ] keep ; inline : prepare-execvp ( args -- cmd args ) diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index 37eb161ff8..2cd1f6fe99 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -1,6 +1,7 @@ USING: io.nonblocking io.windows threads.private kernel io.backend windows.winsock windows.kernel32 windows -io.streams.duplex io namespaces alien.syntax system combinators ; +io.streams.duplex io namespaces alien.syntax system combinators +io.buffers ; IN: io.windows.ce.backend : port-errored ( port -- ) @@ -16,8 +17,12 @@ M: input-port (wait-to-read) ( port -- ) GENERIC: wince-write ( port port-handle -- ) -M: windows-ce-io flush-output ( port -- ) - dup port-handle wince-write ; +M: port port-flush + dup buffer-empty? over port-error or [ + drop + ] [ + dup dup port-handle wince-write port-flush + ] if ; M: windows-ce-io init-io ( -- ) init-winsock ; @@ -29,7 +34,7 @@ FUNCTION: void* _fileno void* file ; M: windows-ce-io init-stdio ( -- ) #! We support Windows NT too, to make this I/O backend #! easier to debug. - 4096 default-buffer-size [ + 512 default-buffer-size [ winnt? [ STD_INPUT_HANDLE GetStdHandle STD_OUTPUT_HANDLE GetStdHandle diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index 277641a78a..0cffcb85f0 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -23,6 +23,5 @@ M: win32-file wince-write ( port port-handle -- ) drop port-errored ] [ FileArgs-lpNumberOfBytesRet *uint - over buffer-consume - port-flush + swap buffer-consume ] if ; diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 8fd1bc5fea..659f481188 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -95,7 +95,7 @@ M: win32-socket wince-write ( port port-handle -- ) win32-file-handle over buffer@ pick buffer-length 0 windows.winsock:send dup windows.winsock:SOCKET_ERROR = - [ drop port-errored ] [ over buffer-consume port-flush ] if ; + [ drop port-errored ] [ swap buffer-consume ] if ; : do-connect ( addrspec -- socket ) [ tcp-socket dup ] keep diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 530bc14c3a..d53f5fcb40 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -39,9 +39,12 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) 2drop ] if ; -M: windows-nt-io flush-output ( port -- ) +: flush-output ( port -- ) [ (flush-output) ] with-destructors ; +M: port port-flush + dup buffer-empty? [ dup flush-output ] unless drop ; + : finish-read ( port -- ) dup pending-error dup get-overlapped-result dup zero? [ diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 74538ac06a..47ab7795b0 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types byte-arrays continuations destructors -io.nonblocking io io.sockets io.sockets.impl +io.nonblocking io io.sockets io.sockets.impl namespaces io.streams.duplex io.windows io.windows.nt io.windows.nt.backend windows.winsock kernel libc math sequences threads tuples.lib ; IN: io.windows.nt.sockets diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 894874a60b..16b7c4847f 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -32,7 +32,6 @@ TUPLE: win32-file handle ptr overlapped ; \ win32-file construct ; HOOK: CreateFile-flags io-backend ( -- DWORD ) -HOOK: flush-output io-backend ( port -- ) HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f ) HOOK: add-completion io-backend ( port -- ) @@ -48,9 +47,6 @@ M: win32-file init-handle ( handle -- ) M: win32-file close-handle ( handle -- ) win32-file-handle CloseHandle drop ; -M: port port-flush - dup buffer-empty? [ dup flush-output ] unless drop ; - ! Clean up resources (open handle) if add-completion fails : open-file ( path access-mode create-mode -- handle ) [ diff --git a/extra/unix/linux/if/if.factor b/extra/unix/linux/if/if.factor new file mode 100644 index 0000000000..0a908831ee --- /dev/null +++ b/extra/unix/linux/if/if.factor @@ -0,0 +1,98 @@ + +USING: alien.syntax ; + +IN: unix.linux.if + +: IFNAMSIZ 16 ; +: IF_NAMESIZE 16 ; +: IFHWADDRLEN 6 ; + +! Standard interface flags (netdevice->flags) + +: IFF_UP HEX: 1 ; ! interface is up +: IFF_BROADCAST HEX: 2 ; ! broadcast address valid +: IFF_DEBUG HEX: 4 ; ! turn on debugging +: IFF_LOOPBACK HEX: 8 ; ! is a loopback net +: IFF_POINTOPOINT HEX: 10 ; ! interface is has p-p link +: IFF_NOTRAILERS HEX: 20 ; ! avoid use of trailers +: IFF_RUNNING HEX: 40 ; ! interface running and carrier ok +: IFF_NOARP HEX: 80 ; ! no ARP protocol +: IFF_PROMISC HEX: 100 ; ! receive all packets +: IFF_ALLMULTI HEX: 200 ; ! receive all multicast packets + +: IFF_MASTER HEX: 400 ; ! master of a load balancer +: IFF_SLAVE HEX: 800 ; ! slave of a load balancer + +: IFF_MULTICAST HEX: 1000 ; ! Supports multicast + +! #define IFF_VOLATILE +! (IFF_LOOPBACK|IFF_POINTOPOINT|IFF_BROADCAST|IFF_MASTER|IFF_SLAVE|IFF_RUNNING) + +: IFF_PORTSEL HEX: 2000 ; ! can set media type +: IFF_AUTOMEDIA HEX: 4000 ; ! auto media select active +: IFF_DYNAMIC HEX: 8000 ; ! dialup device with changing addresses + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +C-STRUCT: struct-ifmap + { "ulong" "mem-start" } + { "ulong" "mem-end" } + { "ushort" "base-addr" } + { "uchar" "irq" } + { "uchar" "dma" } + { "uchar" "port" } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! Hmm... the generic sockaddr type isn't defined anywhere. +! Put it here for now. + +TYPEDEF: ushort sa_family_t + +C-STRUCT: struct-sockaddr + { "sa_family_t" "sa_family" } + { { "char" 14 } "sa_data" } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! C-UNION: union-ifr-ifrn { "char" IFNAMSIZ } ; + +C-UNION: union-ifr-ifrn { "char" 16 } ; + +C-UNION: union-ifr-ifru + "struct-sockaddr" +! "sockaddr" + "short" + "int" + "struct-ifmap" +! { "char" IFNAMSIZ } + { "char" 16 } + "caddr_t" ; + +C-STRUCT: struct-ifreq + { "union-ifr-ifrn" "ifr-ifrn" } + { "union-ifr-ifru" "ifr-ifru" } ; + +: ifr-name ( struct-ifreq -- value ) struct-ifreq-ifr-ifrn ; + +: ifr-hwaddr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ; +: ifr-addr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ; +: ifr-dstaddr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ; +: ifr-broadaddr ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ; +: ifr-netmask ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ; +: ifr-flags ( struct-ifreq -- value ) struct-ifreq-ifr-ifru ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +C-UNION: union-ifc-ifcu "caddr_t" "struct-ifreq*" ; + +C-STRUCT: struct-ifconf + { "int" "ifc-len" } + { "union-ifc-ifcu" "ifc-ifcu" } ; + +: ifc-len ( struct-ifconf -- value ) struct-ifconf-ifc-len ; + +: ifc-buf ( struct-ifconf -- value ) struct-ifconf-ifc-ifcu ; +: ifc-req ( struct-ifconf -- value ) struct-ifconf-ifc-ifcu ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! \ No newline at end of file diff --git a/extra/unix/linux/sockios/sockios.factor b/extra/unix/linux/sockios/sockios.factor new file mode 100644 index 0000000000..22da13f482 --- /dev/null +++ b/extra/unix/linux/sockios/sockios.factor @@ -0,0 +1,59 @@ + +IN: unix.linux.sockios + +! Imported from linux-headers-2.6.15-28-686 on Ubuntu 6.06 + +! Socket configuration controls + +: SIOCGIFNAME HEX: 8910 ; ! get iface name +: SIOCSIFLINK HEX: 8911 ; ! set iface channel +: SIOCGIFCONF HEX: 8912 ; ! get iface list +: SIOCGIFFLAGS HEX: 8913 ; ! get flags +: SIOCSIFFLAGS HEX: 8914 ; ! set flags +: SIOCGIFADDR HEX: 8915 ; ! get PA address +: SIOCSIFADDR HEX: 8916 ; ! set PA address +: SIOCGIFDSTADDR HEX: 8917 ; ! get remote PA address +: SIOCSIFDSTADDR HEX: 8918 ; ! set remote PA address +: SIOCGIFBRDADDR HEX: 8919 ; ! get broadcast PA address +: SIOCSIFBRDADDR HEX: 891a ; ! set broadcast PA address +: SIOCGIFNETMASK HEX: 891b ; ! get network PA mask +: SIOCSIFNETMASK HEX: 891c ; ! set network PA mask +: SIOCGIFMETRIC HEX: 891d ; ! get metric +: SIOCSIFMETRIC HEX: 891e ; ! set metric +: SIOCGIFMEM HEX: 891f ; ! get memory address (BSD) +: SIOCSIFMEM HEX: 8920 ; ! set memory address (BSD) +: SIOCGIFMTU HEX: 8921 ; ! get MTU size +: SIOCSIFMTU HEX: 8922 ; ! set MTU size +: SIOCSIFNAME HEX: 8923 ; ! set interface name +: SIOCSIFHWADDR HEX: 8924 ; ! set hardware address +: SIOCGIFENCAP HEX: 8925 ; ! get/set encapsulations +: SIOCSIFENCAP HEX: 8926 ; +: SIOCGIFHWADDR HEX: 8927 ; ! Get hardware address +: SIOCGIFSLAVE HEX: 8929 ; ! Driver slaving support +: SIOCSIFSLAVE HEX: 8930 ; +: SIOCADDMULTI HEX: 8931 ; ! Multicast address lists +: SIOCDELMULTI HEX: 8932 ; +: SIOCGIFINDEX HEX: 8933 ; ! name -> if_index mapping +: SIOGIFINDEX SIOCGIFINDEX ; ! misprint compatibility :-) +: SIOCSIFPFLAGS HEX: 8934 ; ! set/get extended flags set +: SIOCGIFPFLAGS HEX: 8935 ; +: SIOCDIFADDR HEX: 8936 ; ! delete PA address +: SIOCSIFHWBROADCAST HEX: 8937 ; ! set hardware broadcast addr +: SIOCGIFCOUNT HEX: 8938 ; ! get number of devices + +: SIOCGIFBR HEX: 8940 ; ! Bridging support +: SIOCSIFBR HEX: 8941 ; ! Set bridging options + +: SIOCGIFTXQLEN HEX: 8942 ; ! Get the tx queue length +: SIOCSIFTXQLEN HEX: 8943 ; ! Set the tx queue length + +: SIOCGIFDIVERT HEX: 8944 ; ! Frame diversion support +: SIOCSIFDIVERT HEX: 8945 ; ! Set frame diversion options + +: SIOCETHTOOL HEX: 8946 ; ! Ethtool interface + +: SIOCGMIIPHY HEX: 8947 ; ! Get address of MII PHY in use +: SIOCGMIIREG HEX: 8948 ; ! Read MII PHY register. +: SIOCSMIIREG HEX: 8949 ; ! Write MII PHY register. + +: SIOCWANDEV HEX: 894A ; ! get/set netdev parameters diff --git a/misc/factor.el b/misc/factor.el index 6598f2cbff..19e29843d6 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -86,7 +86,8 @@ "IN:" "USING:" "TUPLE:" "^C:" "^M:" "USE:" "REQUIRE:" "PROVIDE:" "REQUIRES:" "GENERIC:" "GENERIC#" "SYMBOL:" "PREDICATE:" "VAR:" "VARS:" - "UNION:" "" "MACRO:" "MACRO::" "DEFER:")) + "C-STRUCT:" + "C-UNION:" "" "MACRO:" "MACRO::" "DEFER:" "TYPEDEF:")) (defun factor-mode () "A mode for editing programs written in the Factor programming language."