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

Merge branch 'master' into new_codegen

db4
Slava Pestov 2008-10-23 05:29:09 -05:00
parent 95eb0f696b d922afa0a4
commit 1c7d9c1066
15 changed files with 225 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,7 +5,7 @@ io.windows kernel math splitting fry alien.strings
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces make words symbols system
io.ports destructors accessors math.bitwise continuations
windows.errors arrays ;
windows.errors arrays byte-arrays ;
IN: io.windows.files
: open-file ( path access-mode create-mode flags -- handle )
@ -246,20 +246,57 @@ M: winnt file-info ( path -- info )
M: winnt link-info ( path -- info )
file-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+
"DWORD" <c-object> "DWORD" <c-object> "DWORD" <c-object>
MAX_PATH 1+ <byte-array>
MAX_PATH 1+
[ GetVolumeInformation win32-error=0/f ] 2keep drop
utf16n alien>string ;
: file-system-space ( normalized-path -- free-space total-bytes total-free-bytes )
"ULARGE_INTEGER" <c-object>
"ULARGE_INTEGER" <c-object>
"ULARGE_INTEGER" <c-object>
[ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
M: winnt file-system-info ( path -- file-system-info )
normalize-path
dup file-info directory? [ parent-directory ] unless
"ULARGE_INTEGER" <c-object>
"ULARGE_INTEGER" <c-object>
"ULARGE_INTEGER" <c-object>
[ GetDiskFreeSpaceEx win32-error=0/f ] 3keep
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
swap *ulonglong >>free-space ;
swap *ulonglong >>free-space
swap >>type
swap >>name ;
: find-first-volume ( word -- string handle )
MAX_PATH 1+ <byte-array> dup length
dupd
FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ;
: find-next-volume ( handle -- string )
MAX_PATH 1+ <byte-array> dup length
[ FindNextVolume win32-error=0/f ] 2keep drop
utf16n alien>string ;
: mounted ( -- array )
find-first-volume
[
'[
[ _ find-next-volume dup ]
[ ]
[ drop ] produce
swap prefix
]
] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
: file-times ( path -- timestamp timestamp timestamp )
[

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

@ -31,12 +31,13 @@ M: winnt root-directory? ( path -- ? )
ERROR: not-absolute-path ;
: root-directory ( string -- string' )
M: winnt root-directory ( string -- string' )
unicode-prefix ?head drop
dup {
[ length 2 >= ]
[ second CHAR: : = ]
[ first Letter? ]
} 1&& [ 2 head ] [ not-absolute-path ] if ;
} 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
: prepend-prefix ( string -- string' )
dup unicode-prefix head? [

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

@ -23,7 +23,7 @@ C-STRUCT: statvfs
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;
TUPLE: freebsd-file-system-info < file-system-info
bavail bfree blocks favail ffree ffiles
bavail bfree blocks favail ffree files
bsize flag frsize fsid namemax ;
M: freebsd >file-system-info ( struct -- statfs )

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

@ -1,8 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel io.files unix.stat
USING: alien.c-types combinators kernel unix.stat
math accessors system unix io.backend layouts vocabs.loader
alien.syntax ;
alien.syntax unix.statfs io.files ;
IN: unix.statfs.linux
C-STRUCT: statfs

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

@ -1,10 +1,43 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types combinators kernel io.files unix.stat
math accessors system unix io.backend layouts vocabs.loader ;
math accessors system unix io.backend layouts vocabs.loader
sequences csv io.streams.string io.encodings.utf8 namespaces
unix.statfs io.files ;
IN: unix.statfs.linux
cell-bits {
{ 32 [ "unix.statfs.linux.32" require ] }
{ 64 [ "unix.statfs.linux.64" require ] }
} case
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 mounted
parse-mtab [
[ mount-point>> file-system-info ] keep
{
[ file-system-name>> >>device-name ]
[ mount-point>> >>name ]
[ type>> >>type ]
} cleave
] map ;

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

@ -120,13 +120,13 @@ 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 flags filesystem-subtype
file-system-type-name mount-from ;
files-free file-system-id owner type-id flags filesystem-subtype ;
M: macosx mounted* ( -- array )
M: macosx mounted ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error
[ *void* ] dip
"statfs64" heap-size [ * memory>byte-array ] keep group ;
"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
@ -135,7 +135,7 @@ M: macosx >file-system-info ( byte-array -- file-system-info )
[ statfs64-f_bavail ] [ statfs64-f_bsize ] bi *
>>free-space
]
[ statfs64-f_mntonname utf8 alien>string >>mount-on ]
[ statfs64-f_mntonname utf8 alien>string >>name ]
[ statfs64-f_bsize >>block-size ]
[ statfs64-f_iosize >>io-size ]
@ -146,16 +146,16 @@ M: macosx >file-system-info ( byte-array -- file-system-info )
[ statfs64-f_ffree >>files-free ]
[ statfs64-f_fsid >>file-system-id ]
[ statfs64-f_owner >>owner ]
[ statfs64-f_type >>type ]
[ statfs64-f_type >>type-id ]
[ statfs64-f_flags >>flags ]
[ statfs64-f_fssubtype >>filesystem-subtype ]
[
statfs64-f_fstypename utf8 alien>string
>>file-system-type-name
>>type
]
[
statfs64-f_mntfromname
utf8 alien>string >>mount-from
utf8 alien>string >>device-name
]
} cleave ;

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

@ -1,8 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel io.files unix.stat math unix
USING: alien.syntax kernel unix.stat math unix
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types ;
io.encodings.utf8 alien.strings unix.types unix.statfs io.files ;
IN: unix.statfs.netbsd
: _VFS_NAMELEN 32 ; inline
@ -69,7 +69,7 @@ M: netbsd >file-system-info ( byte-array -- netbsd-file-system-info )
[ 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-on ]
[ statvfs-f_mntonname utf8 alien>string >>name ]
[ statvfs-f_mntfromname utf8 alien>string >>mount-from ]
} cleave ;

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

@ -4,25 +4,11 @@ USING: sequences system vocabs.loader combinators accessors
kernel math.order sorting ;
IN: unix.statfs
TUPLE: mounted block-size io-size blocks blocks-free
blocks-available files files-free file-system-id owner type
flags filesystem-subtype file-system-type-name mount-on
mount-from ;
HOOK: mounted* os ( -- array )
HOOK: mounted-struct>mounted os ( byte-array -- mounted )
TUPLE: file-system-info root-directory total-free-size total-size ;
HOOK: >file-system-info os ( struct -- statfs )
: mounted ( -- array )
mounted* [ mounted-struct>mounted ] map ;
: mounted-drive ( path -- mounted/f )
mounted
[ [ mount-on>> ] bi@ <=> ] sort <reversed>
[ mount-on>> head? ] with find nip ;
HOOK: mounted os ( -- array )
os {
{ linux [ "unix.statfs.linux" require ] }

8
basis/unix/types/macosx/macosx.factor
View File

@ -1,19 +1,13 @@
USING: alien.syntax ;
IN: unix.types
! Darwin 9.1.0 ppc
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Darwin 9.1.0
TYPEDEF: ushort __uint16_t
TYPEDEF: uint __uint32_t
TYPEDEF: int __int32_t
TYPEDEF: longlong __int64_t
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TYPEDEF: __int32_t dev_t
TYPEDEF: __uint32_t ino_t
TYPEDEF: __uint16_t mode_t

19
basis/unix/types/types.factor
View File

@ -2,15 +2,6 @@ USING: kernel system alien.syntax combinators vocabs.loader
system ;
IN: unix.types
TYPEDEF: void* caddr_t
TYPEDEF: uint in_addr_t
TYPEDEF: uint socklen_t
TYPEDEF: __uint64_t fsblkcnt_t
TYPEDEF: fsblkcnt_t __fsblkcnt_t
TYPEDEF: __uint64_t fsfilcnt_t
TYPEDEF: fsfilcnt_t __fsfilcnt_t
TYPEDEF: char int8_t
TYPEDEF: short int16_t
TYPEDEF: int int32_t
@ -36,6 +27,16 @@ TYPEDEF: ushort __uint16_t
TYPEDEF: uint __uint32_t
TYPEDEF: ulonglong __uint64_t
TYPEDEF: void* caddr_t
TYPEDEF: uint in_addr_t
TYPEDEF: uint socklen_t
TYPEDEF: __uint64_t fsblkcnt_t
TYPEDEF: fsblkcnt_t __fsblkcnt_t
TYPEDEF: __uint64_t fsfilcnt_t
TYPEDEF: fsfilcnt_t __fsfilcnt_t
TYPEDEF: __uint64_t rlim_t
TYPEDEF: uint32_t id_t
os {
{ linux [ "unix.types.linux" require ] }

7
basis/unix/unix.factor
View File

@ -116,6 +116,13 @@ FUNCTION: passwd* getpwnam ( char* login ) ;
FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsize, passwd** result ) ;
FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
FUNCTION: int getgrouplist ( char* name, int basegid, int* groups, int* ngroups ) ;
FUNCTION: int getrlimit ( int resource, rlimit* rlp ) ;
FUNCTION: int setrlimit ( int resource, rlimit* rlp ) ;
FUNCTION: int getpriority ( int which, id_t who ) ;
FUNCTION: int setpriority ( int which, id_t who, int prio ) ;
FUNCTION: int getrusage ( int who, rusage* r_usage ) ;
FUNCTION: group* getgrent ;
FUNCTION: int gethostname ( char* name, int len ) ;

44
basis/windows/kernel32/kernel32.factor
View File

@ -812,22 +812,42 @@ FUNCTION: HANDLE FindFirstFileW ( LPCTSTR lpFileName, LPWIN32_FIND_DATA lpFindFi
ALIAS: FindFirstFile FindFirstFileW
! FUNCTION: FindFirstVolumeA
! FUNCTION: FindFirstVolumeMountPointA
! FUNCTION: FindFirstVolumeMountPointW
! FUNCTION: FindFirstVolumeW
FUNCTION: HANDLE FindFirstVolumeMountPointW (
LPTSTR lpszRootPathName,
LPTSTR lpszVolumeMountPoint,
DWORD cchBufferLength
) ;
ALIAS: FindFirstVolumeMountPoint FindFirstVolumeMountPointW
FUNCTION: HANDLE FindFirstVolumeW ( LPTSTR lpszVolumeName, DWORD cchBufferLength ) ;
ALIAS: FindFirstVolume FindFirstVolumeW
FUNCTION: BOOL FindNextChangeNotification ( HANDLE hChangeHandle ) ;
! FUNCTION: FindNextFileA
FUNCTION: BOOL FindNextFileW ( HANDLE hFindFile, LPWIN32_FIND_DATA lpFindFileData ) ;
ALIAS: FindNextFile FindNextFileW
! FUNCTION: FindNextVolumeA
! FUNCTION: FindNextVolumeMountPointA
! FUNCTION: FindNextVolumeMountPointW
! FUNCTION: FindNextVolumeW
FUNCTION: BOOL FindNextVolumeMountPointW (
HANDLE hFindVolumeMountPoint,
LPTSTR lpszVolumeMountPoint,
DWORD cchBufferLength
) ;
ALIAS: FindNextVolumeMountPoint FindNextVolumeMountPointW
FUNCTION: BOOL FindNextVolumeW ( HANDLE hFindVolume, LPTSTR lpszVolumeName, DWORD cchBufferLength ) ;
ALIAS: FindNextVolume FindNextVolumeW
! FUNCTION: FindResourceA
! FUNCTION: FindResourceExA
! FUNCTION: FindResourceExW
! FUNCTION: FindResourceW
! FUNCTION: FindVolumeClose
! FUNCTION: FindVolumeMountPointClose
FUNCTION: BOOL FindVolumeClose ( HANDLE hFindVolume ) ;
FUNCTION: BOOL FindVolumeMountPointClose ( HANDLE hFindVolumeMountPoint ) ;
! FUNCTION: FlushConsoleInputBuffer
! FUNCTION: FlushFileBuffers
! FUNCTION: FlushInstructionCache
@ -1094,7 +1114,17 @@ FUNCTION: DWORD GetVersion ( ) ;
FUNCTION: BOOL GetVersionExW ( LPOSVERSIONINFO lpVersionInfo ) ;
ALIAS: GetVersionEx GetVersionExW
! FUNCTION: GetVolumeInformationA
! FUNCTION: GetVolumeInformationW
FUNCTION: BOOL GetVolumeInformationW (
LPCTSTR lpRootPathName,
LPTSTR lpVolumNameBuffer,
DWORD nVolumeNameSize,
LPDWORD lpVolumeSerialNumber,
LPDWORD lpMaximumComponentLength,
LPDWORD lpFileSystemFlags,
LPCTSTR lpFileSystemNameBuffer,
DWORD nFileSystemNameSize
) ;
ALIAS: GetVolumeInformation GetVolumeInformationW
! FUNCTION: GetVolumeNameForVolumeMountPointA
! FUNCTION: GetVolumeNameForVolumeMountPointW
! FUNCTION: GetVolumePathNameA

5
core/classes/tuple/tuple.factor
View File

@ -93,9 +93,8 @@ ERROR: bad-superclass class ;
: tuple-instance? ( object class echelon -- ? )
#! 4 slot == superclasses>>
rot dup tuple? [
layout-of 4 slot
2dup 1 slot fixnum<
[ array-nth eq? ] [ 3drop f ] if
layout-of 4 slot { array } declare
2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if
] [ 3drop f ] if ; inline
: define-tuple-predicate ( class -- )

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

@ -184,7 +184,7 @@ SYMBOL: +unknown+
! File-system
TUPLE: file-system-info mount-on free-space ;
TUPLE: file-system-info device-name name type free-space ;
HOOK: file-system-info os ( path -- file-system-info )

70
extra/dns/resolver/resolver.factor Normal file
View File

@ -0,0 +1,70 @@
USING: kernel accessors namespaces continuations
io io.sockets io.binary io.timeouts io.encodings.binary
destructors
locals strings sequences random prettyprint calendar dns dns.misc ;
IN: dns.resolver
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: send-receive-udp ( BA SERVER -- ba )
T{ inet4 f f 0 } <datagram>
T{ duration { second 3 } } over set-timeout
[| SOCKET | BA SERVER SOCKET send SOCKET receive drop ]
with-disposal ;
:: send-receive-tcp ( BA SERVER -- ba )
[let | BA [ BA length 2 >be BA append ] |
SERVER binary
[
T{ duration { second 3 } } input-stream get set-timeout
BA write flush 2 read be> read
]
with-client ] ;
:: send-receive-server ( BA SERVER -- msg )
[let | RESULT [ BA SERVER send-receive-udp parse-message ] |
RESULT tc>> 1 =
[ BA SERVER send-receive-tcp parse-message ]
[ RESULT ]
if ] ;
: >dns-inet4 ( obj -- inet4 ) dup string? [ 53 <inet4> ] [ ] if ;
:: send-receive-servers ( BA SERVERS -- msg )
SERVERS empty? [ "send-receive-servers: servers list empty" throw ] when
[let | SERVER [ SERVERS random >dns-inet4 ] |
! if this throws an error ...
[ BA SERVER send-receive-server ]
! we try with the other servers...
[ drop BA SERVER SERVERS remove send-receive-servers ]
recover ] ;
:: ask-servers ( MSG SERVERS -- msg )
MSG message->ba SERVERS send-receive-servers ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: fully-qualified ( name -- name ) dup "." tail? [ ] [ "." append ] if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: dns-servers ( -- seq )
\ dns-servers get
[ ]
[ resolv-conf-servers \ dns-servers set dns-servers ]
if* ;
! : dns-server ( -- server ) dns-servers random ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: dns-ip ( name -- ips )
fully-qualified
[let | MSG [ A IN query boa query->message dns-servers ask-servers ] |
MSG rcode>> NO-ERROR =
[ MSG answer-section>> [ type>> A = ] filter [ rdata>> ] map ]
[ "dns-ip: rcode = " MSG rcode>> unparse append throw ]
if ] ;