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

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

release
Doug Coleman 2007-11-09 11:41:34 -06:00
parent 00e5607a2c e8a74a19c2
commit ee64716368
16 changed files with 224 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/libc/libc-docs.factor
View File

@ -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 } }

2
core/libc/libc.factor
View File

@ -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

12
extra/bootstrap/io/io.factor Normal file → Executable file
View File

@ -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

2
extra/io/buffers/buffers.factor
View File

@ -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 -- )

16
extra/io/nonblocking/nonblocking.factor
View File

@ -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 <groups> ] keep
[ stream-write ] curry each
] [
over length over wait-to-write >buffer
] if ;
GENERIC: port-flush ( port -- )

2
extra/io/unix/backend/backend.factor
View File

@ -159,7 +159,7 @@ TUPLE: write-task ;
: <write-task> ( port -- task ) write-task <io-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 ;

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

@ -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" <c-object> 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 )

13
extra/io/windows/ce/backend/backend.factor
View File

@ -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

3
extra/io/windows/ce/files/files.factor
View File

@ -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 ;

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

@ -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

5
extra/io/windows/nt/files/files.factor
View File

@ -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? [

2
extra/io/windows/nt/sockets/sockets.factor
View File

@ -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

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

@ -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 )
[

98
extra/unix/linux/if/if.factor Normal file
View File

@ -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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

59
extra/unix/linux/sockios/sockios.factor Normal file
View File

@ -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

3
misc/factor.el
View File

@ -86,7 +86,8 @@
"IN:" "USING:" "TUPLE:" "^C:" "^M:" "USE:" "REQUIRE:" "PROVIDE:"
"REQUIRES:"
"GENERIC:" "GENERIC#" "SYMBOL:" "PREDICATE:" "VAR:" "VARS:"
"UNION:" "<PRIVATE" "PRIVATE>" "MACRO:" "MACRO::" "DEFER:"))
"C-STRUCT:"
"C-UNION:" "<PRIVATE" "PRIVATE>" "MACRO:" "MACRO::" "DEFER:" "TYPEDEF:"))
(defun factor-mode ()
"A mode for editing programs written in the Factor programming language."