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

Merge branch 'master' of git://factorcode.org/git/factor

db4
John Benediktsson 2008-12-02 15:46:40 -08:00
parent 4d3e593115 9ac3f13b2a
commit 7e377e99b5
96 changed files with 732 additions and 632 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
basis/cpu/x86/assembler/assembler.factor
View File

@ -130,7 +130,7 @@ M: register modifier drop BIN: 11 ;
GENERIC# n, 1 ( value n -- )
M: integer n, >le % ;
M: byte n, >r value>> r> n, ;
M: byte n, [ value>> ] dip n, ;
: 1, ( n -- ) 1 n, ; inline
: 4, ( n -- ) 4 n, ; inline
: 2, ( n -- ) 2 n, ; inline
@ -209,7 +209,7 @@ M: object operand-64? drop f ;
: short-operand ( reg rex.w n -- )
#! Some instructions encode their single operand as part of
#! the opcode.
>r dupd prefix-1 reg-code r> + , ;
[ dupd prefix-1 reg-code ] dip + , ;
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
@ -224,7 +224,7 @@ M: object operand-64? drop f ;
: 1-operand ( op reg,rex.w,opcode -- )
#! The 'reg' is not really a register, but a value for the
#! 'reg' field of the mod-r/m byte.
first3 >r >r over r> prefix-1 r> opcode, swap addressing ;
first3 [ [ over ] dip prefix-1 ] dip opcode, swap addressing ;
: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
@ -250,7 +250,7 @@ M: object operand-64? drop f ;
] if ;
: (2-operand) ( dst src op -- )
>r 2dup t rex-prefix r> opcode,
[ 2dup t rex-prefix ] dip opcode,
reg-code swap addressing ;
: direction-bit ( dst src op -- dst' src' op' )
@ -271,11 +271,11 @@ M: object operand-64? drop f ;
PRIVATE>
: [] ( reg/displacement -- indirect )
dup integer? [ >r f f f r> ] [ f f f ] if <indirect> ;
dup integer? [ [ f f f ] dip ] [ f f f ] if <indirect> ;
: [+] ( reg displacement -- indirect )
dup integer?
[ dup zero? [ drop f ] when >r f f r> ]
[ dup zero? [ drop f ] when [ f f ] dip ]
[ f f ] if
<indirect> ;

4
basis/cpu/x86/assembler/syntax/syntax.factor
View File

@ -4,8 +4,8 @@ USING: kernel words sequences lexer parser fry ;
IN: cpu.x86.assembler.syntax
: define-register ( name num size -- )
>r >r "cpu.x86.assembler" create dup define-symbol r> r>
>r dupd "register" set-word-prop r>
[ "cpu.x86.assembler" create dup define-symbol ] 2dip
[ dupd "register" set-word-prop ] dip
"register-size" set-word-prop ;
: define-registers ( names size -- )

5
basis/environment/environment.factor
View File

@ -27,6 +27,9 @@ HOOK: (set-os-envs) os ( seq -- )
} cond
[
"FACTOR_ROOTS" os-env os windows? ";" ":" ? split
"FACTOR_ROOTS" os-env
[
os windows? ";" ":" ? split
[ add-vocab-root ] each
] when*
] "environment" add-init-hook

4
basis/fry/fry-docs.factor
View File

@ -46,10 +46,10 @@ $nl
"{ 10 20 30 } [ sq ] [ . ] compose each"
"{ 10 20 30 } [ sq . ] each"
}
"The " { $link _ } " and " { $link @ } " specifiers may be freely mixed:"
"The " { $link _ } " and " { $link @ } " specifiers may be freely mixed, and the result is considerably more concise and readable than the version using " { $link curry } " and " { $link compose } " directly:"
{ $code
"{ 8 13 14 27 } [ even? ] 5 '[ @ dup _ ? ] map"
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry compose compose map"
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
}
"The following is a no-op:"

2
basis/io/buffers/buffers-tests.factor
View File

@ -5,7 +5,7 @@ destructors ;
: buffer-set ( string buffer -- )
over >byte-array over ptr>> byte-array>memory
>r length r> buffer-reset ;
[ length ] dip buffer-reset ;
: string>buffer ( string -- buffer )
dup length <buffer> tuck buffer-set ;

2
basis/io/encodings/utf16/utf16.factor
View File

@ -25,7 +25,7 @@ ERROR: missing-bom ;
: quad-be ( stream byte -- stream char )
double-be over stream-read1 [
dup -2 shift BIN: 110111 number= [
>r 2 shift r> BIN: 11 bitand bitor
[ 2 shift ] dip BIN: 11 bitand bitor
over stream-read1 swap append-nums HEX: 10000 +
] [ 2drop dup stream-read1 drop replacement-char ] if
] when* ;

2
basis/io/monitors/monitors.factor
View File

