Merge branch 'master' into new_codegen

basis/io/windows/files/files.factor

@@ -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
+    normalize-path root-directory
-    dup file-info directory? [ parent-directory ] unless
+    dup [ file-system-type ] [ file-system-space ] bi
-    "ULARGE_INTEGER" <c-object>
-    "ULARGE_INTEGER" <c-object>
-    "ULARGE_INTEGER" <c-object>
-    [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep
     \ 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 )
     [

basis/io/windows/nt/files/files.factor

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

basis/unix/statfs/freebsd/freebsd.factor

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

basis/unix/statfs/linux/32/32.factor

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

basis/unix/statfs/linux/linux.factor

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

basis/unix/statfs/macosx/macosx.factor

@@ -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
+files-free file-system-id owner type-id flags filesystem-subtype ;
-file-system-type-name mount-from ;
 
-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 ;
 

basis/unix/statfs/netbsd/netbsd.factor

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

basis/unix/statfs/statfs.factor

@@ -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 )
+HOOK: mounted os ( -- array )
-    mounted* [ mounted-struct>mounted ] map ;
-
-: mounted-drive ( path -- mounted/f )
-    mounted
-    [ [ mount-on>> ] bi@ <=> ] sort <reversed>
-    [ mount-on>> head? ] with find nip ;
 
 os {
     { linux   [ "unix.statfs.linux"   require ] }

basis/unix/types/macosx/macosx.factor

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

basis/unix/types/types.factor

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

basis/unix/unix.factor

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

basis/windows/kernel32/kernel32.factor

@@ -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: BOOL FindVolumeClose ( HANDLE hFindVolume ) ;
-! FUNCTION: FindVolumeMountPointClose
+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

core/classes/tuple/tuple.factor

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

core/io/files/files.factor

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

extra/dns/resolver/resolver.factor

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