@ -53,7 +53,7 @@ SYMBOL: +rename-file-new+
SYMBOL: +rename-file+
: with-monitor ( path recursive? quot -- )
>r <monitor> r> with-disposal ; inline
[ <monitor> ] dip with-disposal ; inline
{
{ [ os macosx? ] [ "io.unix.macosx.monitors" require ] }

18
basis/io/monitors/recursive/recursive.factor
View File

@ -3,7 +3,7 @@
USING: accessors sequences assocs arrays continuations
destructors combinators kernel threads concurrency.messaging
concurrency.mailboxes concurrency.promises io.files io.monitors
debugger ;
debugger fry ;
IN: io.monitors.recursive
! Simulate recursive monitors on platforms that don't have them
@ -29,10 +29,10 @@ DEFER: add-child-monitor
qualify-path dup link-info directory? [
[ add-child-monitors ]
[
[
[ f my-mailbox (monitor) ] keep
'[
_ [ f my-mailbox (monitor) ] keep
monitor tget children>> set-at
] curry ignore-errors
] ignore-errors
] bi
] [ drop ] if ;
@ -48,7 +48,7 @@ M: recursive-monitor dispose*
monitor tget children>> [ nip dispose ] assoc-each ;
: pump-step ( msg -- )
first3 path>> swap >r prepend-path r> monitor tget 3array
first3 path>> swap [ prepend-path ] dip monitor tget 3array
monitor tget queue>>
mailbox-put ;
@ -71,9 +71,9 @@ M: recursive-monitor dispose*
: pump-loop ( -- )
receive dup synchronous? [
>r stop-pump t r> reply-synchronous
[ stop-pump t ] dip reply-synchronous
] [
[ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi
[ '[ _ update-hierarchy ] ignore-errors ] [ pump-step ] bi
pump-loop
] if ;
@ -88,7 +88,7 @@ M: recursive-monitor dispose*
pump-loop ;
: start-pump-thread ( monitor -- )
dup [ pump-thread ] curry
dup '[ _ pump-thread ]
"Recursive monitor pump" spawn
>>thread drop ;
@ -96,7 +96,7 @@ M: recursive-monitor dispose*
ready>> ?promise ?linked drop ;
: <recursive-monitor> ( path mailbox -- monitor )
>r (normalize-path) r>
[ (normalize-path) ] dip
recursive-monitor new-monitor
H{ } clone >>children
<promise> >>ready

2
basis/io/pools/pools.factor
View File

@ -42,7 +42,7 @@ GENERIC: make-connection ( pool -- conn )
[ nip call ] [ drop return-connection ] 3bi ; inline
: with-pooled-connection ( pool quot -- )
>r [ acquire-connection ] keep r>
[ [ acquire-connection ] keep ] dip
[ (with-pooled-connection) ] [ ] [ 2drop dispose ] cleanup ; inline
M: return-connection dispose

2
basis/io/streams/duplex/duplex.factor
View File

@ -27,7 +27,7 @@ M: duplex-stream dispose
] with-destructors ;
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
tuck re-encode >r re-decode r> <duplex-stream> ;
tuck [ re-decode ] [ re-encode ] 2bi* <duplex-stream> ;
: with-stream* ( stream quot -- )
[ [ in>> ] [ out>> ] bi ] dip with-streams* ; inline

8
basis/io/timeouts/timeouts.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel calendar alarms io io.encodings accessors
namespaces ;
namespaces fry ;
IN: io.timeouts
GENERIC: timeout ( obj -- dt/f )
@ -14,14 +14,14 @@ M: encoder set-timeout stream>> set-timeout ;
GENERIC: cancel-operation ( obj -- )
: queue-timeout ( obj timeout -- alarm )
>r [ cancel-operation ] curry r> later ;
[ '[ _ cancel-operation ] ] dip later ;
: with-timeout* ( obj timeout quot -- )
3dup drop queue-timeout >r nip call r> cancel-alarm ;
3dup drop queue-timeout [ nip call ] dip cancel-alarm ;
inline
: with-timeout ( obj quot -- )
over timeout [ >r dup timeout r> with-timeout* ] [ call ] if ;
over timeout [ [ dup timeout ] dip with-timeout* ] [ call ] if ;
inline
: timeouts ( dt -- )

13
basis/io/unix/backend/backend.factor
View File

@ -5,7 +5,7 @@ math io.ports sequences strings sbufs threads unix
vectors io.buffers io.backend io.encodings math.parser
continuations system libc qualified namespaces make io.timeouts
io.encodings.utf8 destructors accessors summary combinators
locals unix.time ;
locals unix.time fry ;
QUALIFIED: io
IN: io.unix.backend
@ -88,19 +88,16 @@ M: io-timeout summary drop "I/O operation timed out" ;
: wait-for-fd ( handle event -- )
dup +retry+ eq? [ 2drop ] [
[
>r
swap handle-fd
mx get-global
r> {
'[
swap handle-fd mx get-global _ {
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
] curry "I/O" suspend nip [ io-timeout ] when
] "I/O" suspend nip [ io-timeout ] when
] if ;
: wait-for-port ( port event -- )
[ >r handle>> r> wait-for-fd ] curry with-timeout ;
'[ handle>> _ wait-for-fd ] with-timeout ;
! Some general stuff
: file-mode OCT: 0666 ;

57
basis/io/unix/files/files.factor
View File

@ -6,7 +6,7 @@ math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
io.files.private destructors vocabs.loader calendar.unix
unix.stat alien.c-types arrays unix.users unix.groups
environment fry io.encodings.utf8 alien.strings unix.statfs
environment fry io.encodings.utf8 alien.strings
combinators.short-circuit ;
IN: io.unix.files
@ -76,15 +76,64 @@ M: unix copy-file ( from to -- )
[ swap file-info permissions>> chmod io-error ]
2bi ;
HOOK: stat>file-info os ( stat -- file-info )
TUPLE: unix-file-system-info < file-system-info
block-size preferred-block-size
blocks blocks-free blocks-available
files files-free files-available
name-max flags id ;
HOOK: stat>type os ( stat -- file-info )
HOOK: new-file-system-info os ( -- file-system-info )
HOOK: new-file-info os ( -- class )
M: unix new-file-system-info ( -- ) unix-file-system-info new ;
HOOK: file-system-statfs os ( path -- statfs )
M: unix file-system-statfs drop f ;
HOOK: file-system-statvfs os ( path -- statvfs )
M: unix file-system-statvfs drop f ;
HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' )
M: unix statfs>file-system-info drop ;
HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' )
M: unix statvfs>file-system-info drop ;
: file-system-calculations ( file-system-info -- file-system-info' )
{
[ dup [ blocks-available>> ] [ block-size>> ] bi * >>free-space drop ]
[ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ]
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
[ ]
} cleave ;
M: unix file-system-info
normalize-path
[ new-file-system-info ] dip
[ file-system-statfs statfs>file-system-info ]
[ file-system-statvfs statvfs>file-system-info ] bi
file-system-calculations ;
os {
{ linux [ "io.unix.files.linux" require ] }
{ macosx [ "io.unix.files.macosx" require ] }
{ freebsd [ "io.unix.files.freebsd" require ] }
{ netbsd [ "io.unix.files.netbsd" require ] }
{ openbsd [ "io.unix.files.openbsd" require ] }
} case
TUPLE: unix-file-info < file-info uid gid dev ino
nlink rdev blocks blocksize ;
HOOK: new-file-info os ( -- file-info )
HOOK: stat>file-info os ( stat -- file-info )
HOOK: stat>type os ( stat -- file-info )
M: unix file-info ( path -- info )
normalize-path file-status stat>file-info ;

24
basis/io/unix/files/freebsd/freebsd.factor Normal file
View File

@ -0,0 +1,24 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax combinators
io.backend io.files io.unix.files kernel math system unix
unix.statfs unix.statvfs.freebsd ;
IN: io.unix.files.freebsd
M: freebsd file-system-statvfs ( path -- byte-array )
"statvfs" <c-object> tuck statvfs io-error ;
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
[ statvfs-f_bavail >>blocks-available ]
[ statvfs-f_bfree >>blocks-free ]
[ statvfs-f_blocks >>blocks ]
[ statvfs-f_favail >>files-available ]
[ statvfs-f_ffree >>files-free ]
[ statvfs-f_files >>files ]
[ statvfs-f_bsize >>block-size ]
[ statvfs-f_flag >>flags ]
[ statvfs-f_frsize >>preferred-block-size ]
[ statvfs-f_fsid >>id ]
[ statvfs-f_namemax >>name-max ]
} cleave ;

0
basis/unix/statfs/linux/32/tags.txt → basis/io/unix/files/freebsd/tags.txt
View File

70
basis/io/unix/files/linux/linux.factor Normal file
View File

@ -0,0 +1,70 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.syntax combinators csv
io.encodings.utf8 io.files io.streams.string io.unix.files
kernel namespaces sequences system unix unix.statfs.linux
unix.statvfs.linux ;
IN: io.unix.files.linux
TUPLE: linux-file-system-info < unix-file-system-info
namelen spare ;
M: linux new-file-system-info linux-file-system-info new ;
M: linux file-system-statfs ( path -- byte-array )
"statfs64" <c-object> tuck statfs64 io-error ;
M: linux statfs>file-system-info ( struct -- statfs )
{
[ statfs64-f_type >>type ]
[ statfs64-f_bsize >>block-size ]
[ statfs64-f_blocks >>blocks ]
[ statfs64-f_bfree >>blocks-free ]
[ statfs64-f_bavail >>blocks-available ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>files-free ]
[ statfs64-f_fsid >>id ]
[ statfs64-f_namelen >>namelen ]
[ statfs64-f_frsize >>preferred-block-size ]
[ statfs64-f_spare >>spare ]
} cleave ;
M: linux file-system-statvfs ( path -- byte-array )
"statvfs64" <c-object> tuck statvfs64 io-error ;
M: linux statvfs>file-system-info ( struct -- statfs )
{
[ statvfs64-f_flag >>flags ]
[ statvfs64-f_namemax >>name-max ]
} cleave ;
TUPLE: mtab-entry file-system-name mount-point type options
frequency pass-number ;
: mtab-csv>mtab-entry ( csv -- mtab-entry )
[ mtab-entry new ] dip
{
[ first >>file-system-name ]
[ second >>mount-point ]
[ third >>type ]
[ fourth <string-reader> csv first >>options ]
[ 4 swap nth >>frequency ]
[ 5 swap nth >>pass-number ]
} cleave ;
: parse-mtab ( -- array )
[
"/etc/mtab" utf8 <file-reader>
CHAR: \s delimiter set csv
] with-scope
[ mtab-csv>mtab-entry ] map ;
M: linux file-systems
parse-mtab [
[ mount-point>> file-system-info ] keep
{
[ file-system-name>> >>device-name ]
[ mount-point>> >>mount-point ]
[ type>> >>type ]
} cleave
] map ;

0
basis/unix/statfs/linux/64/tags.txt → basis/io/unix/files/linux/tags.txt
View File

50
basis/io/unix/files/macosx/macosx.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings combinators
grouping io.encodings.utf8 io.files kernel math sequences
system unix unix.statfs.macosx io.unix.files unix.statvfs.macosx ;
IN: io.unix.files.macosx
TUPLE: macosx-file-system-info < unix-file-system-info
io-size owner type-id filesystem-subtype ;
M: macosx file-systems ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error
[ *void* ] dip
"statfs64" heap-size [ * memory>byte-array ] keep group
[ [ new-file-system-info ] dip statfs>file-system-info ] map ;
M: macosx new-file-system-info macosx-file-system-info new ;
M: macosx file-system-statfs ( normalized-path -- statfs )
"statfs64" <c-object> tuck statfs64 io-error ;
M: macosx file-system-statvfs ( normalized-path -- statvfs )
"statvfs" <c-object> tuck statvfs io-error ;
M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{
[ statfs64-f_bsize >>block-size ]
[ statfs64-f_iosize >>io-size ]
[ statfs64-f_blocks >>blocks ]
[ statfs64-f_bfree >>blocks-free ]
[ statfs64-f_bavail >>blocks-available ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>files-free ]
[ statfs64-f_fsid >>id ]
[ statfs64-f_owner >>owner ]
[ statfs64-f_type >>type-id ]
[ statfs64-f_flags >>flags ]
[ statfs64-f_fssubtype >>filesystem-subtype ]
[ statfs64-f_fstypename utf8 alien>string >>type ]
[ statfs64-f_mntonname utf8 alien>string >>mount-point ]
[ statfs64-f_mntfromname utf8 alien>string >>device-name ]
} cleave ;
M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{
[ statvfs-f_frsize >>preferred-block-size ]
[ statvfs-f_favail >>files-available ]
[ statvfs-f_namemax >>name-max ]
} cleave ;

0
basis/unix/statfs/netbsd/tags.txt → basis/io/unix/files/macosx/tags.txt
View File

49
basis/io/unix/files/netbsd/netbsd.factor Normal file
View File

@ -0,0 +1,49 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel unix.stat math unix
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types unix.statfs
io.unix.files io.files unix.statvfs.netbsd ;
IN: io.unix.files.netbsd
TUPLE: netbsd-file-system-info < unix-file-system-info
blocks-reserved files-reserved
owner io-size
sync-reads sync-writes
async-reads async-writes
idx mount-from spare ;
M: netbsd new-file-system-info netbsd-file-system-info new ;
M: netbsd file-system-statvfs
"statvfs" <c-object> tuck statvfs io-error ;
M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{
[ statvfs-f_flag >>flags ]
[ statvfs-f_bsize >>block-size ]
[ statvfs-f_frsize >>preferred-block-size ]
[ statvfs-f_iosize >>io-size ]
[ statvfs-f_blocks >>blocks ]
[ statvfs-f_bfree >>blocks-free ]
[ statvfs-f_bavail >>blocks-available ]
[ statvfs-f_bresvd >>blocks-reserved ]
[ statvfs-f_files >>files ]
[ statvfs-f_ffree >>files-free ]
[ statvfs-f_favail >>files-available ]
[ statvfs-f_fresvd >>files-reserved ]
[ statvfs-f_syncreads >>sync-reads ]
[ statvfs-f_syncwrites >>sync-writes ]
[ statvfs-f_asyncreads >>async-reads ]
[ statvfs-f_asyncwrites >>async-writes ]
[ statvfs-f_fsidx >>idx ]
[ statvfs-f_fsid >>id ]
[ statvfs-f_namemax >>name-max ]
[ statvfs-f_owner >>owner ]
[ statvfs-f_spare >>spare ]
[ statvfs-f_fstypename alien>native-string >>type ]
[ statvfs-f_mntonname alien>native-string >>mount-point ]
[ statvfs-f_mntfromname alien>native-string >>device-name ]
} cleave ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;

0
basis/unix/statfs/openbsd/32/tags.txt → basis/io/unix/files/netbsd/tags.txt
View File

41
basis/io/unix/files/openbsd/openbsd.factor Normal file
View File

@ -0,0 +1,41 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax accessors combinators kernel
unix.types math system io.backend alien.c-types unix
io.files io.unix.files unix.statvfs.openbsd ;
IN: io.unix.files.openbsd
M: openbsd file-system-statfs
"statfs" <c-object> tuck statfs io-error ;
M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
{
[ statfs-f_flag >>flags ]
[ statfs-f_bsize >>block-size ]
[ statfs-f_iosize >>io-size ]
[ statfs-f_blocks >>blocks ]
[ statfs-f_bfree >>blocks-free ]
[ statfs-f_bavail >>blocks-available ]
[ statfs-f_files >>files ]
[ statfs-f_ffree >>files-free ]
[ statfs-f_favail >>files-available ]
[ statfs-f_syncwrites >>sync-writes ]
[ statfs-f_syncreads >>sync-reads ]
[ statfs-f_asyncwrites >>async-writes ]
[ statfs-f_asyncreads >>async-reads ]
[ statfs-f_fsid >>id ]
[ statfs-f_namemax >>name-max ]
[ statfs-f_owner >>owner ]
[ statfs-f_spare >>spare ]
[ statfs-f_fstypename alien>native-string >>type ]
[ statfs-f_mntonname alien>native-string >>mount-point ]
[ statfs-f_mntfromname alien>native-string >>device-name ]
} cleave ;
M: openbsd file-system-statvfs ( normalized-path -- statvfs )
"statvfs" <c-object> tuck statvfs io-error ;
M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{
[ statvfs-f_frsize >>preferred-block-size ]
} cleave ;

0
basis/unix/statfs/openbsd/64/tags.txt → basis/io/unix/files/openbsd/tags.txt
View File

8
basis/io/unix/linux/monitors/monitors.factor
View File

@ -36,9 +36,7 @@ TUPLE: linux-monitor < monitor wd inotify watches disposed ;
inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
: add-watch ( path mask mailbox -- monitor )
>r
>r (normalize-path) r>
[ (add-watch) ] [ drop ] 2bi r>
[ [ (normalize-path) ] dip [ (add-watch) ] [ drop ] 2bi ] dip
<linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
: check-inotify ( -- )
@ -103,12 +101,12 @@ M: linux-monitor dispose* ( monitor -- )
: next-event ( i buffer -- i buffer )
2dup inotify-event@
inotify-event-len "inotify-event" heap-size +
swap >r + r> ;
swap [ + ] dip ;
: parse-file-notifications ( i buffer -- )
2dup events-exhausted? [ 2drop ] [
2dup inotify-event@ dup inotify-event-wd wd>monitor
>r parse-file-notify r> queue-change
[ parse-file-notify ] dip queue-change
next-event parse-file-notifications
] if ;

6
basis/io/unix/macosx/monitors/monitors.factor
View File

@ -2,15 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.monitors
core-foundation.fsevents continuations kernel sequences
namespaces arrays system locals accessors destructors ;
namespaces arrays system locals accessors destructors fry ;
IN: io.unix.macosx.monitors
TUPLE: macosx-monitor < monitor handle ;
: enqueue-notifications ( triples monitor -- )
[
>r first { +modify-file+ } r> queue-change
] curry each ;
'[ first { +modify-file+ } _ queue-change ] each ;
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
[let | path [ path normalize-path ] |

4
basis/io/unix/select/select.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.ports io.unix.backend
bit-arrays sequences assocs unix math namespaces
accessors math.order locals unix.time ;
accessors math.order locals unix.time fry ;
IN: io.unix.select
TUPLE: select-mx < mx read-fdset write-fdset ;
@ -28,7 +28,7 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
[ check-fd ] 3curry each ; inline
: init-fdset ( fds fdset -- )
[ >r t swap munge r> set-nth ] curry each ;
'[ t swap munge _ set-nth ] each ;
: read-fdset/tasks ( mx -- seq fdset )
[ reads>> keys ] [ read-fdset>> ] bi ;

10
basis/io/unix/sockets/sockets.factor
View File

@ -16,18 +16,18 @@ IN: io.unix.sockets
0 socket dup io-error <fd> init-fd |dispose ;
: set-socket-option ( fd level opt -- )
>r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ;
[ handle-fd ] 2dip 1 <int> "int" heap-size setsockopt io-error ;
M: unix addrinfo-error ( n -- )
dup zero? [ drop ] [ gai_strerror throw ] if ;
! Client sockets - TCP and Unix domain
M: object (get-local-address) ( handle remote -- sockaddr )
>r handle-fd r> empty-sockaddr/size <int>
[ handle-fd ] dip empty-sockaddr/size <int>
[ getsockname io-error ] 2keep drop ;
M: object (get-remote-address) ( handle local -- sockaddr )
>r handle-fd r> empty-sockaddr/size <int>
[ handle-fd ] dip empty-sockaddr/size <int>
[ getpeername io-error ] 2keep drop ;
: init-client-socket ( fd -- )
@ -60,7 +60,7 @@ M: object ((client)) ( addrspec -- fd )
SOL_SOCKET SO_REUSEADDR set-socket-option ;
: server-socket-fd ( addrspec type -- fd )
>r dup protocol-family r> socket-fd
[ dup protocol-family ] dip socket-fd
dup init-server-socket
dup handle-fd rot make-sockaddr/size bind io-error ;
@ -77,7 +77,7 @@ M: object (server) ( addrspec -- handle )
M: object (accept) ( server addrspec -- fd sockaddr )
2dup do-accept
{
{ [ over 0 >= ] [ >r 2nip <fd> init-fd r> ] }
{ [ over 0 >= ] [ [ 2nip <fd> init-fd ] dip ] }
{ [ err_no EINTR = ] [ 2drop (accept) ] }
{ [ err_no EAGAIN = ] [
2drop

8
basis/io/unix/unix-tests.factor
View File

@ -46,7 +46,7 @@ yield
"Receive 1" print
"d" get receive >r reverse r>
"d" get receive [ reverse ] dip
"Send 1" print
dup .
@ -55,7 +55,7 @@ yield
"Receive 2" print
"d" get receive >r " world" append r>
"d" get receive [ " world" append ] dip
"Send 1" print
dup .
@ -86,7 +86,7 @@ datagram-client <local> <datagram>
[ "olleh" t ] [
"d" get receive
datagram-server <local> =
>r >string r>
[ >string ] dip
] unit-test
[ ] [
@ -98,7 +98,7 @@ datagram-client <local> <datagram>
[ "hello world" t ] [
"d" get receive
datagram-server <local> =
>r >string r>
[ >string ] dip
] unit-test
[ ] [ "d" get dispose ] unit-test

36
basis/io/windows/files/files.factor
View File

@ -10,7 +10,7 @@ IN: io.windows.files
: open-file ( path access-mode create-mode flags -- handle )
[
>r >r share-mode default-security-attributes r> r>
[ share-mode default-security-attributes ] 2dip
CreateFile-flags f CreateFile opened-file
] with-destructors ;
@ -46,7 +46,7 @@ IN: io.windows.files
GetLastError ERROR_ALREADY_EXISTS = not ;
: set-file-pointer ( handle length method -- )
>r dupd d>w/w <uint> r> SetFilePointer
[ dupd d>w/w <uint> ] dip SetFilePointer
INVALID_SET_FILE_POINTER = [
CloseHandle "SetFilePointer failed" throw
] when drop ;
@ -257,9 +257,6 @@ M: winnt link-info ( path -- info )
HOOK: root-directory os ( string -- string' )
TUPLE: winnt-file-system-info < file-system-info
total-bytes total-free-bytes ;
: file-system-type ( normalized-path -- str )
MAX_PATH 1+ <byte-array>
MAX_PATH 1+
@ -269,21 +266,28 @@ total-bytes total-free-bytes ;
[ GetVolumeInformation win32-error=0/f ] 2keep drop
utf16n alien>string ;
: file-system-space ( normalized-path -- free-space total-bytes total-free-bytes )
: file-system-space ( normalized-path -- available-space total-space free-space )
"ULARGE_INTEGER" <c-object>
"ULARGE_INTEGER" <c-object>
"ULARGE_INTEGER" <c-object>
[ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
: calculate-file-system-info ( file-system-info -- file-system-info' )
{
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
[ ]
} cleave ;
M: winnt file-system-info ( path -- file-system-info )
normalize-path root-directory
dup [ file-system-type ] [ file-system-space ] bi
\ winnt-file-system-info new
swap *ulonglong >>total-free-bytes
swap *ulonglong >>total-bytes
\ file-system-info new
swap *ulonglong >>free-space
swap *ulonglong >>total-space
swap *ulonglong >>available-space
swap >>type
swap >>mount-point ;
swap >>mount-point
calculate-file-system-info ;
: volume>paths ( string -- array )
16384 "ushort" <c-array> tuck dup length
@ -324,7 +328,7 @@ M: winnt file-systems ( -- array )
find-volumes [ volume>paths ] map
concat [
[ file-system-info ]
[ drop winnt-file-system-info new swap >>mount-point ] recover
[ drop \ file-system-info new swap >>mount-point ] recover
] map ;
: file-times ( path -- timestamp timestamp timestamp )
@ -344,23 +348,23 @@ M: winnt file-systems ( -- array )
: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
#! timestamp order: creation access write
[
>r >r >r
[
normalize-path open-existing &dispose handle>>
r> r> r> (set-file-times)
] 3dip (set-file-times)
] with-destructors ;
: set-file-create-time ( path timestamp -- )
f f set-file-times ;
: set-file-access-time ( path timestamp -- )
>r f r> f set-file-times ;
[ f ] dip f set-file-times ;
: set-file-write-time ( path timestamp -- )
>r f f r> set-file-times ;
[ f f ] dip set-file-times ;
M: winnt touch-file ( path -- )
[
normalize-path
maybe-create-file >r &dispose r>
maybe-create-file [ &dispose ] dip
[ drop ] [ handle>> f now dup (set-file-times) ] if
] with-destructors ;

16
basis/io/windows/nt/backend/backend.factor
View File

@ -18,8 +18,8 @@ C: <io-callback> io-callback
"OVERLAPPED" malloc-object &free ;
: make-overlapped ( port -- overlapped-ext )
>r (make-overlapped)
r> handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
[ (make-overlapped) ] dip
handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
: <completion-port> ( handle existing -- handle )
f 1 CreateIoCompletionPort dup win32-error=0/f ;
@ -64,13 +64,9 @@ M: winnt add-completion ( win32-handle -- )
: handle-overlapped ( us -- ? )
wait-for-overlapped [
dup [
>r drop GetLastError 1array r> resume-callback t
] [
2drop f
] if
] [
resume-callback t
] if ;
[ drop GetLastError 1array ] dip resume-callback t
] [ 2drop f ] if
] [ resume-callback t ] if ;
M: win32-handle cancel-operation
[ check-disposed ] [ handle>> CancelIo drop ] bi ;
@ -94,7 +90,7 @@ M: winnt init-io ( -- )
: wait-for-file ( FileArgs n port -- n )
swap file-error?
[ 2drop 0 ] [ >r lpOverlapped>> r> twiddle-thumbs ] if ;
[ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
: update-file-ptr ( n port -- )
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;

2
basis/io/windows/nt/files/files.factor
View File

@ -59,6 +59,6 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
M: winnt open-append
[ dup file-info size>> ] [ drop 0 ] recover
>r (open-append) r> >>ptr ;
[ (open-append) ] dip >>ptr ;
M: winnt home "USERPROFILE" os-env ;

4
basis/io/windows/nt/launcher/launcher.factor
View File

@ -52,7 +52,7 @@ IN: io.windows.nt.launcher
CreateFile dup invalid-handle? <win32-file> &dispose handle>> ;
: redirect-append ( path access-mode create-mode -- handle )
>r >r path>> r> r>
[ path>> ] 2dip
drop OPEN_ALWAYS
redirect-file
dup 0 FILE_END set-file-pointer ;
@ -61,7 +61,7 @@ IN: io.windows.nt.launcher
2drop handle>> duplicate-handle ;
: redirect-stream ( stream access-mode create-mode -- handle )
>r >r underlying-handle handle>> r> r> redirect-handle ;
[ underlying-handle handle>> ] 2dip redirect-handle ;
: redirect ( obj access-mode create-mode -- handle )
{

8
basis/io/windows/nt/privileges/privileges.factor
View File

@ -20,12 +20,12 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
: with-process-token ( quot -- )
#! quot: ( token-handle -- token-handle )
>r open-process-token r>
[ open-process-token ] dip
[ keep ] curry
[ CloseHandle drop ] [ ] cleanup ; inline
: lookup-privilege ( string -- luid )
>r f r> "LUID" <c-object>
[ f ] dip "LUID" <c-object>
[ LookupPrivilegeValue win32-error=0/f ] keep ;
: make-token-privileges ( name ? -- obj )
@ -39,10 +39,10 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
set-LUID_AND_ATTRIBUTES-Attributes
] when
>r lookup-privilege r>
[ lookup-privilege ] dip
[
TOKEN_PRIVILEGES-Privileges
>r 0 r> LUID_AND_ATTRIBUTES-nth
[ 0 ] dip LUID_AND_ATTRIBUTES-nth
set-LUID_AND_ATTRIBUTES-Luid
] keep ;

8
basis/io/windows/nt/sockets/sockets.factor
View File

@ -176,8 +176,8 @@ TUPLE: WSASendTo-args port
: make-send-buffer ( packet -- WSABUF )
"WSABUF" malloc-object &free
[ >r malloc-byte-array &free r> set-WSABUF-buf ]
[ >r length r> set-WSABUF-len ]
[ [ malloc-byte-array &free ] dip set-WSABUF-buf ]
[ [ length ] dip set-WSABUF-len ]
[ nip ]
2tri ; inline
@ -186,8 +186,8 @@ TUPLE: WSASendTo-args port
swap >>port
dup port>> handle>> handle>> >>s
swap make-sockaddr/size
>r malloc-byte-array &free
r> [ >>lpTo ] [ >>iToLen ] bi*
[ malloc-byte-array &free ] dip
[ >>lpTo ] [ >>iToLen ] bi*
swap make-send-buffer >>lpBuffers
1 >>dwBufferCount
0 >>dwFlags

8
basis/io/windows/sockets/sockets.factor
View File

@ -20,21 +20,21 @@ M: win32-socket dispose ( stream -- )
<win32-socket> |dispose dup add-completion ;
: open-socket ( addrspec type -- win32-socket )
>r protocol-family r>
[ protocol-family ] dip
0 f 0 WSASocket-flags WSASocket
dup socket-error
opened-socket ;
M: object (get-local-address) ( socket addrspec -- sockaddr )
>r handle>> r> empty-sockaddr/size <int>
[ handle>> ] dip empty-sockaddr/size <int>
[ getsockname socket-error ] 2keep drop ;
M: object (get-remote-address) ( socket addrspec -- sockaddr )
>r handle>> r> empty-sockaddr/size <int>
[ handle>> ] dip empty-sockaddr/size <int>
[ getpeername socket-error ] 2keep drop ;
: bind-socket ( win32-socket sockaddr len -- )
>r >r handle>> r> r> bind socket-error ;
[ handle>> ] 2dip bind socket-error ;
M: object ((client)) ( addrspec -- handle )
[ SOCK_STREAM open-socket ] keep

3
basis/io/windows/windows.factor
View File

@ -8,7 +8,8 @@ splitting continuations math.bitwise system accessors ;
IN: io.windows
: set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
[ HANDLE_FLAG_INHERIT ] dip
>BOOLEAN SetHandleInformation win32-error=0/f ;
TUPLE: win32-handle handle disposed ;

2
basis/models/range/range.factor
View File

@ -6,7 +6,7 @@ IN: models.range
TUPLE: range < compose ;
: <range> ( value min max page -- range )
: <range> ( value page min max -- range )
4array [ <model> ] map range new-compose ;
: range-model ( range -- model ) dependencies>> first ;

20
basis/qualified/qualified-docs.factor
View File

@ -4,14 +4,21 @@ IN: qualified
HELP: QUALIFIED:
{ $syntax "QUALIFIED: vocab" }
{ $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." }
{ $examples { $code
"QUALIFIED: math\n1 2 math:+ ! ==> 3" } } ;
{ $examples { $example
"USING: prettyprint qualified ;"
"QUALIFIED: math"
"1 2 math:+ ." "3"
} } ;
HELP: QUALIFIED-WITH:
{ $syntax "QUALIFIED-WITH: vocab word-prefix" }
{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses " { $snippet "word-prefix" } " as prefix." }
{ $examples { $code
"QUALIFIED-WITH: math m\n1 2 m:+ ! ==> 3" } } ;
"USING: prettyprint qualified ;"
"QUALIFIED-WITH: math m"
"1 2 m:+ ."
"3"
} } ;
HELP: FROM:
{ $syntax "FROM: vocab => words ... ;" }
@ -28,9 +35,12 @@ HELP: EXCLUDE:
HELP: RENAME:
{ $syntax "RENAME: word vocab => newname " }
{ $description "Imports " { $snippet "word" } " from " { $snippet "vocab" } ", but renamed to " { $snippet "newname" } "." }
{ $examples { $code
{ $examples { $example
"USING: prettyprint qualified ;"
"RENAME: + math => -"
"2 3 - ! => 5" } } ;
"2 3 - ."
"5"
} } ;
ARTICLE: "qualified" "Qualified word lookup"
"The " { $vocab-link "qualified" } " vocabulary provides a handful of parsing words which give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } "."

6
basis/tools/deploy/shaker/shaker.factor
View File

@ -23,10 +23,8 @@ IN: tools.deploy.shaker
: strip-init-hooks ( -- )
"Stripping startup hooks" show
"cpu.x86" init-hooks get delete-at
"command-line" init-hooks get delete-at
"libc" init-hooks get delete-at
"system" init-hooks get delete-at
{ "cpu.x86" "command-line" "libc" "system" "environment" }
[ init-hooks get delete-at ] each
deploy-threads? get [
"threads" init-hooks get delete-at
] unless

16
basis/tools/scaffold/scaffold.factor
View File

@ -19,21 +19,15 @@ ERROR: no-vocab vocab ;
: root? ( string -- ? ) vocab-roots get member? ;
: length-changes? ( seq quot -- ? )
dupd call [ length ] bi@ = not ; inline
: contains-dot? ( string -- ? ) ".." swap subseq? ;
: contains-separator? ( string -- ? ) [ path-separator? ] contains? ;
: check-vocab-name ( string -- string )
dup [ [ CHAR: . = ] trim ] length-changes?
[ vocab-name-contains-dot ] when
".." over subseq? [ vocab-name-contains-dot ] when
dup [ path-separator? ] contains?
[ vocab-name-contains-separator ] when ;
dup contains-dot? [ vocab-name-contains-dot ] when
dup contains-separator? [ vocab-name-contains-separator ] when ;
: check-root ( string -- string )
check-vocab-name
dup "resource:" head? [ "resource:" prepend ] unless
dup root? [ not-a-vocab-root ] unless ;
: directory-exists ( path -- )

13
basis/ui/gadgets/editors/editors.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents io kernel math models
USING: accessors arrays documents kernel math models
namespaces locals fry make opengl opengl.gl sequences strings
io.styles math.vectors sorting colors combinators assocs
math.order fry calendar alarms ui.clipboards ui.commands
@ -218,7 +218,7 @@ M: editor ungraft*
] with-editor-translation ;
: selection-start/end ( editor -- start end )
dup editor-mark* swap editor-caret* sort-pair ;
[ editor-mark* ] [ editor-caret* ] bi sort-pair ;
: (draw-selection) ( x1 x2 -- )
over -
@ -227,9 +227,8 @@ M: editor ungraft*
swap [ gl-fill-rect ] with-translation ;
: draw-selected-line ( start end n -- )
[ start/end-on-line ] keep tuck
[ editor get offset>x ] 2dip
editor get offset>x
[ start/end-on-line ] keep
tuck [ editor get offset>x ] 2bi@
(draw-selection) ;
: draw-selection ( -- )
@ -237,9 +236,9 @@ M: editor ungraft*
editor get selection-start/end
over first [
2dup [
[ 2dup ] dip draw-selected-line
draw-selected-line
1 translate-lines
] each-line 2drop
] with with each-line
] with-editor-translation ;
M: editor draw-gadget*

12
basis/ui/windows/windows.factor
View File

@ -284,13 +284,9 @@ SYMBOL: nc-buttons
message>button nc-buttons get
swap [ push ] [ delete ] if ;
: >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ;
: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
: mouse-absolute>relative ( lparam handle -- array )
[ >lo-hi ] dip
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
get-RECT-top-left 2array v- ;
: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
: mouse-event>gesture ( uMsg -- button )
key-modifiers swap message>button
@ -340,9 +336,7 @@ SYMBOL: nc-buttons
>lo-hi swap window move-hand fire-motion ;
:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
wParam mouse-wheel
lParam hWnd mouse-absolute>relative
hWnd window send-wheel ;
wParam mouse-wheel hand-loc get hWnd window send-wheel ;
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
#! message sent if windows needs application to stop dragging

10
basis/ui/x11/x11.factor Normal file → Executable file
View File

@ -117,7 +117,7 @@ M: world button-up-event
} at ;
M: world wheel-event
[ dup mouse-event>scroll-direction swap mouse-event-loc ] dip
[ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
send-wheel ;
M: world enter-event motion-event ;
@ -125,7 +125,7 @@ M: world enter-event motion-event ;
M: world leave-event 2drop forget-rollover ;
M: world motion-event
[ dup XMotionEvent-x swap XMotionEvent-y 2array ] dip
[ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
move-hand fire-motion ;
M: world focus-in-event
@ -146,10 +146,10 @@ M: world selection-notify-event
: clipboard-for-atom ( atom -- clipboard )
{
{ [ dup XA_PRIMARY = ] [ drop selection get ] }
{ [ dup XA_CLIPBOARD = ] [ drop clipboard get ] }
{ XA_PRIMARY [ selection get ] }
{ XA_CLIPBOARD [ clipboard get ] }
[ drop <clipboard> ]
} cond ;
} case ;
: encode-clipboard ( string type -- bytes )
XSelectionRequestEvent-target

51
basis/unix/statfs/freebsd/freebsd.factor
View File

@ -1,53 +1,4 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel unix math accessors
combinators system io.backend alien.c-types unix.statfs
io.files ;
USING: alien.syntax ;
IN: unix.statfs.freebsd
: ST_RDONLY 1 ; inline
: ST_NOSUID 2 ; inline
C-STRUCT: statvfs
{ "fsblkcnt_t" "f_bavail" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsfilcnt_t" "f_favail" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_files" }
{ "ulong" "f_bsize" }
{ "ulong" "f_flag" }
{ "ulong" "f_frsize" }
{ "ulong" "f_fsid" }
{ "ulong" "f_namemax" } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
TUPLE: freebsd-file-system-info < file-system-info
bavail bfree blocks favail ffree files
bsize flag frsize fsid namemax ;
M: freebsd >file-system-info ( struct -- statfs )
[ \ freebsd-file-system-info new ] dip
{
[
[ statvfs-f_bsize ]
[ statvfs-f_bavail ] bi * >>free-space
]
[ statvfs-f_bavail >>bavail ]
[ statvfs-f_bfree >>bfree ]
[ statvfs-f_blocks >>blocks ]
[ statvfs-f_favail >>favail ]
[ statvfs-f_ffree >>ffree ]
[ statvfs-f_files >>files ]
[ statvfs-f_bsize >>bsize ]
[ statvfs-f_flag >>flag ]
[ statvfs-f_frsize >>frsize ]
[ statvfs-f_fsid >>fsid ]
[ statvfs-f_namemax >>namemax ]
} cleave ;
M: freebsd file-system-info ( path -- byte-array )
normalize-path
"statvfs" <c-object> tuck statvfs io-error
>file-system-info ;

46
basis/unix/statfs/linux/32/32.factor
View File

@ -1,46 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel unix.stat
math accessors system unix io.backend layouts vocabs.loader
alien.syntax unix.statfs io.files ;
IN: unix.statfs.linux
C-STRUCT: statfs
{ "long" "f_type" }
{ "long" "f_bsize" }
{ "long" "f_blocks" }
{ "long" "f_bfree" }
{ "long" "f_bavail" }
{ "long" "f_files" }
{ "long" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "long" "f_namelen" } ;
FUNCTION: int statfs ( char* path, statfs* buf ) ;
TUPLE: linux32-file-system-info < file-system-info
bsize blocks bfree bavail files ffree fsid namelen
frsize spare ;
M: linux >file-system-info ( struct -- statfs )
[ \ linux32-file-system-info new ] dip
{
[
[ statfs-f_bsize ]
[ statfs-f_bavail ] bi * >>free-space
]
[ statfs-f_type >>type ]
[ statfs-f_bsize >>bsize ]
[ statfs-f_blocks >>blocks ]
[ statfs-f_bfree >>bfree ]
[ statfs-f_bavail >>bavail ]
[ statfs-f_files >>files ]
[ statfs-f_ffree >>ffree ]
[ statfs-f_fsid >>fsid ]
[ statfs-f_namelen >>namelen ]
} cleave ;
M: linux file-system-info ( path -- byte-array )
normalize-path
"statfs" <c-object> tuck statfs io-error
>file-system-info ;

1
basis/unix/statfs/linux/32/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

50
basis/unix/statfs/linux/64/64.factor
View File

@ -1,50 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel unix.stat
math accessors system unix io.backend layouts vocabs.loader
alien.syntax unix.statfs io.files ;
IN: unix.statfs.linux
C-STRUCT: statfs64
{ "__SWORD_TYPE" "f_type" }
{ "__SWORD_TYPE" "f_bsize" }
{ "__fsblkcnt64_t" "f_blocks" }
{ "__fsblkcnt64_t" "f_bfree" }
{ "__fsblkcnt64_t" "f_bavail" }
{ "__fsfilcnt64_t" "f_files" }
{ "__fsfilcnt64_t" "f_ffree" }
{ "__fsid_t" "f_fsid" }
{ "__SWORD_TYPE" "f_namelen" }
{ "__SWORD_TYPE" "f_frsize" }
{ { "__SWORD_TYPE" 5 } "f_spare" } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
TUPLE: linux64-file-system-info < file-system-info
bsize blocks bfree bavail files ffree fsid namelen
frsize spare ;
M: linux >file-system-info ( struct -- statfs )
[ \ linux64-file-system-info new ] dip
{
[
[ statfs64-f_bsize ]
[ statfs64-f_bavail ] bi * >>free-space
]
[ statfs64-f_type >>type ]
[ statfs64-f_bsize >>bsize ]
[ statfs64-f_blocks >>blocks ]
[ statfs64-f_bfree >>bfree ]
[ statfs64-f_bavail >>bavail ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>ffree ]
[ statfs64-f_fsid >>fsid ]
[ statfs64-f_namelen >>namelen ]
[ statfs64-f_frsize >>frsize ]
[ statfs64-f_spare >>spare ]
} cleave ;
M: linux file-system-info ( path -- byte-array )
normalize-path
"statfs64" <c-object> tuck statfs64 io-error
>file-system-info ;

1
basis/unix/statfs/linux/64/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

52
basis/unix/statfs/linux/linux.factor
View File

@ -1,43 +1,19 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel unix.stat
math accessors system unix io.backend layouts vocabs.loader
sequences csv io.streams.string io.encodings.utf8 namespaces
unix.statfs io.files ;
USING: alien.syntax ;
IN: unix.statfs.linux
cell-bits {
{ 32 [ "unix.statfs.linux.32" require ] }
{ 64 [ "unix.statfs.linux.64" require ] }
} case
C-STRUCT: statfs64
{ "__SWORD_TYPE" "f_type" }
{ "__SWORD_TYPE" "f_bsize" }
{ "__fsblkcnt64_t" "f_blocks" }
{ "__fsblkcnt64_t" "f_bfree" }
{ "__fsblkcnt64_t" "f_bavail" }
{ "__fsfilcnt64_t" "f_files" }
{ "__fsfilcnt64_t" "f_ffree" }
{ "__fsid_t" "f_fsid" }
{ "__SWORD_TYPE" "f_namelen" }
{ "__SWORD_TYPE" "f_frsize" }
{ { "__SWORD_TYPE" 5 } "f_spare" } ;
TUPLE: mtab-entry file-system-name mount-point type options
frequency pass-number ;
: mtab-csv>mtab-entry ( csv -- mtab-entry )
[ mtab-entry new ] dip
{
[ first >>file-system-name ]
[ second >>mount-point ]
[ third >>type ]
[ fourth <string-reader> csv first >>options ]
[ 4 swap nth >>frequency ]
[ 5 swap nth >>pass-number ]
} cleave ;
: parse-mtab ( -- array )
[
"/etc/mtab" utf8 <file-reader>
CHAR: \s delimiter set csv
] with-scope
[ mtab-csv>mtab-entry ] map ;
M: linux file-systems
parse-mtab [
[ mount-point>> file-system-info ] keep
{
[ file-system-name>> >>device-name ]
[ mount-point>> >>mount-point ]
[ type>> >>type ]
} cleave
] map ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;

49
basis/unix/statfs/macosx/macosx.factor
View File

@ -3,7 +3,7 @@
USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math
grouping system unix.statfs io.files io.backend alien.strings
math.bitwise alien.syntax ;
math.bitwise alien.syntax io.unix.files ;
IN: unix.statfs.macosx
: MNT_RDONLY HEX: 00000001 ; inline
@ -116,50 +116,3 @@ C-STRUCT: statfs64
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ;
TUPLE: macosx-file-system-info < file-system-info
block-size io-size blocks blocks-free blocks-available files
files-free file-system-id owner type-id flags filesystem-subtype ;
M: macosx file-systems ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error
[ *void* ] dip
"statfs64" heap-size [ * memory>byte-array ] keep group
[ >file-system-info ] map ;
M: macosx >file-system-info ( byte-array -- file-system-info )
[ \ macosx-file-system-info new ] dip
{
[
[ statfs64-f_bavail ] [ statfs64-f_bsize ] bi *
>>free-space
]
[ statfs64-f_mntonname utf8 alien>string >>mount-point ]
[ statfs64-f_bsize >>block-size ]
[ statfs64-f_iosize >>io-size ]
[ statfs64-f_blocks >>blocks ]
[ statfs64-f_bfree >>blocks-free ]
[ statfs64-f_bavail >>blocks-available ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>files-free ]
[ statfs64-f_fsid >>file-system-id ]
[ statfs64-f_owner >>owner ]
[ statfs64-f_type >>type-id ]
[ statfs64-f_flags >>flags ]
[ statfs64-f_fssubtype >>filesystem-subtype ]
[
statfs64-f_fstypename utf8 alien>string
>>type
]
[
statfs64-f_mntfromname
utf8 alien>string >>device-name
]
} cleave ;
M: macosx file-system-info ( path -- file-system-info )
normalize-path
"statfs64" <c-object> tuck statfs64 io-error
>file-system-info ;

1
basis/unix/statfs/netbsd/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

78
basis/unix/statfs/netbsd/netbsd.factor
View File

@ -1,78 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel unix.stat math unix
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types unix.statfs io.files ;
IN: unix.statfs.netbsd
: _VFS_NAMELEN 32 ; inline
: _VFS_MNAMELEN 1024 ; inline
C-STRUCT: statvfs
{ "ulong" "f_flag" }
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "ulong" "f_iosize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsblkcnt_t" "f_bresvd" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "fsfilcnt_t" "f_fresvd" }
{ "uint64_t" "f_syncreads" }
{ "uint64_t" "f_syncwrites" }
{ "uint64_t" "f_asyncreads" }
{ "uint64_t" "f_asyncwrites" }
{ "fsid_t" "f_fsidx" }
{ "ulong" "f_fsid" }
{ "ulong" "f_namemax" }
{ "uid_t" "f_owner" }
{ { "uint32_t" 4 } "f_spare" }
{ { "char" _VFS_NAMELEN } "f_fstypename" }
{ { "char" _VFS_MNAMELEN } "f_mntonname" }
{ { "char" _VFS_MNAMELEN } "f_mntfromname" } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
TUPLE: netbsd-file-system-info < file-system-info
flag bsize frsize io-size
blocks blocks-free blocks-available blocks-reserved
files ffree sync-reads sync-writes async-reads async-writes
fsidx fsid namemax owner spare fstype mnotonname mntfromname
file-system-type-name mount-from ;
M: netbsd >file-system-info ( byte-array -- netbsd-file-system-info )
[ \ netbsd-file-system-info new ] dip
{
[
[ statvfs-f_bsize ]
[ statvfs-f_bavail ] bi * >>free-space
]
[ statvfs-f_flag >>flag ]
[ statvfs-f_bsize >>bsize ]
[ statvfs-f_frsize >>frsize ]
[ statvfs-f_iosize >>io-size ]
[ statvfs-f_blocks >>blocks ]
[ statvfs-f_bfree >>blocks-free ]
[ statvfs-f_favail >>blocks-available ]
[ statvfs-f_fresvd >>blocks-reserved ]
[ statvfs-f_files >>files ]
[ statvfs-f_ffree >>ffree ]
[ statvfs-f_syncreads >>sync-reads ]
[ statvfs-f_syncwrites >>sync-writes ]
[ statvfs-f_asyncreads >>async-reads ]
[ statvfs-f_asyncwrites >>async-writes ]
[ statvfs-f_fsidx >>fsidx ]
[ statvfs-f_namemax >>namemax ]
[ statvfs-f_owner >>owner ]
[ statvfs-f_spare >>spare ]
[ statvfs-f_fstypename utf8 alien>string >>file-system-type-name ]
[ statvfs-f_mntonname utf8 alien>string >>mount-point ]
[ statvfs-f_mntfromname utf8 alien>string >>mount-from ]
} cleave ;
M: netbsd file-system-info
normalize-path "statvfs" <c-object> tuck statvfs io-error
>file-system-info ;

26
basis/unix/statfs/openbsd/32/32.factor
View File

@ -1,26 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel unix ;
IN: unix.statfs.openbsd.32
: MFSNAMELEN 16 ; inline
: MNAMELEN 90 ; inline
C-STRUCT: statfs
{ "u_int32_t" "f_flags" }
{ "int32_t" "f_bsize" }
{ "u_int32_t" "f_iosize" }
{ "u_int32_t" "f_blocks" }
{ "u_int32_t" "f_bfree" }
{ "int32_t" "f_bavail" }
{ "u_int32_t" "f_files" }
{ "u_int32_t" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "uid_t" "f_owner" }
{ "u_int32_t" "f_syncwrites" }
{ "u_int32_t" "f_asyncwrites" }
{ "u_int32_t" "f_ctime" }
{ { "u_int32_t" 3 } "f_spare" }
{ { "char" MFSNAMELEN } "f_fstypename" }
{ { "char" MNAMELEN } "f_mntonname" }
{ { "char" MNAMELEN } "f_mntfromname" } ;

1
basis/unix/statfs/openbsd/32/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

32
basis/unix/statfs/openbsd/64/64.factor
View File

@ -1,32 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax unix ;
IN: unix.statfs.openbsd.64
: MFSNAMELEN 16 ; inline
: MNAMELEN 90 ; inline
C-STRUCT: statfss
{ "u_int32_t" "f_flags" }
{ "u_int32_t" "f_bsize" }
{ "u_int32_t" "f_iosize" }
{ "u_int64_t" "f_blocks" }
{ "u_int64_t" "f_bfree" }
{ "int64_t" "f_bavail" }
{ "u_int64_t" "f_files" }
{ "u_int64_t" "f_ffree" }
{ "int64_t" "f_favail" }
{ "u_int64_t" "f_syncwrites" }
{ "u_int64_t" "f_syncreads" }
{ "u_int64_t" "f_asyncwrites" }
{ "u_int64_t" "f_asyncreads" }
{ "fsid_t" "f_fsid" }
{ "u_int32_t" "f_namemax" }
{ "uid_t" "f_owner" }
{ "u_int32_t" "f_ctime" }
{ { "u_int32_t" 3 } " f_spare" }
{ { "char" MFSNAMELEN } "f_fstypename" }
{ { "char" MNAMELEN } "f_mntonname" }
{ { "char" MNAMELEN } "f_mntfromname" }
{ { "char" 512 } "mount_info" } ;
! { "mount_info" "mount_info" } ;

1
basis/unix/statfs/openbsd/64/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

1
basis/unix/statfs/openbsd/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

74
basis/unix/statfs/openbsd/openbsd.factor
View File

@ -1,53 +1,33 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax accessors combinators kernel
unix.types math system io.backend alien.c-types unix
unix.statfs io.files ;
USING: alien.syntax ;
IN: unix.statfs.openbsd
C-STRUCT: statvfs
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "ulong" "f_fsid" }
{ "ulong" "f_flag" }
{ "ulong" "f_namemax" } ;
: MFSNAMELEN 16 ; inline
: MNAMELEN 90 ; inline
: ST_RDONLY 1 ; inline
: ST_NOSUID 2 ; inline
C-STRUCT: statfs
{ "u_int32_t" "f_flags" }
{ "u_int32_t" "f_bsize" }
{ "u_int32_t" "f_iosize" }
{ "u_int64_t" "f_blocks" }
{ "u_int64_t" "f_bfree" }
{ "int64_t" "f_bavail" }
{ "u_int64_t" "f_files" }
{ "u_int64_t" "f_ffree" }
{ "int64_t" "f_favail" }
{ "u_int64_t" "f_syncwrites" }
{ "u_int64_t" "f_syncreads" }
{ "u_int64_t" "f_asyncwrites" }
{ "u_int64_t" "f_asyncreads" }
{ "fsid_t" "f_fsid" }
{ "u_int32_t" "f_namemax" }
{ "uid_t" "f_owner" }
{ "u_int32_t" "f_ctime" }
{ { "u_int32_t" 3 } "f_spare" }
{ { "char" MFSNAMELEN } "f_fstypename" }
{ { "char" MNAMELEN } "f_mntonname" }
{ { "char" MNAMELEN } "f_mntfromname" } ;
! { "mount_info" "mount_info" } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
TUPLE: openbsd-file-system-info < file-system-info
bsize frsize blocks bfree bavail files ffree favail
fsid flag namemax ;
M: openbsd >file-system-info ( struct -- statfs )
[ \ openbsd-file-system-info new ] dip
{
[
[ statvfs-f_bsize ]
[ statvfs-f_bavail ] bi * >>free-space
]
[ statvfs-f_bsize >>bsize ]
[ statvfs-f_frsize >>frsize ]
[ statvfs-f_blocks >>blocks ]
[ statvfs-f_bfree >>bfree ]
[ statvfs-f_bavail >>bavail ]
[ statvfs-f_files >>files ]
[ statvfs-f_ffree >>ffree ]
[ statvfs-f_favail >>favail ]
[ statvfs-f_fsid >>fsid ]
[ statvfs-f_flag >>flag ]
[ statvfs-f_namemax >>namemax ]
} cleave ;
M: openbsd file-system-info ( path -- byte-array )
normalize-path
"statvfs" <c-object> tuck statvfs io-error
>file-system-info ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ;

4
basis/unix/statfs/statfs.factor
View File

@ -4,12 +4,10 @@ USING: sequences system vocabs.loader combinators accessors
kernel math.order sorting ;
IN: unix.statfs
HOOK: >file-system-info os ( struct -- statfs )
os {
{ linux [ "unix.statfs.linux" require ] }
{ macosx [ "unix.statfs.macosx" require ] }
{ freebsd [ "unix.statfs.freebsd" require ] }
{ netbsd [ "unix.statfs.netbsd" require ] }
{ openbsd [ "unix.statfs.openbsd" require ] }
{ netbsd [ ] }
} case

1
basis/unix/statvfs/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/unix/statvfs/freebsd/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

23
basis/unix/statvfs/freebsd/freebsd.factor Normal file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
IN: unix.statvfs.freebsd
C-STRUCT: statvfs
{ "fsblkcnt_t" "f_bavail" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsfilcnt_t" "f_favail" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_files" }
{ "ulong" "f_bsize" }
{ "ulong" "f_flag" }
{ "ulong" "f_frsize" }
{ "ulong" "f_fsid" }
{ "ulong" "f_namemax" } ;
! Flags
: ST_RDONLY HEX: 1 ; inline ! Read-only file system
: ST_NOSUID HEX: 2 ; inline ! Does not honor setuid/setgid
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;

1
basis/unix/statvfs/freebsd/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/unix/statvfs/linux/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

31
basis/unix/statvfs/linux/linux.factor Normal file
View File

@ -0,0 +1,31 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
IN: unix.statvfs.linux
C-STRUCT: statvfs64
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "__fsblkcnt64_t" "f_blocks" }
{ "__fsblkcnt64_t" "f_bfree" }
{ "__fsblkcnt64_t" "f_bavail" }
{ "__fsfilcnt64_t" "f_files" }
{ "__fsfilcnt64_t" "f_ffree" }
{ "__fsfilcnt64_t" "f_favail" }
{ "ulong" "f_fsid" }
{ "ulong" "f_flag" }
{ "ulong" "f_namemax" }
{ { "int" 6 } "__f_spare" } ;
FUNCTION: int statvfs64 ( char* path, statvfs64* buf ) ;
: ST_RDONLY 1 ; inline ! Mount read-only.
: ST_NOSUID 2 ; inline ! Ignore suid and sgid bits.
: ST_NODEV 4 ; inline ! Disallow access to device special files.
: ST_NOEXEC 8 ; inline ! Disallow program execution.
: ST_SYNCHRONOUS 16 ; inline ! Writes are synced at once.
: ST_MANDLOCK 64 ; inline ! Allow mandatory locks on an FS.
: ST_WRITE 128 ; inline ! Write on file/directory/symlink.
: ST_APPEND 256 ; inline ! Append-only file.
: ST_IMMUTABLE 512 ; inline ! Immutable file.
: ST_NOATIME 1024 ; inline ! Do not update access times.

1
basis/unix/statvfs/linux/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/unix/statvfs/macosx/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

23
basis/unix/statvfs/macosx/macosx.factor Normal file
View File

@ -0,0 +1,23 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
IN: unix.statvfs.macosx
C-STRUCT: statvfs
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "ulong" "f_fsid" }
{ "ulong" "f_flag" }
{ "ulong" "f_namemax" } ;
! Flags
: ST_RDONLY HEX: 1 ; inline ! Read-only file system
: ST_NOSUID HEX: 2 ; inline ! Does not honor setuid/setgid
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;

1
basis/unix/statvfs/macosx/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/unix/statvfs/netbsd/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

35
basis/unix/statvfs/netbsd/netbsd.factor Normal file
View File

@ -0,0 +1,35 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
IN: unix.statvfs.netbsd
: _VFS_NAMELEN 32 ; inline
: _VFS_MNAMELEN 1024 ; inline
C-STRUCT: statvfs
{ "ulong" "f_flag" }
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "ulong" "f_iosize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsblkcnt_t" "f_bresvd" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "fsfilcnt_t" "f_fresvd" }
{ "uint64_t" "f_syncreads" }
{ "uint64_t" "f_syncwrites" }
{ "uint64_t" "f_asyncreads" }
{ "uint64_t" "f_asyncwrites" }
{ "fsid_t" "f_fsidx" }
{ "ulong" "f_fsid" }
{ "ulong" "f_namemax" }
{ "uid_t" "f_owner" }
{ { "uint32_t" 4 } "f_spare" }
{ { "char" _VFS_NAMELEN } "f_fstypename" }
{ { "char" _VFS_MNAMELEN } "f_mntonname" }
{ { "char" _VFS_MNAMELEN } "f_mntfromname" } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;

1
basis/unix/statvfs/netbsd/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

1
basis/unix/statvfs/openbsd/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

22
basis/unix/statvfs/openbsd/openbsd.factor Normal file
View File

@ -0,0 +1,22 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
IN: unix.statvfs.openbsd
C-STRUCT: statvfs
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "ulong" "f_fsid" }
{ "ulong" "f_flag" }
{ "ulong" "f_namemax" } ;
: ST_RDONLY 1 ; inline
: ST_NOSUID 2 ; inline
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;

1
basis/unix/statvfs/openbsd/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

12
basis/unix/statvfs/statvfs.factor Normal file
View File

@ -0,0 +1,12 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators system vocabs.loader ;
IN: unix.statvfs
os {
{ linux [ "unix.statvfs.linux" require ] }
{ macosx [ "unix.statvfs.macosx" require ] }
{ freebsd [ "unix.statvfs.freebsd" require ] }
{ netbsd [ "unix.statvfs.netbsd" require ] }
{ openbsd [ "unix.statvfs.openbsd" require ] }
} case

1
basis/unix/statvfs/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

26
basis/xmode/utilities/utilities.factor
View File

@ -1,30 +1,30 @@
USING: accessors sequences assocs kernel quotations namespaces
xml.data xml.utilities combinators macros parser lexer words ;
xml.data xml.utilities combinators macros parser lexer words fry ;
IN: xmode.utilities
: implies >r not r> or ; inline
: implies [ not ] dip or ; inline
: child-tags ( tag -- seq ) children>> [ tag? ] filter ;
: map-find ( seq quot -- result elt )
f -rot
[ nip ] swap [ dup ] 3compose find
>r [ drop f ] unless r> ; inline
'[ nip @ dup ] find
[ [ drop f ] unless ] dip ; inline
: tag-init-form ( spec -- quot )
{
{ [ dup quotation? ] [ [ object get tag get ] prepose ] }
{ [ dup length 2 = ] [
first2 [
>r >r tag get children>string
r> [ execute ] when* object get r> execute
] 2curry
first2 '[
tag get children>string
_ [ execute ] when* object get _ execute
]
] }
{ [ dup length 3 = ] [
first3 [
>r >r tag get at
r> [ execute ] when* object get r> execute
] 3curry
first3 '[
_ tag get at
_ [ execute ] when* object get _ execute
]
] }
} cond ;
@ -36,7 +36,7 @@ MACRO: (init-from-tag) ( specs -- )
[ with-tag-initializer ] curry ;
: init-from-tag ( tag tuple specs -- tuple )
over >r (init-from-tag) r> ; inline
over [ (init-from-tag) ] dip ; inline
SYMBOL: tag-handlers
SYMBOL: tag-handler-word

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

@ -187,7 +187,8 @@ SYMBOL: +unknown+
HOOK: file-systems os ( -- array )
TUPLE: file-system-info device-name mount-point type free-space ;
TUPLE: file-system-info device-name mount-point type
available-space free-space used-space total-space ;
HOOK: file-system-info os ( path -- file-system-info )

2
core/io/io.factor
View File

@ -65,7 +65,7 @@ SYMBOL: error-stream
: with-streams ( input output quot -- )
[ [ with-streams* ] 3curry ]
[ [ drop dispose dispose ] 3curry ] 3bi
[ drop [ [ dispose ] bi@ ] 2curry ] 3bi
[ ] cleanup ; inline
: tabular-output ( style quot -- )

13
core/kernel/kernel-docs.factor
View File

@ -578,18 +578,6 @@ HELP: prepose
{ compose prepose } related-words
HELP: 3compose
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes
"The following two lines are equivalent:"
{ $code
"3compose call"
"3append call"
}
"However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
} ;
HELP: dip
{ $values { "x" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
@ -814,7 +802,6 @@ ARTICLE: "compositional-combinators" "Compositional combinators"
{ $subsection 3curry }
{ $subsection with }
{ $subsection compose }
{ $subsection 3compose }
{ $subsection prepose }
"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;

3
core/kernel/kernel.factor
View File

@ -179,9 +179,6 @@ GENERIC: boa ( ... class -- tuple )
: prepose ( quot1 quot2 -- compose )
swap compose ; inline
: 3compose ( quot1 quot2 quot3 -- compose )
compose compose ; inline
! Booleans
: not ( obj -- ? ) [ f ] [ t ] if ; inline

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

@ -66,7 +66,7 @@ HELP: vocab-roots
{ $var-description "A sequence of pathname strings to search for vocabularies." } ;
HELP: add-vocab-root
{ $values { "path" "a pathname string" } }
{ $values { "root" "a pathname string" } }
{ $description "Adds a directory pathname to the list of vocabulary roots." }
{ $see-also "factor-roots" } ;

11
extra/benchmark/xml/xml.factor Normal file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.utf8 io.files kernel sequences xml ;
IN: benchmark.xml
: xml-benchmark ( -- )
"resource:basis/xmode/modes/" [
[ utf8 <file-reader> read-xml drop ] each
] with-directory-files ;
MAIN: xml-benchmark

15
extra/boids/boids.factor
View File

@ -25,7 +25,7 @@ USING: kernel
ui.render
multi-methods
multi-method-syntax
combinators.short-circuit.smart
combinators.short-circuit
processing.shapes
flatland ;
@ -86,7 +86,7 @@ TUPLE: <separation> < <behaviour> { radius initial: 25 } ;
[ BEHAVIOUR view-angle>> in-view? ]
[ eq? not ]
}
&& ;
2&& ;
:: neighborhood ( SELF OTHERS BEHAVIOUR -- boids )
OTHERS [| OTHER | SELF OTHER BEHAVIOUR within-neighborhood? ] filter ;
@ -154,7 +154,7 @@ M: <boids-gadget> ungraft* ( <boids-gadget> -- ) t >>paused drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
:: iterate-system ( BOIDS-GADGET -- )
[let | SKY [ BOIDS-GADGET gadget->sky ]
BOIDS [ BOIDS-GADGET boids>> ]
@ -183,11 +183,14 @@ M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
map
BOIDS-GADGET (>>boids)
BOIDS-GADGET (>>boids) ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
origin get
[ BOIDS-GADGET boids>> [ draw-boid ] each ]
with-translation ] ;
with-translation ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -197,7 +200,7 @@ M:: <boids-gadget> draw-gadget* ( BOIDS-GADGET -- )
[
GADGET paused>>
[ f ]
[ GADGET relayout-1 25 milliseconds sleep t ]
[ GADGET iterate-system GADGET relayout-1 1 milliseconds sleep t ]
if
]
loop

2
extra/combinators/lib/lib.factor
View File

@ -142,7 +142,7 @@ MACRO: multikeep ( word out-indexes -- ... )
[ tuck 2slip ] dip while ; inline
: generate ( generator predicate -- obj )
[ dup ] swap [ dup [ nip ] unless not ] 3compose
'[ dup @ dup [ nip ] unless not ]
swap [ ] do-while ;
MACRO: predicates ( seq -- quot/f )

8
extra/inverse/inverse.factor
View File

@ -5,7 +5,8 @@ sequences assocs math arrays stack-checker effects generalizations
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors
combinators.short-circuit ;
combinators.short-circuit fry qualified ;
RENAME: _ fry => __
IN: inverse
TUPLE: fail ;
@ -46,7 +47,7 @@ M: no-inverse summary
dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
: swap-inverse ( math-inverse revquot -- revquot* quot )
next assure-constant rot second [ swap ] swap 3compose ;
next assure-constant rot second '[ @ swap @ ] ;
: pull-inverse ( math-inverse revquot const -- revquot* quot )
assure-constant rot first compose ;
@ -236,8 +237,7 @@ DEFER: _
] recover ; inline
: true-out ( quot effect -- quot' )
out>> [ ndrop ] curry
[ t ] 3compose ;
out>> '[ @ __ ndrop t ] ;
: false-recover ( effect -- quot )
in>> [ ndrop f ] curry [ recover-fail ] curry ;

55
extra/irc/gitbot/gitbot.factor Normal file
View File

@ -0,0 +1,55 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry irc.client irc.client.private kernel namespaces
sequences threads io.encodings.8-bit io.launcher io splitting
make mason.common mason.updates calendar math alarms ;
IN: irc.gitbot
: bot-profile ( -- obj )
"irc.freenode.org" 6667 "jackass" f <irc-profile> ;
: bot-channel ( -- seq ) "#concatenative" ;
GENERIC: handle-message ( msg -- )
M: object handle-message drop ;
: bot-loop ( chat -- )
dup hear handle-message bot-loop ;
: start-bot ( -- chat )
bot-profile <irc-client>
[ connect-irc ]
[
[ bot-channel <irc-channel-chat> dup ] dip
'[ _ [ _ attach-chat ] [ bot-loop ] bi ]
"GitBot" spawn drop
] bi ;
: git-log ( from to -- lines )
[
"git-log" ,
"--no-merges" ,
"--pretty=format:%h %an: %s" ,
".." swap 3append ,
] { } make
latin1 [ input-stream get lines ] with-process-reader ;
: updates ( from to -- lines )
git-log reverse
dup length 4 > [ 4 head "... and more" suffix ] when ;
: report-updates ( from to chat -- )
[ updates ] dip
[ 1 seconds sleep ] swap
'[ _ speak ] interleave ;
: check-for-updates ( chat -- )
[ git-id git-pull-cmd short-running-process git-id ] dip
report-updates ;
: bot ( -- )
start-bot
'[ _ check-for-updates ] 5 minutes every drop ;
MAIN: bot

1
extra/line-art/authors.txt
View File

@ -1 +0,0 @@
Joe Groff

1
extra/line-art/summary.txt
View File

@ -1 +0,0 @@
Stanford Bunny rendered with cartoon-style lines instead of shading

3
extra/line-art/tags.txt
View File

@ -1,3 +0,0 @@
demos
opengl
glsl

1
extra/math/blas/cblas/cblas.factor
View File

@ -5,6 +5,7 @@ IN: math.blas.cblas
{ [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
{ [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
{ [ os openbsd? ] [ "libcblas.so" "cdecl" add-library ] }
{ [ os freebsd? ] [ "libcblas.so" "cdecl" add-library ] }
[ "libblas.so" "cdecl" add-library ]
} cond >>

8
extra/sequences/lib/lib.factor
View File

@ -5,7 +5,7 @@ USING: combinators.lib kernel sequences math namespaces make
assocs random sequences.private shuffle math.functions arrays
math.parser math.private sorting strings ascii macros assocs.lib
quotations hashtables math.order locals generalizations
math.ranges random ;
math.ranges random fry ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
@ -90,12 +90,8 @@ ERROR: element-not-found ;
dupd find over [ element-not-found ] unless
>r cut rest r> swap ; inline
: (map-until) ( quot pred -- quot )
[ dup ] swap 3compose
[ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ;
: map-until ( seq quot pred -- newseq )
(map-until) { } make ;
'[ [ @ dup @ [ drop t ] [ , f ] if ] find 2drop ] { } make ;
: take-while ( seq quot -- newseq )
[ not ] compose

1
vm/os-unix.h
View File

@ -23,6 +23,7 @@ typedef char F_SYMBOL;
#define STRNCMP strncmp
#define STRDUP strdup
#define FIXNUM_FORMAT "%ld"
#define CELL_FORMAT "%lu"
#define CELL_HEX_FORMAT "%lx"

8
vm/os-windows.h
View File

@ -20,13 +20,13 @@ typedef wchar_t F_CHAR;
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
#define FIXNUM_FORMAT "%Id"
#define CELL_FORMAT "%lu"
#define CELL_HEX_FORMAT "%Ix"
#ifdef WIN64
#define CELL_FORMAT "%Iu"
#define CELL_HEX_FORMAT "%Ix"
#define CELL_HEX_PAD_FORMAT "%016Ix"
#else
#define CELL_FORMAT "%lu"
#define CELL_HEX_FORMAT "%lx"
#define CELL_HEX_PAD_FORMAT "%08lx"
#endif

2
vm/utilities.c
View File

@ -44,7 +44,7 @@ void print_cell_hex_pad(CELL x)
void print_fixnum(F_FIXNUM x)
{
printf(CELL_FORMAT,x);
printf(FIXNUM_FORMAT,x);
}
CELL read_cell_hex(void)