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

basis/calendar/unix/unix.factor

@@ -4,13 +4,19 @@ USING: alien alien.c-types alien.syntax arrays calendar
 kernel math unix unix.time namespaces system ;
 IN: calendar.unix
 
-: timeval>unix-time ( timeval -- timestamp )
+: timeval>seconds ( timeval -- seconds )
     [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
-    time+ since-1970 ;
+    time+ ;
 
-: timespec>unix-time ( timeval -- timestamp )
+: timeval>unix-time ( timeval -- timestamp )
+    timeval>seconds since-1970 ;
+
+: timespec>seconds ( timespec -- seconds )
     [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
-    time+ since-1970 ;
+    time+ ;
+
+: timespec>unix-time ( timespec -- timestamp )
+    timespec>seconds since-1970 ;
 
 : get-time ( -- alien )
     f time <uint> localtime ;

basis/cocoa/messages/messages.factor

@@ -3,9 +3,8 @@
 USING: accessors alien alien.c-types alien.strings arrays assocs
 combinators compiler kernel math namespaces make parser
 prettyprint prettyprint.sections quotations sequences strings
-words cocoa.runtime io macros memoize debugger
+words cocoa.runtime io macros memoize debugger fry
-io.encodings.ascii effects compiler.generator libc libc.private
+io.encodings.ascii effects compiler.generator libc libc.private ;
-parser lexer init core-foundation ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
@@ -108,22 +107,34 @@ H{
     { "c" "char" }
     { "i" "int" }
     { "s" "short" }
-    { "l" "long" }
-    { "q" "longlong" }
     { "C" "uchar" }
     { "I" "uint" }
     { "S" "ushort" }
-    { "L" "ulong" }
-    { "Q" "ulonglong" }
     { "f" "float" }
     { "d" "double" }
     { "B" "bool" }
     { "v" "void" }
     { "*" "char*" }
+    { "?" "unknown_type" }
     { "@" "id" }
-    { "#" "id" }
+    { "#" "Class" }
     { ":" "SEL" }
-} objc>alien-types set-global
+}
+"ptrdiff_t" heap-size {
+    { 4 [ H{
+        { "l" "long" }
+        { "q" "longlong" }
+        { "L" "ulong" }
+        { "Q" "ulonglong" }
+    } ] }
+    { 8 [ H{
+        { "l" "long32" }
+        { "q" "long" }
+        { "L" "ulong32" }
+        { "Q" "ulong" }
+    } ] }
+} case
+assoc-union objc>alien-types set-global
 
 ! The transpose of the above map
 SYMBOL: alien>objc-types
@@ -132,16 +143,22 @@ objc>alien-types get [ swap ] assoc-map
 ! A hack...
 "ptrdiff_t" heap-size {
     { 4 [ H{
-        { "NSPoint" "{_NSPoint=ff}" }
+        { "NSPoint"    "{_NSPoint=ff}" }
-        { "NSRect" "{_NSRect=ffff}" }
+        { "NSRect"     "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
-        { "NSSize" "{_NSSize=ff}" }
+        { "NSSize"     "{_NSSize=ff}" }
-        { "NSRange" "{_NSRange=II}" }
+        { "NSRange"    "{_NSRange=II}" }
+        { "NSInteger"  "i" }
+        { "NSUInteger" "I" }
+        { "CGFloat"    "f" }
     } ] }
     { 8 [ H{
-        { "NSPoint" "{_NSPoint=dd}" }
+        { "NSPoint"    "{CGPoint=dd}" }
-        { "NSRect" "{_NSRect=dddd}" }
+        { "NSRect"     "{CGRect={CGPoint=dd}{CGSize=dd}}" }
-        { "NSSize" "{_NSSize=dd}" }
+        { "NSSize"     "{CGSize=dd}" }
-        { "NSRange" "{_NSRange=QQ}" }
+        { "NSRange"    "{_NSRange=QQ}" }
+        { "NSInteger"  "q" }
+        { "NSUInteger" "Q" }
+        { "CGFloat"    "d" }
     } ] }
 } case
 assoc-union alien>objc-types set-global
@@ -184,12 +201,23 @@ assoc-union alien>objc-types set-global
     swap method_getName sel_getName
     objc-methods get set-at ;
 
-: (register-objc-methods) ( methods count -- methods )
+: each-method-in-class ( class quot -- )
-    over [ void*-nth register-objc-method ] curry each ;
+    [ 0 <uint> [ class_copyMethodList ] keep *uint over ] dip
+    '[ _ void*-nth @ ] each (free) ; inline
 
 : register-objc-methods ( class -- )
-    0 <uint> [ class_copyMethodList ] keep *uint 
+    [ register-objc-method ] each-method-in-class ;
-    (register-objc-methods) (free) ;
+
+: method. ( method -- )
+    {
+        [ method_getName sel_getName ]
+        [ method-return-type ]
+        [ method-arg-types ]
+        [ method_getImplementation ]
+    } cleave 4array . ;
+
+: methods. ( class -- )
+    [ method. ] each-method-in-class ;
 
 : class-exists? ( string -- class ) objc_getClass >boolean ;
 

basis/cocoa/runtime/runtime.factor

@@ -9,7 +9,7 @@ TYPEDEF: void* id
 
 FUNCTION: char* sel_getName ( SEL aSelector ) ;
 
-FUNCTION: bool sel_isMapped ( SEL aSelector ) ;
+FUNCTION: char sel_isMapped ( SEL aSelector ) ;
 
 FUNCTION: SEL sel_registerName ( char* str ) ;
 
@@ -54,6 +54,8 @@ FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ;
 
 FUNCTION: Class class_getSuperclass ( Class cls ) ;
 
+FUNCTION: char* class_getName ( Class cls ) ;
+
 FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
 
 FUNCTION: char class_addProtocol ( Class class, Protocol protocol ) ;
@@ -73,5 +75,6 @@ FUNCTION: void* method_getTypeEncoding ( Method method ) ;
 FUNCTION: SEL method_getName ( Method method ) ;
 
 FUNCTION: void* method_setImplementation ( Method method, void* imp ) ; 
+FUNCTION: void* method_getImplementation ( Method method ) ; 
 
 FUNCTION: Class object_getClass ( id object ) ;

basis/cocoa/subclassing/subclassing.factor

@@ -12,12 +12,17 @@ IN: cocoa.subclassing
     [ sel_registerName ] [ execute ] [ ascii string>alien ]
     tri* ;
 
+: throw-if-false ( YES/NO -- )
+    zero? [ "Failed to add method or protocol to class" throw ]
+    when ;
+
 : add-methods ( methods class -- )
     swap
-    [ init-method class_addMethod drop ] with each ;
+    [ init-method class_addMethod throw-if-false ] with each ;
 
 : add-protocols ( protocols class -- )
-    swap [ objc-protocol class_addProtocol drop ] with each ;
+    swap [ objc-protocol class_addProtocol throw-if-false ]
+    with each ;
 
 : (define-objc-class) ( protocols superclass name imeth -- )
     -rot

basis/cocoa/types/types.factor

@@ -10,25 +10,6 @@ TYPEDEF: ulong NSUInteger
     { 8 [ "double" ] }
 } case "CGFloat" typedef >>
 
-C-STRUCT: NSRect
-    { "CGFloat" "x" }
-    { "CGFloat" "y" }
-    { "CGFloat" "w" }
-    { "CGFloat" "h" } ;
-
-TYPEDEF: NSRect _NSRect
-TYPEDEF: NSRect CGRect
-
-: <NSRect> ( x y w h -- rect )
-    "NSRect" <c-object>
-    [ set-NSRect-h ] keep
-    [ set-NSRect-w ] keep
-    [ set-NSRect-y ] keep
-    [ set-NSRect-x ] keep ;
-
-: NSRect-x-y ( alien -- origin-x origin-y )
-    [ NSRect-x ] keep NSRect-y ;
-
 C-STRUCT: NSPoint
     { "CGFloat" "x" }
     { "CGFloat" "y" } ;
@@ -47,19 +28,58 @@ C-STRUCT: NSSize
 
 TYPEDEF: NSSize _NSSize
 TYPEDEF: NSSize CGSize
-TYPEDEF: NSPoint CGPoint
 
 : <NSSize> ( w h -- size )
     "NSSize" <c-object>
     [ set-NSSize-h ] keep
     [ set-NSSize-w ] keep ;
 
+C-STRUCT: NSRect
+    { "NSPoint" "origin" }
+    { "NSSize"  "size"   } ;
+
+TYPEDEF: NSRect _NSRect
+TYPEDEF: NSRect CGRect
+
+: NSRect-x ( NSRect -- x )
+    NSRect-origin NSPoint-x ; inline
+: NSRect-y ( NSRect -- y )
+    NSRect-origin NSPoint-y ; inline
+: NSRect-w ( NSRect -- w )
+    NSRect-size NSSize-w ; inline
+: NSRect-h ( NSRect -- h )
+    NSRect-size NSSize-h ; inline
+
+: set-NSRect-x ( x NSRect -- )
+    NSRect-origin set-NSPoint-x ; inline
+: set-NSRect-y ( y NSRect -- )
+    NSRect-origin set-NSPoint-y ; inline
+: set-NSRect-w ( w NSRect -- )
+    NSRect-size set-NSSize-w ; inline
+: set-NSRect-h ( h NSRect -- )
+    NSRect-size set-NSSize-h ; inline
+
+: <NSRect> ( x y w h -- rect )
+    "NSRect" <c-object>
+    [ set-NSRect-h ] keep
+    [ set-NSRect-w ] keep
+    [ set-NSRect-y ] keep
+    [ set-NSRect-x ] keep ;
+
+: NSRect-x-y ( alien -- origin-x origin-y )
+    [ NSRect-x ] keep NSRect-y ;
+
 C-STRUCT: NSRange
     { "NSUInteger" "location" }
     { "NSUInteger" "length" } ;
 
 TYPEDEF: NSRange _NSRange
 
+! The "lL" type encodings refer to 32-bit values even in 64-bit mode
+TYPEDEF: int long32
+TYPEDEF: uint ulong32
+TYPEDEF: void* unknown_type
+
 : <NSRange> ( length location -- size )
     "NSRange" <c-object>
     [ set-NSRange-length ] keep

basis/cpu/x86/assembler/assembler-tests.factor

@@ -4,9 +4,9 @@ IN: cpu.x86.assembler.tests
 [ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
 [ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test
 
-! [ { HEX: 89 HEX: ca } ] [ [ EDX ECX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: ca } ] [ [ EDX ECX MOV ] { } make ] unit-test
-! [ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
+[ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
-! [ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
+[ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
 
 [ { HEX: f2 HEX: 0f HEX: 2c HEX: c0 } ] [ [ EAX XMM0 CVTTSD2SI ] { } make ] unit-test
 [ { HEX: f2 HEX: 48 HEX: 0f HEX: 2c HEX: c0 } ] [ [ RAX XMM0 CVTTSD2SI ] { } make ] unit-test
@@ -39,3 +39,21 @@ IN: cpu.x86.assembler.tests
 
 [ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
 [ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1a } ] [ [ R10 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1b } ] [ [ R11 RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1c } ] [ [ R12 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 04 HEX: 1c } ] [ [ RSP RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ R13 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ RBP RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 4a HEX: 89 HEX: 04 HEX: 23 } ] [ [ RBX R12 [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 4a HEX: 89 HEX: 04 HEX: 2b } ] [ [ RBX R13 [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 4b HEX: 89 HEX: 44 HEX: 25 HEX: 00 } ] [ [ R13 R12 [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 4b HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 R13 [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
+[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail

basis/cpu/x86/assembler/assembler.factor

@@ -64,18 +64,18 @@ M: indirect extended? base>> extended? ;
 
 : canonicalize-EBP ( indirect -- indirect )
     #! { EBP } ==> { EBP 0 }
-    dup base>> { EBP RBP R13 } member? [
+    dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
-        dup displacement>> [ 0 >>displacement ] unless
+    [ 0 >>displacement ] when ;
-    ] when ;
 
-: canonicalize-ESP ( indirect -- indirect )
+ERROR: bad-index indirect ;
-    #! { ESP } ==> { ESP ESP }
+
-    dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
+: check-ESP ( indirect -- indirect )
+    dup index>> { ESP RSP } memq? [ bad-index ] when ;
 
 : canonicalize ( indirect -- indirect )
     #! Modify the indirect to work around certain addressing mode
     #! quirks.
-    canonicalize-EBP canonicalize-ESP ;
+    canonicalize-EBP check-ESP ;
 
 : <indirect> ( base index scale displacement -- indirect )
     indirect boa canonicalize ;
@@ -91,7 +91,7 @@ M: indirect extended? base>> extended? ;
 GENERIC: sib-present? ( op -- ? )
 
 M: indirect sib-present?
-    [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
+    [ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ;
 
 M: register sib-present? drop f ;
 
@@ -254,7 +254,8 @@ M: object operand-64? drop f ;
     reg-code swap addressing ;
 
 : direction-bit ( dst src op -- dst' src' op' )
-    pick register? [ BIN: 10 opcode-or swapd ] when ;
+    pick register? pick register? not and
+    [ BIN: 10 opcode-or swapd ] when ;
 
 : operand-size-bit ( dst src op -- dst' src' op' )
     over register-8? [ BIN: 1 opcode-or ] unless ;

basis/db/queries/queries.factor

@@ -166,9 +166,11 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
     swap 3append ;
 
 : do-group ( tuple groups -- )
+    dup string? [ 1array ] when
     [ ", " join " group by " splice ] curry change-sql drop ;
 
 : do-order ( tuple order -- )
+    dup string? [ 1array ] when
     [ ", " join " order by " splice ] curry change-sql drop ;
 
 : do-offset ( tuple n -- )

basis/db/sqlite/lib/lib.factor

@@ -5,7 +5,7 @@ namespaces sequences db.sqlite.ffi db combinators
 continuations db.types calendar.format serialize
 io.streams.byte-array byte-arrays io.encodings.binary
 io.backend db.errors present urls io.encodings.utf8
-io.encodings.string accessors ;
+io.encodings.string accessors shuffle ;
 IN: db.sqlite.lib
 
 ERROR: sqlite-error < db-error n string ;
@@ -79,6 +79,9 @@ ERROR: sqlite-sql-error < sql-error n string ;
 : sqlite-bind-uint64-by-name ( handle name int64 -- )
     parameter-index sqlite-bind-uint64 ;
 
+: sqlite-bind-boolean-by-name ( handle name obj -- )
+    >boolean 1 0 ? parameter-index sqlite-bind-int ;
+
 : sqlite-bind-double-by-name ( handle name double -- )
     parameter-index sqlite-bind-double ;
 
@@ -88,14 +91,14 @@ ERROR: sqlite-sql-error < sql-error n string ;
 : sqlite-bind-null-by-name ( handle name obj -- )
     parameter-index drop sqlite-bind-null ;
 
-: sqlite-bind-type ( handle key value type -- )
+: (sqlite-bind-type) ( handle key value type -- )
-    over [ drop NULL ] unless
     dup array? [ first ] when
     {
         { INTEGER [ sqlite-bind-int-by-name ] }
         { BIG-INTEGER [ sqlite-bind-int64-by-name ] }
         { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
         { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
+        { BOOLEAN [ sqlite-bind-boolean-by-name ] }
         { TEXT [ sqlite-bind-text-by-name ] }
         { VARCHAR [ sqlite-bind-text-by-name ] }
         { DOUBLE [ sqlite-bind-double-by-name ] }
@@ -104,10 +107,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
         { DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] }
         { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] }
         { BLOB [ sqlite-bind-blob-by-name ] }
-        { FACTOR-BLOB [
+        { FACTOR-BLOB [ object>bytes sqlite-bind-blob-by-name ] }
-            object>bytes
-            sqlite-bind-blob-by-name
-        ] }
         { URL [ present sqlite-bind-text-by-name ] }
         { +db-assigned-id+ [ sqlite-bind-int-by-name ] }
         { +random-id+ [ sqlite-bind-int64-by-name ] }
@@ -115,6 +115,14 @@ ERROR: sqlite-sql-error < sql-error n string ;
         [ no-sql-type ]
     } case ;
 
+: sqlite-bind-type ( handle key value type -- )
+    #! null and empty values need to be set by sqlite-bind-null-by-name
+    over [
+        NULL = [ 2drop NULL NULL ] when
+    ] [
+        drop NULL 
+    ] if* (sqlite-bind-type) ;
+
 : sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
 : sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
 : sqlite-clear-bindings ( handle -- )
@@ -141,6 +149,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
         { BIG-INTEGER [ sqlite3_column_int64 ] }
         { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
         { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
+        { BOOLEAN [ sqlite3_column_int 1 = ] }
         { DOUBLE [ sqlite3_column_double ] }
         { TEXT [ sqlite3_column_text ] }
         { VARCHAR [ sqlite3_column_text ] }
@@ -150,11 +159,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
         { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] }
         { BLOB [ sqlite-column-blob ] }
         { URL [ sqlite3_column_text dup [ >url ] when ] }
-        { FACTOR-BLOB [
+        { FACTOR-BLOB [ sqlite-column-blob dup [ bytes>object ] when ] }
-            sqlite-column-blob
-            dup [ bytes>object ] when
-        ] }
-        ! { NULL [ 2drop f ] }
         [ no-sql-type ]
     } case ;
 

basis/db/sqlite/sqlite.factor

@@ -185,6 +185,7 @@ M: sqlite-db persistent-table ( -- assoc )
         { +set-null+ { f f "set null" } }
         { +set-default+ { f f "set default" } }
 
+        { BOOLEAN { "boolean" "boolean" f } }
         { INTEGER { "integer" "integer" f } }
         { BIG-INTEGER { "bigint" "bigint" f } }
         { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }

basis/debugger/debugger-docs.factor

@@ -1,7 +1,6 @@
 USING: alien arrays generic generic.math help.markup help.syntax
 kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations system io.files.private
+help generic.standard continuations io.files.private listener ;
-listener ;
 IN: debugger
 
 ARTICLE: "debugger" "The debugger"
@@ -144,5 +143,4 @@ HELP: memory-error.
 { $notes "This can be a result of incorrect usage of C library interface words, a bug in the compiler, or a bug in the VM." } ;
 
 HELP: primitive-error.
-{ $error-description "Thrown by the Factor VM if an unsupported primitive word is called." }
+{ $error-description "Thrown by the Factor VM if an unsupported primitive word is called." } ;
-{ $notes "This word is only ever thrown on Windows CE, where the " { $link cwd } ", " { $link cd } ", and " { $link os-env } " primitives are unsupported." } ;

basis/editors/editors.factor

@@ -27,7 +27,8 @@ SYMBOL: edit-hook
 
 : edit-location ( file line -- )
     >r (normalize-path) r>
-    edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
+    edit-hook get-global
+    [ call ] [ no-edit-hook edit-location ] if* ;
 
 : edit ( defspec -- )
     where [ first2 edit-location ] when* ;

basis/environment/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/environment/environment-docs.factor

@@ -0,0 +1,68 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax io.streams.string sequences strings ;
+IN: environment
+
+HELP: (os-envs)
+{ $values
+    
+     { "seq" sequence } }
+{ $description "" } ;
+
+HELP: (set-os-envs)
+{ $values
+     { "seq" sequence } }
+{ $description "" } ;
+
+
+HELP: os-env ( key -- value )
+{ $values { "key" string } { "value" string } }
+{ $description "Looks up the value of a shell environment variable." }
+{ $examples
+    "This is an operating system-specific feature. On Unix, you can do:"
+    { $unchecked-example "\"USER\" os-env print" "jane" }
+} ;
+
+HELP: os-envs
+{ $values { "assoc" "an association mapping strings to strings" } }
+{ $description "Outputs the current set of environment variables." }
+{ $notes
+    "Names and values of environment variables are operating system-specific."
+} ;
+
+HELP: set-os-envs
+{ $values { "assoc" "an association mapping strings to strings" } }
+{ $description "Replaces the current set of environment variables." }
+{ $notes
+    "Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
+} ;
+
+HELP: set-os-env ( value key -- )
+{ $values { "value" string } { "key" string } }
+{ $description "Set an environment variable." }
+{ $notes
+    "Names and values of environment variables are operating system-specific."
+} ;
+
+HELP: unset-os-env ( key -- )
+{ $values { "key" string } }
+{ $description "Unset an environment variable." }
+{ $notes
+    "Names and values of environment variables are operating system-specific."
+} ;
+
+{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words
+
+
+ARTICLE: "environment" "Environment variables"
+"The " { $vocab-link "environment" } " vocabulary interfaces to the platform-dependent mechanism for setting environment variables." $nl
+"Windows CE has no concept of environment variables, so these words are undefined on that platform." $nl
+"Reading environment variables:"
+{ $subsection os-env }
+{ $subsection os-envs }
+"Writing environment variables:"
+{ $subsection set-os-env }
+{ $subsection unset-os-env }
+{ $subsection set-os-envs } ;
+
+ABOUT: "environment"

basis/environment/environment-tests.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces prettyprint system tools.test
+environment strings sequences ;
+IN: environment.tests
+
+os wince? [
+    [ ] [ os-envs . ] unit-test
+
+    os unix? [
+        [ ] [ os-envs "envs" set ] unit-test
+        [ ] [ { { "A" "B" } } set-os-envs ] unit-test
+        [ "B" ] [ "A" os-env ] unit-test
+        [ ] [ "envs" get set-os-envs ] unit-test
+        [ t ] [ os-envs "envs" get = ] unit-test
+    ] when
+
+    [ ] [ "factor-test-key-1" unset-os-env ] unit-test
+    [ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test
+    [ "ps3" ] [ "factor-test-key-1" os-env ] unit-test
+    [ ] [ "factor-test-key-1" unset-os-env ] unit-test
+    [ f ] [ "factor-test-key-1" os-env ] unit-test
+
+    [ ] [
+        32766 CHAR: a <string> "factor-test-key-long" set-os-env
+    ] unit-test
+    [ 32766 ] [ "factor-test-key-long" os-env length ] unit-test
+    [ ] [ "factor-test-key-long" unset-os-env ] unit-test
+] unless

basis/environment/environment.factor

@@ -0,0 +1,27 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs combinators kernel sequences splitting system
+vocabs.loader ;
+IN: environment
+
+HOOK: os-env os ( key -- value )
+
+HOOK: set-os-env os ( value key -- )
+
+HOOK: unset-os-env os ( key -- )
+
+HOOK: (os-envs) os ( -- seq )
+
+HOOK: (set-os-envs) os ( seq -- )
+
+: os-envs ( -- assoc )
+    (os-envs) [ "=" split1 ] H{ } map>assoc ;
+
+: set-os-envs ( assoc -- )
+    [ "=" swap 3append ] { } assoc>map (set-os-envs) ;
+
+{
+    { [ os unix? ] [ "environment.unix" require ] }
+    { [ os winnt? ] [ "environment.winnt" require ] }
+    { [ os wince? ] [ ] }
+} cond

basis/environment/summary.txt

@@ -0,0 +1 @@
+Environment variables

basis/environment/unix/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/environment/unix/macosx/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/environment/unix/macosx/macosx.factor

@@ -0,0 +1,8 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax system environment.unix ;
+IN: environment.unix.macosx
+
+FUNCTION: void* _NSGetEnviron ( ) ;
+
+M: macosx environ _NSGetEnviron ;

basis/environment/unix/macosx/tags.txt

@@ -0,0 +1 @@
+unportable

basis/environment/unix/tags.txt

@@ -0,0 +1 @@
+unportable

basis/environment/unix/unix.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings alien.syntax kernel
+layouts sequences system unix environment io.encodings.utf8
+unix.utilities vocabs.loader combinators alien.accessors ;
+IN: environment.unix
+
+HOOK: environ os ( -- void* )
+
+M: unix environ ( -- void* ) "environ" f dlsym ;
+
+M: unix os-env ( key -- value ) getenv ;
+
+M: unix set-os-env ( value key -- ) swap 1 setenv io-error ;
+
+M: unix unset-os-env ( key -- ) unsetenv io-error ;
+
+M: unix (os-envs) ( -- seq )
+    environ *void* utf8 alien>strings ;
+
+: set-void* ( value alien -- ) 0 set-alien-cell ;
+
+M: unix (set-os-envs) ( seq -- )
+    utf8 strings>alien malloc-byte-array environ set-void* ;
+
+os {
+    { macosx [ "environment.unix.macosx" require ] }
+    [ drop ]
+} case

basis/environment/winnt/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/environment/winnt/tags.txt

@@ -0,0 +1 @@
+unportable

basis/environment/winnt/winnt.factor

@@ -0,0 +1,33 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.strings fry io.encodings.utf16 kernel
+splitting windows windows.kernel32 system environment
+alien.c-types sequences windows.errors io.streams.memory
+io.encodings io ;
+IN: environment.winnt
+
+M: winnt os-env ( key -- value )
+    MAX_UNICODE_PATH "TCHAR" <c-array>
+    [ dup length GetEnvironmentVariable ] keep over 0 = [
+        2drop f
+    ] [
+        nip utf16n alien>string
+    ] if ;
+
+M: winnt set-os-env ( value key -- )
+    swap SetEnvironmentVariable win32-error=0/f ;
+
+M: winnt unset-os-env ( key -- )
+    f SetEnvironmentVariable 0 = [
+        GetLastError ERROR_ENVVAR_NOT_FOUND =
+        [ win32-error ] unless
+    ] when ;
+
+M: winnt (os-envs) ( -- seq )
+    GetEnvironmentStrings [
+        <memory-stream> [
+            utf16n decode-input
+            [ "\0" read-until drop dup empty? not ]
+            [ ] [ drop ] produce
+        ] with-input-stream*
+    ] [ FreeEnvironmentStrings win32-error=0/f ] bi ;

basis/http/http-tests.factor

@@ -192,110 +192,104 @@ test-db [
     init-furnace-tables
 ] with-db
 
-: test-httpd ( -- )
+: test-httpd ( responder -- )
-    #! Return as soon as server is running.
+    [
-    <http-server>
+        main-responder set
-        1237 >>insecure
+        <http-server>
-        f >>secure
+            0 >>insecure
-    start-server* ;
+            f >>secure
+        dup start-server*
+        sockets>> first addr>> port>>
+    ] with-scope "port" set ;
 
 [ ] [
-    [
+    <dispatcher>
+        add-quit-action
         <dispatcher>
-            add-quit-action
+            "resource:basis/http/test" <static> >>default
-            <dispatcher>
+        "nested" add-responder
-                "resource:basis/http/test" <static> >>default
+        <action>
-            "nested" add-responder
+            [ URL" redirect-loop" <temporary-redirect> ] >>display
-            <action>
+        "redirect-loop" add-responder
-                [ URL" redirect-loop" <temporary-redirect> ] >>display
-            "redirect-loop" add-responder
-        main-responder set
 
-        test-httpd
+    test-httpd
-    ] with-scope
 ] unit-test
 
+: add-port ( url -- url' )
+    >url clone "port" get >>port ;
+
 [ t ] [
     "resource:basis/http/test/foo.html" ascii file-contents
-    "http://localhost:1237/nested/foo.html" http-get nip =
+    "http://localhost/nested/foo.html" add-port http-get nip =
 ] unit-test
 
-[ "http://localhost:1237/redirect-loop" http-get nip ]
+[ "http://localhost/redirect-loop" add-port http-get nip ]
 [ too-many-redirects? ] must-fail-with
 
 [ "Goodbye" ] [
-    "http://localhost:1237/quit" http-get nip
+    "http://localhost/quit" add-port http-get nip
 ] unit-test
 
 ! HTTP client redirect bug
 [ ] [
-    [
+    <dispatcher>
-        <dispatcher>
+        add-quit-action
-            add-quit-action
+        <action> [ "quit" <temporary-redirect> ] >>display
-            <action> [ "quit" <temporary-redirect> ] >>display
+        "redirect" add-responder
-            "redirect" add-responder
-        main-responder set
 
-        test-httpd
+    test-httpd
-    ] with-scope
 ] unit-test
 
 [ "Goodbye" ] [
-    "http://localhost:1237/redirect" http-get nip
+    "http://localhost/redirect" add-port http-get nip
 ] unit-test
 
 
 [ ] [
-    [ "http://localhost:1237/quit" http-get 2drop ] ignore-errors
+    [ "http://localhost/quit" add-port http-get 2drop ] ignore-errors
 ] unit-test
 
 ! Dispatcher bugs
 [ ] [
-    [
+    <dispatcher>
+        <action> <protected>
+        "Test" <login-realm>
+        <sessions>
+        "" add-responder
+        add-quit-action
         <dispatcher>
-            <action> <protected>
+            <action> "" add-responder
-            "Test" <login-realm>
+        "d" add-responder
-            <sessions>
+    test-db <db-persistence>
-            "" add-responder
-            add-quit-action
-            <dispatcher>
-                <action> "" add-responder
-            "d" add-responder
-        test-db <db-persistence>
-        main-responder set
 
-        test-httpd
+    test-httpd
-    ] with-scope
 ] unit-test
 
 : 404? [ download-failed? ] [ response>> code>> 404 = ] bi and ;
 
 ! This should give a 404 not an infinite redirect loop
-[ "http://localhost:1237/d/blah" http-get nip ] [ 404? ] must-fail-with
+[ "http://localhost/d/blah" add-port http-get nip ] [ 404? ] must-fail-with
 
 ! This should give a 404 not an infinite redirect loop
-[ "http://localhost:1237/blah/" http-get nip ] [ 404? ] must-fail-with
+[ "http://localhost/blah/" add-port http-get nip ] [ 404? ] must-fail-with
 
-[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
 
 [ ] [
-    [
+    <dispatcher>
-        <dispatcher>
+        <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
-            <action> [ [ "Hi" write ] "text/plain" <content> ] >>display
+        "Test" <login-realm>
-            "Test" <login-realm>
+        <sessions>
-            <sessions>
+        "" add-responder
-            "" add-responder
+        add-quit-action
-            add-quit-action
+    test-db <db-persistence>
-        test-db <db-persistence>
-        main-responder set
 
-        test-httpd
+    test-httpd
-    ] with-scope
 ] unit-test
 
-[ "Hi" ] [ "http://localhost:1237/" http-get nip ] unit-test
+[ "Hi" ] [ "http://localhost/" add-port http-get nip ] unit-test
 
-[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
 
 USING: html.components html.elements html.forms
 xml xml.utilities validators
@@ -304,22 +298,19 @@ furnace furnace.conversations ;
 SYMBOL: a
 
 [ ] [
-    [
+    <dispatcher>
-        <dispatcher>
+        <action>
-            <action>
+            [ a get-global "a" set-value ] >>init
-                [ a get-global "a" set-value ] >>init
+            [ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
-                [ [ <html> "a" <field> render </html> ] "text/html" <content> ] >>display
+            [ { { "a" [ v-integer ] } } validate-params ] >>validate
-                [ { { "a" [ v-integer ] } } validate-params ] >>validate
+            [ "a" value a set-global URL" " <redirect> ] >>submit
-                [ "a" value a set-global URL" " <redirect> ] >>submit
+        <conversations>
-            <conversations>
+        <sessions>
-            <sessions>
+        >>default
-            >>default
+        add-quit-action
-            add-quit-action
+    test-db <db-persistence>
-        test-db <db-persistence>
-        main-responder set
 
-        test-httpd
+    test-httpd
-    ] with-scope
 ] unit-test
 
 3 a set-global
@@ -327,27 +318,35 @@ SYMBOL: a
 : test-a string>xml "input" tag-named "value" swap at ;
 
 [ "3" ] [
-    "http://localhost:1237/" http-get
+    "http://localhost/" add-port http-get
     swap dup cookies>> "cookies" set session-id-key get-cookie
     value>> "session-id" set test-a
 ] unit-test
 
 [ "4" ] [
-    H{ { "a" "4" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
+    [
-    "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+        "4" "a" set
+        "http://localhost" add-port "__u" set
+        "session-id" get session-id-key set
+    ] H{ } make-assoc
+    "http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
 ] unit-test
 
 [ 4 ] [ a get-global ] unit-test
 
 ! Test flash scope
 [ "xyz" ] [
-    H{ { "a" "xyz" } { "__u" "http://localhost:1237/" } } "session-id" get session-id-key associate assoc-union
+    [
-    "http://localhost:1237/" <post-request> "cookies" get >>cookies http-request nip test-a
+        "xyz" "a" set
+        "http://localhost" add-port "__u" set
+        "session-id" get session-id-key set
+    ] H{ } make-assoc
+    "http://localhost/" add-port <post-request> "cookies" get >>cookies http-request nip test-a
 ] unit-test
 
 [ 4 ] [ a get-global ] unit-test
 
-[ "Goodbye" ] [ "http://localhost:1237/quit" http-get nip ] unit-test
+[ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test
 
 ! Test cloning
 [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test

basis/http/server/static/static.factor

@@ -59,8 +59,8 @@ TUPLE: file-responder root hook special allow-listings ;
 
 \ serve-file NOTICE add-input-logging
 
-: file. ( name dirp -- )
+: file. ( name -- )
-    [ "/" append ] when
+    dup link-info directory? [ "/" append ] when
     dup <a =href a> escape-string write </a> ;
 
 : directory. ( path -- )
@@ -68,8 +68,7 @@ TUPLE: file-responder root hook special allow-listings ;
         [ <h1> file-name escape-string write </h1> ]
         [
             <ul>
-                directory sort-keys
+                directory-files [ <li> file. </li> ] each
-                [ <li> file. </li> ] assoc-each
             </ul>
         ] bi
     ] simple-page ;

basis/io/launcher/launcher.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: system kernel namespaces strings hashtables sequences 
 assocs combinators vocabs.loader init threads continuations
-math accessors concurrency.flags destructors
+math accessors concurrency.flags destructors environment
 io io.backend io.timeouts io.pipes io.pipes.private io.encodings
 io.streams.duplex io.ports debugger prettyprint summary ;
 IN: io.launcher
@@ -58,8 +58,6 @@ SYMBOL: +realtime-priority+
 ! Non-blocking process exit notification facility
 SYMBOL: processes
 
-[ H{ } clone processes set-global ] "io.launcher" add-init-hook
-
 HOOK: wait-for-processes io-backend ( -- ? )
 
 SYMBOL: wait-flag
@@ -73,7 +71,10 @@ SYMBOL: wait-flag
     <flag> wait-flag set-global
     [ wait-loop t ] "Process wait" spawn-server drop ;
 
-[ start-wait-thread ] "io.launcher" add-init-hook
+[
+    H{ } clone processes set-global
+    start-wait-thread
+] "io.launcher" add-init-hook
 
 : process-started ( process handle -- )
     >>handle

basis/io/monitors/recursive/recursive.factor

@@ -19,11 +19,14 @@ DEFER: add-child-monitor
 
 : add-child-monitors ( path -- )
     #! We yield since this directory scan might take a while.
-    directory* [ first add-child-monitor ] each yield ;
+    dup [
+        [ append-path ] with map
+        [ add-child-monitor ] each yield
+    ] with-directory-files ;
 
 : add-child-monitor ( path -- )
     notify? [ dup { +add-file+ } monitor tget queue-change ] when
-    qualify-path dup link-info type>> +directory+ eq? [
+    qualify-path dup link-info directory? [
         [ add-child-monitors ]
         [
             [

basis/io/servers/connection/connection-tests.factor

@@ -27,25 +27,12 @@ concurrency.promises io.encodings.ascii io threads calendar ;
     init-server semaphore>> count>> 
 ] unit-test
 
-[ ] [ <promise> "p" set ] unit-test
-
 [ ] [
     <threaded-server>
         5 >>max-connections
-        1237 >>insecure
+        0 >>insecure
         [ "Hello world." write stop-this-server ] >>handler
-    "server" set
+    dup start-server* sockets>> first addr>> port>> "port" set
 ] unit-test
 
-[ ] [
+[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop contents ] unit-test
-    [
-        "server" get start-server
-        t "p" get fulfill
-    ] in-thread
-] unit-test
-
-[ ] [ "server" get wait-for-server ] unit-test
-
-[ "Hello world." ] [ "localhost" 1237 <inet> ascii <client> drop contents ] unit-test
-
-[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test

basis/io/unix/files/bsd/bsd.factor

@@ -13,5 +13,8 @@ M: bsd stat>file-info ( stat -- file-info )
     {
         [ stat-st_flags >>flags ]
         [ stat-st_gen >>gen ]
-        [ stat-st_birthtimespec timespec>unix-time >>birth-time ]
+        [
+            stat-st_birthtimespec timespec>unix-time
+            >>birth-time
+        ]
     } cleave ;

basis/io/unix/files/files-docs.factor

@@ -36,39 +36,39 @@ HELP: file-user-id
 
 HELP: group-execute?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file." } ;
+{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 HELP: group-read?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string, file-info object, or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file." } ;
+{ $description "Tests whether the " { $snippet "group read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 HELP: group-write?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string, file-info object, or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file." } ;
+{ $description "Tests whether the " { $snippet "group write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 HELP: other-execute?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string, file-info object, or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file." } ;
+{ $description "Tests whether the " { $snippet "other execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 HELP: other-read?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string, file-info object, or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file." } ;
+{ $description "Tests whether the " { $snippet "other read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 HELP: other-write?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string, file-info object, or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file." } ;
+{ $description "Tests whether the " { $snippet "other write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 HELP: set-file-access-time
 { $values
@@ -124,9 +124,9 @@ HELP: set-gid
 
 HELP: gid?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string, file-info object, or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file." } ;
+{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 HELP: set-group-execute
 { $values
@@ -165,9 +165,9 @@ HELP: set-sticky
 
 HELP: sticky?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string, file-info object, or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "sticky" } " bit of a file is set." } ;
+{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 HELP: set-uid
 { $values
@@ -176,9 +176,9 @@ HELP: set-uid
 
 HELP: uid?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string, file-info object, or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "uid" } " bit of a file is set." } ;
+{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 HELP: set-user-execute
 { $values
@@ -197,21 +197,21 @@ HELP: set-user-write
 
 HELP: user-execute?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string, file-info object, or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file." } ;
+{ $description "Tests whether the " { $snippet "user execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 HELP: user-read?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string, file-info object, or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file." } ;
+{ $description "Tests whether the " { $snippet "user read" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 HELP: user-write?
 { $values
-     { "path" "a pathname string" }
+     { "obj" "a pathname string, file-info object, or an integer" }
      { "?" "a boolean" } }
-{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file." } ;
+{ $description "Tests whether the " { $snippet "user write" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
 
 ARTICLE: "unix-file-permissions" "Unix file permissions"
 "Reading all file permissions:"

basis/io/unix/files/files-tests.factor

@@ -55,32 +55,32 @@ prepare-test-file
 [ t ] [ test-file other-write? ] unit-test
 [ t ] [ test-file other-execute? ] unit-test
 
-[ t ]
+[ t ] [ test-file f set-other-execute perms OCT: 776 = ] unit-test
-[ test-file f set-other-execute perms OCT: 776 = ] unit-test
+[ f ] [ test-file file-info other-execute? ] unit-test
 
-[ t ]
+[ t ] [ test-file f set-other-write perms OCT: 774 = ] unit-test
-[ test-file f set-other-write perms OCT: 774 = ] unit-test
+[ f ] [ test-file file-info other-write? ] unit-test
 
-[ t ]
+[ t ] [ test-file f set-other-read perms OCT: 770 = ] unit-test
-[ test-file f set-other-read perms OCT: 770 = ] unit-test
+[ f ] [ test-file file-info other-read? ] unit-test
 
-[ t ]
+[ t ] [ test-file f set-group-execute perms OCT: 760 = ] unit-test
-[ test-file f set-group-execute perms OCT: 760 = ] unit-test
+[ f ] [ test-file file-info group-execute? ] unit-test
 
-[ t ]
+[ t ] [ test-file f set-group-write perms OCT: 740 = ] unit-test
-[ test-file f set-group-write perms OCT: 740 = ] unit-test
+[ f ] [ test-file file-info group-write? ] unit-test
 
-[ t ]
+[ t ] [ test-file f set-group-read perms OCT: 700 = ] unit-test
-[ test-file f set-group-read perms OCT: 700 = ] unit-test
+[ f ] [ test-file file-info group-read? ] unit-test
 
-[ t ]
+[ t ] [ test-file f set-user-execute perms OCT: 600 = ] unit-test
-[ test-file f set-user-execute perms OCT: 600 = ] unit-test
+[ f ] [ test-file file-info other-execute? ] unit-test
 
-[ t ]
+[ t ] [ test-file f set-user-write perms OCT: 400 = ] unit-test
-[ test-file f set-user-write perms OCT: 400 = ] unit-test
+[ f ] [ test-file file-info other-write? ] unit-test
 
-[ t ]
+[ t ] [ test-file f set-user-read perms OCT: 000 = ] unit-test
-[ test-file f set-user-read perms OCT: 000 = ] unit-test
+[ f ] [ test-file file-info other-read? ] unit-test
 
 [ t ]
 [ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test
@@ -135,3 +135,29 @@ prepare-test-file
 
 [ ]
 [ test-file f f set-file-ids ] unit-test
+
+[ t ] [ OCT: 4000 uid? ] unit-test
+[ t ] [ OCT: 2000 gid? ] unit-test
+[ t ] [ OCT: 1000 sticky? ] unit-test
+[ t ] [ OCT: 400 user-read? ] unit-test
+[ t ] [ OCT: 200 user-write? ] unit-test
+[ t ] [ OCT: 100 user-execute? ] unit-test
+[ t ] [ OCT: 040 group-read? ] unit-test
+[ t ] [ OCT: 020 group-write? ] unit-test
+[ t ] [ OCT: 010 group-execute? ] unit-test
+[ t ] [ OCT: 004 other-read? ] unit-test
+[ t ] [ OCT: 002 other-write? ] unit-test
+[ t ] [ OCT: 001 other-execute? ] unit-test
+
+[ f ] [ 0 uid? ] unit-test
+[ f ] [ 0 gid? ] unit-test
+[ f ] [ 0 sticky? ] unit-test
+[ f ] [ 0 user-read? ] unit-test
+[ f ] [ 0 user-write? ] unit-test
+[ f ] [ 0 user-execute? ] unit-test
+[ f ] [ 0 group-read? ] unit-test
+[ f ] [ 0 group-write? ] unit-test
+[ f ] [ 0 group-execute? ] unit-test
+[ f ] [ 0 other-read? ] unit-test
+[ f ] [ 0 other-write? ] unit-test
+[ f ] [ 0 other-execute? ] unit-test

basis/io/unix/files/files.factor

@@ -5,7 +5,8 @@ unix unix.stat unix.time kernel math continuations
 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 ;
+unix.stat alien.c-types arrays unix.users unix.groups
+environment fry io.encodings.utf8 alien.strings unix.statfs ;
 IN: io.unix.files
 
 M: unix cwd ( -- path )
@@ -137,6 +138,27 @@ os {
     { linux [ ] }
 } case
 
+: with-unix-directory ( path quot -- )
+    [ opendir dup [ (io-error) ] unless ] dip
+    dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
+
+: find-next-file ( DIR* -- byte-array )
+    "dirent" <c-object>
+    f <void*>
+    [ readdir_r 0 = [ (io-error) ] unless ] 2keep
+    *void* [ drop f ] unless ;
+
+M: unix >directory-entry ( byte-array -- directory-entry )
+    [ dirent-d_name utf8 alien>string ]
+    [ dirent-d_type ] bi directory-entry boa ;
+
+M: unix (directory-entries) ( path -- seq )
+    [
+        '[ _ find-next-file dup ]
+        [ >directory-entry ]
+        [ drop ] produce
+    ] with-unix-directory ;
+
 <PRIVATE
 
 : stat-mode ( path -- mode )
@@ -166,18 +188,57 @@ PRIVATE>
 : OTHER-WRITE   OCT: 0000002 ; inline  
 : OTHER-EXECUTE OCT: 0000001 ; inline    
 
-: uid? ( path -- ? ) UID file-mode? ;
+GENERIC: uid? ( obj -- ? )
-: gid? ( path -- ? ) GID file-mode? ;
+GENERIC: gid? ( obj -- ? )
-: sticky? ( path -- ? ) STICKY file-mode? ;
+GENERIC: sticky? ( obj -- ? )
-: user-read? ( path -- ? ) USER-READ file-mode? ;
+GENERIC: user-read? ( obj -- ? )
-: user-write? ( path -- ? ) USER-WRITE file-mode? ;
+GENERIC: user-write? ( obj -- ? )
-: user-execute? ( path -- ? ) USER-EXECUTE file-mode? ;
+GENERIC: user-execute? ( obj -- ? )
-: group-read? ( path -- ? ) GROUP-READ file-mode? ;
+GENERIC: group-read? ( obj -- ? )
-: group-write? ( path -- ? ) GROUP-WRITE file-mode? ;
+GENERIC: group-write? ( obj -- ? )
-: group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ;
+GENERIC: group-execute? ( obj -- ? )
-: other-read? ( path -- ? ) OTHER-READ file-mode? ;
+GENERIC: other-read? ( obj -- ? )
-: other-write? ( path -- ? ) OTHER-WRITE file-mode? ; 
+GENERIC: other-write? ( obj -- ? )
-: other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
+GENERIC: other-execute? ( obj -- ? )
+
+M: integer uid? ( integer -- ? ) UID mask? ;
+M: integer gid? ( integer -- ? ) GID mask? ;
+M: integer sticky? ( integer -- ? ) STICKY mask? ;
+M: integer user-read? ( integer -- ? ) USER-READ mask? ;
+M: integer user-write? ( integer -- ? ) USER-WRITE mask? ;
+M: integer user-execute? ( integer -- ? ) USER-EXECUTE mask? ;
+M: integer group-read? ( integer -- ? ) GROUP-READ mask? ;
+M: integer group-write? ( integer -- ? ) GROUP-WRITE mask? ;
+M: integer group-execute? ( integer -- ? ) GROUP-EXECUTE mask? ;
+M: integer other-read? ( integer -- ? ) OTHER-READ mask? ;
+M: integer other-write? ( integer -- ? ) OTHER-WRITE mask? ; 
+M: integer other-execute? ( integer -- ? ) OTHER-EXECUTE mask? ;
+
+M: file-info uid? ( file-info -- ? ) permissions>> uid? ;
+M: file-info gid? ( file-info -- ? ) permissions>> gid? ;
+M: file-info sticky? ( file-info -- ? ) permissions>> sticky? ;
+M: file-info user-read? ( file-info -- ? ) permissions>> user-read? ;
+M: file-info user-write? ( file-info -- ? ) permissions>> user-write? ;
+M: file-info user-execute? ( file-info -- ? ) permissions>> user-execute? ;
+M: file-info group-read? ( file-info -- ? ) permissions>> group-read? ;
+M: file-info group-write? ( file-info -- ? ) permissions>> group-write? ;
+M: file-info group-execute? ( file-info -- ? ) permissions>> group-execute? ;
+M: file-info other-read? ( file-info -- ? ) permissions>> other-read? ;
+M: file-info other-write? ( file-info -- ? ) permissions>> other-write? ;
+M: file-info other-execute? ( file-info -- ? ) permissions>> other-execute? ;
+
+M: string uid? ( path -- ? ) UID file-mode? ;
+M: string gid? ( path -- ? ) GID file-mode? ;
+M: string sticky? ( path -- ? ) STICKY file-mode? ;
+M: string user-read? ( path -- ? ) USER-READ file-mode? ;
+M: string user-write? ( path -- ? ) USER-WRITE file-mode? ;
+M: string user-execute? ( path -- ? ) USER-EXECUTE file-mode? ;
+M: string group-read? ( path -- ? ) GROUP-READ file-mode? ;
+M: string group-write? ( path -- ? ) GROUP-WRITE file-mode? ;
+M: string group-execute? ( path -- ? ) GROUP-EXECUTE file-mode? ;
+M: string other-read? ( path -- ? ) OTHER-READ file-mode? ;
+M: string other-write? ( path -- ? ) OTHER-WRITE file-mode? ; 
+M: string other-execute? ( path -- ? ) OTHER-EXECUTE file-mode? ;
 
 : set-uid ( path ? -- ) UID swap chmod-set-bit ;
 : set-gid ( path ? -- ) GID swap chmod-set-bit ;
@@ -255,3 +316,5 @@ M: string set-file-group ( path string -- )
 
 : file-group-name ( path -- string )
     file-group-id group-name ;
+
+M: unix home "HOME" os-env ;

basis/io/unix/launcher/launcher.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces math system sequences debugger
 continuations arrays assocs combinators alien.c-types strings
-threads accessors
+threads accessors environment
 io io.backend io.launcher io.ports io.files
 io.files.private io.unix.files io.unix.backend
 io.unix.launcher.parser

basis/io/windows/files/files.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types io.binary io.backend io.files io.buffers
-io.windows kernel math splitting
+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 ;
+io.ports destructors accessors math.bitwise continuations
+windows.errors arrays byte-arrays ;
 IN: io.windows.files
 
 : open-file ( path access-mode create-mode flags -- handle )
@@ -113,8 +114,35 @@ M: windows delete-directory ( path -- )
     normalize-path
     RemoveDirectory win32-error=0/f ;
 
-M: windows normalize-directory ( string -- string )
+M: windows >directory-entry ( byte-array -- directory-entry )
-    normalize-path "\\" ?tail drop "\\*" append ;
+    [ WIN32_FIND_DATA-cFileName utf16n alien>string ]
+    [ WIN32_FIND_DATA-dwFileAttributes ]
+    bi directory-entry boa ;
+
+: find-first-file ( path -- WIN32_FIND_DATA handle )
+    "WIN32_FIND_DATA" <c-object> tuck
+    FindFirstFile
+    [ INVALID_HANDLE_VALUE = [ win32-error ] when ] keep ;
+
+: find-next-file ( path -- WIN32_FIND_DATA/f )
+    "WIN32_FIND_DATA" <c-object> tuck
+    FindNextFile 0 = [
+        GetLastError ERROR_NO_MORE_FILES = [
+            win32-error
+        ] unless drop f
+    ] when ;
+
+M: windows (directory-entries) ( path -- seq )
+    "\\" ?tail drop "\\*" append
+    find-first-file [ >directory-entry ] dip
+    [
+        '[
+            [ _ find-next-file dup ]
+            [ >directory-entry ]
+            [ drop ] produce
+            over name>> "." = [ nip ] [ swap prefix ] if
+        ]
+    ] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ;
 
 SYMBOLS: +read-only+ +hidden+ +system+
 +archive+ +device+ +normal+ +temporary+
@@ -218,6 +246,58 @@ 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 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 >>type
+        swap >>mount-point ;
+
+: 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 )
     [
         normalize-path open-existing &dispose handle>>

basis/io/windows/files/unique/unique.factor

@@ -1,6 +1,6 @@
 USING: kernel system io.files.unique.backend
 windows.kernel32 io.windows io.windows.files io.ports windows
-destructors ;
+destructors environment ;
 IN: io.windows.files.unique
 
 M: windows (make-unique-file) ( path -- )

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

@@ -1,7 +1,7 @@
 USING: continuations destructors io.buffers io.files io.backend
 io.timeouts io.ports io.windows io.windows.files
 io.windows.nt.backend windows windows.kernel32
-kernel libc math threads system
+kernel libc math threads system environment
 alien.c-types alien.arrays alien.strings sequences combinators
 combinators.short-circuit ascii splitting alien strings
 assocs namespaces make io.files.private accessors tr ;
@@ -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? [
@@ -59,3 +60,5 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
 M: winnt open-append
     [ dup file-info size>> ] [ drop 0 ] recover
     >r (open-append) r> >>ptr ;
+
+M: winnt home "USERPROFILE" os-env ;

basis/io/windows/nt/launcher/launcher-tests.factor

@@ -1,7 +1,7 @@
-IN: io.windows.launcher.nt.tests
+USING: io.launcher tools.test calendar accessors environment
-USING: io.launcher tools.test calendar accessors
 namespaces kernel system arrays io io.files io.encodings.ascii
 sequences parser assocs hashtables math continuations eval ;
+IN: io.windows.launcher.nt.tests
 
 [ ] [
     <process>

basis/io/windows/nt/launcher/test/env.factor

@@ -1,3 +1,4 @@
-USE: system
+USE: system
-USE: prettyprint
+USE: prettyprint
-os-envs .
+USE: environment
+os-envs .

basis/locals/locals-tests.factor

@@ -1,7 +1,7 @@
 USING: locals math sequences tools.test hashtables words kernel
 namespaces arrays strings prettyprint io.streams.string parser
 accessors generic eval combinators combinators.short-circuit
-combinators.short-circuit.smart math.order ;
+combinators.short-circuit.smart math.order math.functions ;
 IN: locals.tests
 
 :: foo ( a b -- a a ) a a ;
@@ -305,17 +305,29 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 [ f ] [ 8 &&-test ] unit-test
 [ t ] [ 12 &&-test ] unit-test
 
-:: wlet-&&-test ( a -- ? )
+:: let-and-cond-test-1 ( -- a )
-    [wlet | is-integer? [ a integer? ]
+    [let | a [ 10 ] |
-            is-even? [ a even? ]
+        [let | a [ 20 ] |
-            >10? [ a 10 > ] |
+            {
-        { [ is-integer? ] [ is-even? ] [ >10? ] } &&
+                { [ t ] [ [let | c [ 30 ] | a ] ] }
+            } cond
+        ]
     ] ;
 
-! [ f ] [ 1.5 wlet-&&-test ] unit-test
+\ let-and-cond-test-1 must-infer
-! [ f ] [ 3 wlet-&&-test ] unit-test
+
-! [ f ] [ 8 wlet-&&-test ] unit-test
+[ 20 ] [ let-and-cond-test-1 ] unit-test
-! [ t ] [ 12 wlet-&&-test ] unit-test
+
+:: let-and-cond-test-2 ( -- pair )
+    [let | A [ 10 ] |
+        [let | B [ 20 ] |
+            { { [ t ] [ { A B } ] } } cond
+        ]
+    ] ;
+
+\ let-and-cond-test-2 must-infer
+
+[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
 
 [ { 10       } ] [ 10       [| a     | { a     } ] call ] unit-test
 [ { 10 20    } ] [ 10 20    [| a b   | { a b   } ] call ] unit-test
@@ -333,6 +345,16 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 
 { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
 
+
+:: literal-identity-test ( -- a b )
+    { } V{ } ;
+
+[ t f ] [
+    literal-identity-test
+    literal-identity-test
+    swapd [ eq? ] [ eq? ] 2bi*
+] unit-test
+
 :: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
     obj1 obj2 <=> {
         { +lt+ [ lt-quot call ] }
@@ -340,4 +362,30 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
         { +gt+ [ gt-quot call ] }
     } case ; inline
 
-[ [ ] [ ] [ ] compare-case ] must-infer
+[ [ ] [ ] [ ] compare-case ] must-infer
+
+:: big-case-test ( a -- b )
+    a {
+        { 0 [ a 1 + ] }
+        { 1 [ a 1 - ] }
+        { 2 [ a 1 swap / ] }
+        { 3 [ a dup * ] }
+        { 4 [ a sqrt ] }
+        { 5 [ a a ^ ] }
+    } case ;
+
+\ big-case-test must-infer
+
+[ 9 ] [ 3 big-case-test ] unit-test
+
+! :: wlet-&&-test ( a -- ? )
+!     [wlet | is-integer? [ a integer? ]
+!             is-even? [ a even? ]
+!             >10? [ a 10 > ] |
+!         { [ is-integer? ] [ is-even? ] [ >10? ] } &&
+!     ] ;
+
+! [ f ] [ 1.5 wlet-&&-test ] unit-test
+! [ f ] [ 3 wlet-&&-test ] unit-test
+! [ f ] [ 8 wlet-&&-test ] unit-test
+! [ t ] [ 12 wlet-&&-test ] unit-test

basis/locals/locals.factor

@@ -35,11 +35,15 @@ C: <wlet> wlet
 
 M: lambda expand-macros clone [ expand-macros ] change-body ;
 
+M: lambda expand-macros* expand-macros literal ;
+
 M: binding-form expand-macros
     clone
         [ [ expand-macros ] assoc-map ] change-bindings
         [ expand-macros ] change-body ;
 
+M: binding-form expand-macros* expand-macros literal ;
+
 PREDICATE: local < word "local?" word-prop ;
 
 : <local> ( name -- word )
@@ -142,12 +146,12 @@ GENERIC: free-vars* ( form -- )
     [ free-vars* ] { } make prune ;
 
 : add-if-free ( object -- )
-  {
+    {
-      { [ dup local-writer? ] [ "local-reader" word-prop , ] }
+        { [ dup local-writer? ] [ "local-reader" word-prop , ] }
-      { [ dup lexical? ]      [ , ] }
+        { [ dup lexical? ] [ , ] }
-      { [ dup quote? ]        [ local>> , ] }
+        { [ dup quote? ] [ local>> , ] }
-      { [ t ]                 [ free-vars* ] }
+        { [ t ] [ free-vars* ] }
-  } cond ;
+    } cond ;
 
 M: object free-vars* drop ;
 
@@ -195,6 +199,20 @@ M: block lambda-rewrite*
         swap point-free ,
     ] keep length \ curry <repetition> % ;
 
+GENERIC: rewrite-literal? ( obj -- ? )
+
+M: special rewrite-literal? drop t ;
+
+M: array rewrite-literal? [ rewrite-literal? ] contains? ;
+
+M: hashtable rewrite-literal? drop t ;
+
+M: vector rewrite-literal? drop t ;
+
+M: tuple rewrite-literal? drop t ;
+
+M: object rewrite-literal? drop f ;
+
 GENERIC: rewrite-element ( obj -- )
 
 : rewrite-elements ( seq -- )
@@ -203,7 +221,8 @@ GENERIC: rewrite-element ( obj -- )
 : rewrite-sequence ( seq -- )
     [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
 
-M: array rewrite-element rewrite-sequence ;
+M: array rewrite-element
+    dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
 
 M: vector rewrite-element rewrite-sequence ;
 
@@ -441,7 +460,7 @@ M: lambda-memoized definition
     "lambda" word-prop body>> ;
 
 M: lambda-memoized reset-word
-    [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+    [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
 
 : method-stack-effect ( method -- effect )
     dup "lambda" word-prop vars>>

basis/logging/server/server.factor

@@ -83,7 +83,7 @@ SYMBOL: log-files
 
 : (rotate-logs) ( -- )
     (close-logs)
-    log-root directory [ drop rotate-log ] assoc-each ;
+    log-root directory-files [ rotate-log ] each ;
 
 : log-server-loop ( -- )
     receive unclip {

basis/macros/expander/expander.factor

@@ -1,14 +1,12 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences namespaces make quotations accessors
+USING: kernel sequences sequences.private namespaces make
-words continuations vectors effects math
+quotations accessors words continuations vectors effects math
-stack-checker.transforms ;
+generalizations stack-checker.transforms fry ;
 IN: macros.expander
 
 GENERIC: expand-macros ( quot -- quot' )
 
-<PRIVATE
-
 SYMBOL: stack
 
 : begin ( -- ) V{ } clone stack set ;
@@ -28,6 +26,17 @@ GENERIC: expand-macros* ( obj -- )
 
 M: wrapper expand-macros* wrapped>> literal ;
 
+: expand-dispatch? ( word -- ? )
+    \ dispatch eq? stack get length 1 >= and ;
+
+: expand-dispatch ( -- )
+    stack get pop end
+    [ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
+    [
+        length [ <reversed> ] keep
+        [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
+    ] bi ;
+
 : expand-macro ( quot -- )
     stack [ swap with-datastack >vector ] change
     stack get pop >quotation end (expand-macros) ;
@@ -38,8 +47,14 @@ M: wrapper expand-macros* wrapped>> literal ;
         stack get length <=
     ] [ 2drop f f ] if ;
 
+: word, ( word -- ) end , ;
+
 M: word expand-macros*
-    dup expand-macro? [ nip expand-macro ] [ drop end , ] if ;
+    dup expand-dispatch? [ drop expand-dispatch ] [
+        dup expand-macro? [ nip expand-macro ] [
+            drop word,
+        ] if
+    ] if ;
 
 M: object expand-macros* literal ;
 
@@ -48,5 +63,3 @@ M: callable expand-macros*
 
 M: callable expand-macros ( quot -- quot' )
     [ begin (expand-macros) end ] [ ] make ;
-
-PRIVATE>

basis/stack-checker/known-words/known-words.factor

@@ -396,8 +396,6 @@ do-primitive alien-invoke alien-indirect alien-callback
 
 \ (exists?) { string } { object } define-primitive
 
-\ (directory) { string } { array } define-primitive
-
 \ gc { } { } define-primitive
 
 \ gc-stats { } { array } define-primitive
@@ -412,8 +410,6 @@ do-primitive alien-invoke alien-indirect alien-callback
 \ code-room { } { integer integer integer integer } define-primitive
 \ code-room  make-flushable
 
-\ os-env { string } { object } define-primitive
-
 \ millis { } { integer } define-primitive
 \ millis make-flushable
 
@@ -590,14 +586,6 @@ do-primitive alien-invoke alien-indirect alien-callback
 
 \ set-innermost-frame-quot { quotation callstack } { } define-primitive
 
-\ (os-envs) { } { array } define-primitive
-
-\ set-os-env { string string } { } define-primitive
-
-\ unset-os-env { string } { } define-primitive
-
-\ (set-os-envs) { array } { } define-primitive
-
 \ dll-valid? { object } { object } define-primitive
 
 \ modify-code-heap { array object } { } define-primitive

basis/tools/deploy/deploy-tests.factor

@@ -1,7 +1,8 @@
 IN: tools.deploy.tests
 USING: tools.test system io.files kernel tools.deploy.config
 tools.deploy.backend math sequences io.launcher arrays
-namespaces continuations layouts accessors ;
+namespaces continuations layouts accessors io.encodings.ascii
+urls math.parser ;
 
 : shake-and-bake ( vocab -- )
     [ "test.image" temp-file delete-file ] ignore-errors
@@ -38,7 +39,7 @@ namespaces continuations layouts accessors ;
 ! [ ] [ "tetris" shake-and-bake ] unit-test
 ! 
 ! [ t ] [ 1500000 small-enough? ] unit-test
-! 
+
 [ ] [ "bunny" shake-and-bake ] unit-test
 
 [ t ] [ 2500000 small-enough? ] unit-test
@@ -71,22 +72,24 @@ M: quit-responder call-responder*
 : add-quot-responder ( responder -- responder )
     quit-responder "quit" add-responder ;
 
-: test-httpd ( -- )
+: test-httpd ( responder -- )
-    #! Return as soon as server is running.
+    [
-    <http-server>
+        main-responder set
-        1237 >>insecure
+        <http-server>
-        f >>secure
+            0 >>insecure
-    start-server* ;
+            f >>secure
+        dup start-server*
+        sockets>> first addr>> port>>
+        dup number>string "resource:temp/port-number" ascii set-file-contents
+    ] with-scope
+    "port" set ;
 
 [ ] [
-    [
+    <dispatcher>
-        <dispatcher>
+        add-quot-responder
-            add-quot-responder
+        "resource:basis/http/test" <static> >>default
-            "resource:basis/http/test" <static> >>default
-        main-responder set
 
-        test-httpd
+    test-httpd
-    ] with-scope
 ] unit-test
 
 [ ] [
@@ -94,7 +97,10 @@ M: quit-responder call-responder*
     run-temp-image
 ] unit-test
 
-[ ] [ "http://localhost:1237/quit" http-get 2drop ] unit-test
+: add-port ( url -- url' )
+    >url clone "port" get >>port ;
+
+[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
 
 [ ] [
     "tools.deploy.test.6" shake-and-bake

basis/tools/deploy/test/5/5.factor

@@ -1,7 +1,10 @@
 IN: tools.deploy.test.5
-USING: http.client kernel ;
+USING: accessors urls io.encodings.ascii io.files math.parser
+http.client kernel ;
 
 : deploy-test-5 ( -- )
-    "http://localhost:1237/foo.html" http-get 2drop ;
+    URL" http://localhost/foo.html" clone
+    "resource:port-number" ascii file-contents string>number >>port
+    http-get 2drop ;
 
 MAIN: deploy-test-5

basis/tools/scaffold/scaffold.factor

@@ -16,13 +16,18 @@ ERROR: vocab-name-contains-dot path ;
 ERROR: no-vocab vocab ;
 
 <PRIVATE
-: root? ( string -- ? )
+
-    vocab-roots get member?  ;
+: root? ( string -- ? ) vocab-roots get member?  ;
+
+: length-changes? ( seq quot -- ? )
+    dupd call [ length ] bi@ = not ; inline
 
 : check-vocab-name ( string -- string )
-    dup dup [ CHAR: . = ] trim [ length ] bi@ =
+    dup [ [ CHAR: . = ] trim ] length-changes?
-    [ vocab-name-contains-dot ] unless
+    [ vocab-name-contains-dot ] when
+
     ".." over subseq? [ vocab-name-contains-dot ] when
+
     dup [ path-separator? ] contains?
     [ vocab-name-contains-separator ] when ;
 
@@ -43,8 +48,11 @@ ERROR: no-vocab vocab ;
 : scaffolding ( path -- )
     "Creating scaffolding for " write <pathname> . ;
 
+: (scaffold-path) ( path string -- path )
+    dupd [ file-name ] dip append append-path ;
+
 : scaffold-path ( path string -- path ? )
-    dupd [ file-name ] dip append append-path
+    (scaffold-path)
     dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ;
 
 : scaffold-copyright ( -- )
@@ -205,14 +213,15 @@ ERROR: no-vocab vocab ;
 
 : check-vocab ( vocab -- vocab )
     dup find-vocab-root [ no-vocab ] unless ;
+
 PRIVATE>
 
 : link-vocab ( vocab -- )
     check-vocab
     "Edit documentation: " write
-    [ find-vocab-root ] keep
+    [ find-vocab-root ]
-    [ append-path ] keep "-docs.factor" append append-path
+    [ vocab>scaffold-path ] bi
-    <pathname> . ;
+    "-docs.factor" (scaffold-path) <pathname> . ;
 
 : help. ( word -- )
     [ (help.) ] [ nl vocabulary>> link-vocab ] bi ;

basis/tools/test/test.factor

@@ -12,6 +12,7 @@ SYMBOL: failures
     error-continuation get 3array ;
 
 : failure ( error what -- )
+    "--> test failed!" print
     <failure> failures get push ;
 
 SYMBOL: this-test

basis/tools/vocabs/vocabs.factor

@@ -14,8 +14,7 @@ IN: tools.vocabs
 : vocab-tests-dir ( vocab -- paths )
     dup vocab-dir "tests" append-path vocab-append-path dup [
         dup exists? [
-            dup directory keys
+            dup directory-files [ ".factor" tail? ] filter
-            [ ".factor" tail? ] filter
             [ append-path ] with map
         ] [ drop f ] if
     ] [ drop f ] if ;
@@ -208,11 +207,15 @@ M: vocab-link summary vocab-summary ;
     dup vocab-authors-path set-vocab-file-contents ;
 
 : subdirs ( dir -- dirs )
-    directory [ second ] filter keys natural-sort ;
+    [
+        [ link-info directory? ] filter
+    ] with-directory-files natural-sort ;
 
 : (all-child-vocabs) ( root name -- vocabs )
-    [ vocab-dir append-path subdirs ] keep
     [
+        vocab-dir append-path dup exists?
+        [ subdirs ] [ drop { } ] if
+    ] keep [
         swap [ "." swap 3append ] with map
     ] unless-empty ;
 

basis/ui/cocoa/views/views.factor

@@ -128,12 +128,12 @@ CLASS: {
 }
 
 ! Rendering
-{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
+{ "drawRect:" "void" { "id" "SEL" "NSRect" }
-    [ 3drop window relayout-1 ]
+    [ 2drop window relayout-1 ]
 }
 
 ! Events
-{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
+{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" }
     [ 3drop 1 ]
 }
 
@@ -251,7 +251,7 @@ CLASS: {
 
 ! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
 
-{ "acceptsFirstResponder" "bool" { "id" "SEL" }
+{ "acceptsFirstResponder" "char" { "id" "SEL" }
     [ 2drop 1 ]
 }
 
@@ -264,26 +264,26 @@ CLASS: {
     ]
 }
 
-{ "writeSelectionToPasteboard:types:" "bool" { "id" "SEL" "id" "id" }
+{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
     [
         CF>string-array NSStringPboardType swap member? [
             >r drop window-focus gadget-selection dup [
-                r> set-pasteboard-string t
+                r> set-pasteboard-string 1
             ] [
-                r> 2drop f
+                r> 2drop 0
             ] if
         ] [
-            3drop f
+            3drop 0
         ] if
     ]
 }
 
-{ "readSelectionFromPasteboard:" "bool" { "id" "SEL" "id" }
+{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
     [
         pasteboard-string dup [
-            >r drop window-focus r> swap user-input t
+            >r drop window-focus r> swap user-input 1
         ] [
-            3drop f
+            3drop 0
         ] if
     ]
 }
@@ -293,7 +293,7 @@ CLASS: {
     [ [ nip send-user-input ] ui-try ]
 }
 
-{ "hasMarkedText" "bool" { "id" "SEL" }
+{ "hasMarkedText" "char" { "id" "SEL" }
     [ 2drop 0 ]
 }
 
@@ -321,7 +321,7 @@ CLASS: {
     [ 3drop f ]
 }
 
-{ "characterIndexForPoint:" "uint" { "id" "SEL" "NSPoint" }
+{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" }
     [ 3drop 0 ]
 }
 
@@ -329,7 +329,7 @@ CLASS: {
     [ 3drop 0 0 0 0 <NSRect> ]
 }
 
-{ "conversationIdentifier" "long" { "id" "SEL" }
+{ "conversationIdentifier" "NSInteger" { "id" "SEL" }
     [ drop alien-address ]
 }
 
@@ -394,9 +394,9 @@ CLASS: {
     ]
 }
 
-{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
+{ "windowShouldClose:" "char" { "id" "SEL" "id" }
     [
-        3drop t
+        3drop 1
     ]
 }
 

basis/ui/tools/listener/listener-tests.factor

@@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
 ui.tools.listener hashtables kernel namespaces parser sequences
 tools.test ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads arrays generic threads accessors listener ;
+threads arrays generic threads accessors listener math ;
 IN: ui.tools.listener.tests
 
 [ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
@@ -51,3 +51,5 @@ IN: ui.tools.listener.tests
 
     [ ] [ "listener" get com-end ] unit-test
 ] with-grafted-gadget
+
+[ ] [ \ + <pane> <interactor> interactor-use use-if-necessary ] unit-test

basis/ui/tools/listener/listener.factor

@@ -101,8 +101,8 @@ M: engine-word word-completion-string
     "engine-generic" word-prop word-completion-string ;
 
 : use-if-necessary ( word seq -- )
-    over vocabulary>> [
+    over vocabulary>> over and [
-        2dup assoc-stack pick = [ 2drop ] [
+        2dup [ assoc-stack ] keep = [ 2drop ] [
             >r vocabulary>> vocab-words r> push
         ] if
     ] [ 2drop ] if ;
@@ -114,9 +114,10 @@ M: engine-word word-completion-string
     2bi ;
 
 : quot-action ( interactor -- lines )
-    dup control-value
+    [ control-value ] keep
-    dup "\n" join pick add-interactor-history
+    [ [ "\n" join ] dip add-interactor-history ]
-    swap select-all ;
+    [ select-all ]
+    2bi ;
 
 TUPLE: stack-display < track ;
 

basis/ui/tools/tools.factor

@@ -40,11 +40,11 @@ IN: ui.tools
 
 : resize-workspace ( workspace -- )
     dup sizes>> over control-value zero? [
-        1/5 1 pick set-nth
+        1/5 over set-second
-        4/5 2 rot set-nth
+        4/5 swap set-third
     ] [
-        2/3 1 pick set-nth
+        2/3 over set-second
-        1/3 2 rot set-nth
+        1/3 swap set-third
     ] if relayout ;
 
 M: workspace model-changed

basis/ui/x11/x11.factor

@@ -6,8 +6,8 @@ assocs kernel math namespaces opengl sequences strings x11.xlib
 x11.events x11.xim x11.glx x11.clipboard x11.constants
 x11.windows io.encodings.string io.encodings.ascii
 io.encodings.utf8 combinators debugger command-line qualified
-math.vectors classes.tuple opengl.gl threads math.geometry.rect ;
+math.vectors classes.tuple opengl.gl threads math.geometry.rect
-QUALIFIED: system
+environment ;
 IN: ui.x11
 
 SINGLETON: x11-ui-backend
@@ -262,5 +262,5 @@ M: x11-ui-backend beep ( -- )
 
 x11-ui-backend ui-backend set-global
 
-[ "DISPLAY" system:os-env "ui" "listener" ? ]
+[ "DISPLAY" os-env "ui" "listener" ? ]
 main-vocab-hook set-global

basis/unix/bsd/bsd.factor

@@ -3,8 +3,6 @@
 USING: alien.syntax combinators system vocabs.loader ;
 IN: unix
 
-! FreeBSD
-
 : MAXPATHLEN 1024 ; inline
 
 : O_RDONLY   HEX: 0000 ; inline
@@ -85,6 +83,16 @@ C-STRUCT: passwd
 : SEEK_CUR 1 ; inline
 : SEEK_END 2 ; inline
 
+: DT_UNKNOWN   0 ; inline
+: DT_FIFO      1 ; inline
+: DT_CHR       2 ; inline
+: DT_DIR       4 ; inline
+: DT_BLK       6 ; inline
+: DT_REG       8 ; inline
+: DT_LNK      10 ; inline
+: DT_SOCK     12 ; inline
+: DT_WHT      14 ; inline
+
 os {
     { macosx  [ "unix.bsd.macosx"  require ] }
     { freebsd [ "unix.bsd.freebsd" require ] }

basis/unix/bsd/freebsd/freebsd.factor

@@ -13,6 +13,13 @@ C-STRUCT: addrinfo
     { "void*" "addr" }
     { "addrinfo*" "next" } ;
 
+C-STRUCT: dirent
+    { "u_int32_t" "d_fileno" }
+    { "u_int16_t" "d_reclen" }
+    { "u_int8_t"  "d_type" }
+    { "u_int8_t"  "d_namlen" }
+    { { "char" 256 } "d_name" } ;
+
 : EPERM 1 ; inline
 : ENOENT 2 ; inline
 : ESRCH 3 ; inline

basis/unix/bsd/macosx/macosx.factor

@@ -13,6 +13,32 @@ C-STRUCT: addrinfo
     { "void*" "addr" }
     { "addrinfo*" "next" } ;
 
+: _UTX_USERSIZE 256 ; inline
+: _UTX_LINESIZE 32 ; inline
+: _UTX_IDSIZE 4 ; inline
+: _UTX_HOSTSIZE 256 ; inline
+    
+C-STRUCT: utmpx
+    { { "char" _UTX_USERSIZE } "ut_user" }
+    { { "char" _UTX_IDSIZE } "ut_id" }
+    { { "char" _UTX_LINESIZE } "ut_line" }
+    { "pid_t" "ut_pid" }
+    { "short" "ut_type" }
+    { "timeval" "ut_tv" }
+    { { "char" _UTX_HOSTSIZE } "ut_host" }
+    { { "uint" 16 } "ut_pad" } ;
+
+: __DARWIN_MAXPATHLEN 1024 ; inline
+: __DARWIN_MAXNAMELEN 255 ; inline
+: __DARWIN_MAXNAMELEN+1 255 ; inline
+
+C-STRUCT: dirent
+    { "ino_t" "d_ino" }
+    { "__uint16_t" "d_reclen" }
+    { "__uint8_t"  "d_type" }
+    { "__uint8_t"  "d_namlen" }
+    { { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ;
+
 : EPERM 1 ; inline
 : ENOENT 2 ; inline
 : ESRCH 3 ; inline
@@ -117,18 +143,3 @@ C-STRUCT: addrinfo
 : ETIME 101 ; inline
 : EOPNOTSUPP 102 ; inline
 : ENOPOLICY 103 ; inline
-
-: _UTX_USERSIZE 256 ; inline
-: _UTX_LINESIZE 32 ; inline
-: _UTX_IDSIZE 4 ; inline
-: _UTX_HOSTSIZE 256 ; inline
-    
-C-STRUCT: utmpx
-    { { "char" _UTX_USERSIZE } "ut_user" }
-    { { "char" _UTX_IDSIZE } "ut_id" }
-    { { "char" _UTX_LINESIZE } "ut_line" }
-    { "pid_t" "ut_pid" }
-    { "short" "ut_type" }
-    { "timeval" "ut_tv" }
-    { { "char" _UTX_HOSTSIZE } "ut_host" }
-    { { "uint" 16 } "ut_pad" } ;

basis/unix/bsd/netbsd/netbsd.factor

@@ -13,6 +13,13 @@ C-STRUCT: addrinfo
     { "void*" "addr" }
     { "addrinfo*" "next" } ;
 
+C-STRUCT: dirent
+    { "__uint32_t" "d_fileno" }
+    { "__uint16_t" "d_reclen" }
+    { "__uint8_t"  "d_type" }
+    { "__uint8_t"  "d_namlen" }
+    { { "char" 256 } "d_name" } ;
+
 : EPERM 1 ; inline
 : ENOENT 2 ; inline
 : ESRCH 3 ; inline

basis/unix/bsd/openbsd/openbsd.factor

@@ -13,6 +13,13 @@ C-STRUCT: addrinfo
     { "char*" "canonname" }
     { "addrinfo*" "next" } ;
 
+C-STRUCT: dirent
+    { "__uint32_t" "d_fileno" }
+    { "__uint16_t" "d_reclen" }
+    { "__uint8_t"  "d_type" }
+    { "__uint8_t"  "d_namlen" }
+    { { "char" 256 } "d_name" } ;
+
 : EPERM 1 ; inline
 : ENOENT 2 ; inline
 : ESRCH 3 ; inline

basis/unix/groups/groups.factor

@@ -4,7 +4,7 @@ USING: alien alien.c-types alien.strings io.encodings.utf8
 io.unix.backend kernel math sequences splitting unix strings
 combinators.short-circuit byte-arrays combinators qualified
 accessors math.parser fry assocs namespaces continuations
-unix.users ;
+unix.users unix.utilities ;
 IN: unix.groups
 
 QUALIFIED: grouping
@@ -18,12 +18,7 @@ GENERIC: group-struct ( obj -- group )
 <PRIVATE
 
 : group-members ( group-struct -- seq )
-    group-gr_mem
+    group-gr_mem utf8 alien>strings ;
-    [ dup { [ ] [ *void* ] } 1&& ]
-    [
-        dup *void* utf8 alien>string
-        [ alien-address "char**" heap-size + <alien> ] dip
-    ] [ ] produce nip ;
 
 : (group-struct) ( id -- group-struct id group-struct byte-array length void* )
     "group" <c-object> tuck 4096

basis/unix/linux/fs/fs.factor

@@ -1,6 +1,4 @@
-
 USING: alien.syntax ;
-
 IN: unix.linux.fs
 
 : MS_RDONLY             1    ; ! Mount read-only.
@@ -22,4 +20,4 @@ FUNCTION: int mount
 
 ! FUNCTION: int umount2 ( char* file, int flags ) ;
 
-FUNCTION: int umount ( char* file ) ;
+FUNCTION: int umount ( char* file ) ;

basis/unix/linux/linux.factor

@@ -92,6 +92,13 @@ C-STRUCT: passwd
     { "char*"  "pw_dir" }
     { "char*"  "pw_shell" } ;
 
+C-STRUCT: dirent
+    { "__ino_t" "d_ino" }
+    { "__off_t" "d_off" }
+    { "ushort" "d_reclen" }
+    { "uchar" "d_type" }
+    { { "char" 256 } "d_name" } ;
+
 : EPERM 1 ; inline
 : ENOENT 2 ; inline
 : ESRCH 3 ; inline

basis/unix/process/process.factor

@@ -1,6 +1,6 @@
 USING: kernel alien.c-types alien.strings sequences math alien.syntax unix
-       vectors kernel namespaces continuations threads assocs vectors
+vectors kernel namespaces continuations threads assocs vectors
-       io.unix.backend io.encodings.utf8 ;
+io.unix.backend io.encodings.utf8 unix.utilities ;
 IN: unix.process
 
 ! Low-level Unix process launching utilities. These are used
@@ -15,17 +15,16 @@ FUNCTION: int execv ( char* path, char** argv ) ;
 FUNCTION: int execvp ( char* path, char** argv ) ;
 FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
 
-: >argv ( seq -- alien )
-    [ utf8 malloc-string ] map f suffix >c-void*-array ;
-
 : exec ( pathname argv -- int )
-    [ utf8 malloc-string ] [ >argv ] bi* execv ;
+    [ utf8 malloc-string ] [ utf8 strings>alien ] bi* execv ;
 
 : exec-with-path ( filename argv -- int )
-    [ utf8 malloc-string ] [ >argv ] bi* execvp ;
+    [ utf8 malloc-string ] [ utf8 strings>alien ] bi* execvp ;
 
 : exec-with-env ( filename argv envp -- int )
-    [ utf8 malloc-string ] [ >argv ] [ >argv ] tri* execve ;
+    [ utf8 malloc-string ]
+    [ utf8 strings>alien ]
+    [ utf8 strings>alien ] tri* execve ;
 
 : exec-args ( seq -- int )
     [ first ] [ ] bi exec ;
@@ -99,4 +98,4 @@ FUNCTION: pid_t wait ( int* status ) ;
 FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
 
 : wait-for-pid ( pid -- status )
-    0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
+    0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;

basis/unix/stat/linux/32/32.factor

@@ -1,6 +1,4 @@
-
 USING: kernel alien.syntax math ;
-
 IN: unix.stat
 
 ! Ubuntu 8.04 32-bit
@@ -24,8 +22,6 @@ C-STRUCT: stat
     { "ulong"     "unused4" }
     { "ulong"     "unused5" } ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 FUNCTION: int __xstat  ( int ver, char* pathname, stat* buf ) ;
 FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
 

basis/unix/stat/linux/64/64.factor

@@ -1,6 +1,5 @@
-
+USING: kernel alien.syntax math sequences unix
-USING: kernel alien.syntax math ;
+alien.c-types arrays accessors combinators ;
-
 IN: unix.stat
 
 ! Ubuntu 7.10 64-bit

basis/unix/stat/linux/linux.factor

@@ -1,11 +1,8 @@
-
+USING: alien.syntax layouts combinators vocabs.loader ;
-USING: layouts combinators vocabs.loader ;
-
 IN: unix.stat
 
 cell-bits
-  {
+{
     { 32 [ "unix.stat.linux.32" require ] }
     { 64 [ "unix.stat.linux.64" require ] }
-  }
+} case
-case

basis/unix/stat/macosx/macosx.factor

@@ -1,4 +1,5 @@
-USING: kernel alien.syntax math ;
+USING: kernel alien.syntax math unix math.bitwise
+alien.c-types alien sequences grouping accessors combinators ;
 IN: unix.stat
 
 ! Mac OS X ppc

basis/unix/stat/netbsd/netbsd.factor

@@ -1,4 +1,4 @@
-USING: layouts combinators vocabs.loader ;
+USING: layouts combinators vocabs.loader alien.syntax ;
 IN: unix.stat
 
 cell-bits {

basis/unix/stat/stat.factor

@@ -18,6 +18,12 @@ FUNCTION: int chmod ( char* path, mode_t mode ) ;
 FUNCTION: int fchmod ( int fd, mode_t mode ) ;
 FUNCTION: int mkdir ( char* path, mode_t mode ) ;
 
+C-STRUCT: fsid
+    { { "int" 2 } "__val" } ;
+
+    TYPEDEF: fsid __fsid_t
+    TYPEDEF: fsid fsid_t
+
 << os {
     { linux   [ "unix.stat.linux"   require ] }
     { macosx  [ "unix.stat.macosx"  require ] }
@@ -27,11 +33,7 @@ FUNCTION: int mkdir ( char* path, mode_t mode ) ;
 } case >>
 
 : file-status ( pathname -- stat )
-    "stat" <c-object> [
+    "stat" <c-object> [ [ stat ] unix-system-call drop ] keep ;
-        [ stat ] unix-system-call drop
-    ] keep ;
 
 : link-status ( pathname -- stat )
-    "stat" <c-object> [
+    "stat" <c-object> [ [ lstat ] unix-system-call drop ] keep ;
-        [ lstat ] unix-system-call drop
-    ] keep ;

basis/unix/statfs/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/unix/statfs/freebsd/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/unix/statfs/freebsd/freebsd.factor

@@ -0,0 +1,53 @@
+! 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 ;
+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 ;

basis/unix/statfs/freebsd/tags.txt

@@ -0,0 +1 @@
+unportable

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

@@ -0,0 +1,46 @@
+! 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
+type 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 ;

basis/unix/statfs/linux/32/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/unix/statfs/linux/32/tags.txt

@@ -0,0 +1 @@
+unportable

basis/unix/statfs/linux/64/64.factor

@@ -0,0 +1,50 @@
+! 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
+type 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 ;

basis/unix/statfs/linux/64/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/unix/statfs/linux/64/tags.txt

@@ -0,0 +1 @@
+unportable

basis/unix/statfs/linux/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/unix/statfs/linux/linux.factor

@@ -0,0 +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
+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>> >>mount-point ]
+            [ type>> >>type ]
+        } cleave
+    ] map ;

basis/unix/statfs/linux/tags.txt

@@ -0,0 +1 @@
+unportable

basis/unix/statfs/macosx/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/unix/statfs/macosx/macosx.factor

@@ -0,0 +1,165 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+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 ;
+IN: unix.statfs.macosx
+
+: MNT_RDONLY  HEX: 00000001 ; inline
+: MNT_SYNCHRONOUS HEX: 00000002 ; inline
+: MNT_NOEXEC  HEX: 00000004 ; inline
+: MNT_NOSUID  HEX: 00000008 ; inline
+: MNT_NODEV   HEX: 00000010 ; inline
+: MNT_UNION   HEX: 00000020 ; inline
+: MNT_ASYNC   HEX: 00000040 ; inline
+: MNT_EXPORTED HEX: 00000100 ; inline
+: MNT_QUARANTINE  HEX: 00000400 ; inline
+: MNT_LOCAL   HEX: 00001000 ; inline
+: MNT_QUOTA   HEX: 00002000 ; inline
+: MNT_ROOTFS  HEX: 00004000 ; inline
+: MNT_DOVOLFS HEX: 00008000 ; inline
+: MNT_DONTBROWSE  HEX: 00100000 ; inline
+: MNT_IGNORE_OWNERSHIP HEX: 00200000 ; inline
+: MNT_AUTOMOUNTED HEX: 00400000 ; inline
+: MNT_JOURNALED   HEX: 00800000 ; inline
+: MNT_NOUSERXATTR HEX: 01000000 ; inline
+: MNT_DEFWRITE    HEX: 02000000 ; inline
+: MNT_MULTILABEL  HEX: 04000000 ; inline
+: MNT_NOATIME HEX: 10000000 ; inline
+: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP ; inline
+
+: MNT_VISFLAGMASK ( -- n )
+    {
+        MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC
+        MNT_NOSUID MNT_NODEV MNT_UNION
+        MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE
+        MNT_LOCAL MNT_QUOTA
+        MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE
+        MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED
+        MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME
+    } flags ; inline
+
+: MNT_UPDATE  HEX: 00010000 ; inline
+: MNT_RELOAD  HEX: 00040000 ; inline
+: MNT_FORCE   HEX: 00080000 ; inline
+: MNT_CMDFLAGS { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline
+
+: VFS_GENERIC 0 ; inline
+: VFS_NUMMNTOPS 1 ; inline
+: VFS_MAXTYPENUM 1 ; inline
+: VFS_CONF 2 ; inline
+: VFS_SET_PACKAGE_EXTS 3 ; inline
+
+: MNT_WAIT    1 ; inline
+: MNT_NOWAIT  2 ; inline
+
+: VFS_CTL_VERS1   HEX: 01 ; inline
+
+: VFS_CTL_STATFS  HEX: 00010001 ; inline
+: VFS_CTL_UMOUNT  HEX: 00010002 ; inline
+: VFS_CTL_QUERY   HEX: 00010003 ; inline
+: VFS_CTL_NEWADDR HEX: 00010004 ; inline
+: VFS_CTL_TIMEO   HEX: 00010005 ; inline
+: VFS_CTL_NOLOCKS HEX: 00010006 ; inline
+
+C-STRUCT: vfsquery
+    { "uint32_t" "vq_flags" }
+    { { "uint32_t" 31 } "vq_spare" } ;
+
+: VQ_NOTRESP  HEX: 0001 ; inline
+: VQ_NEEDAUTH HEX: 0002 ; inline
+: VQ_LOWDISK  HEX: 0004 ; inline
+: VQ_MOUNT    HEX: 0008 ; inline
+: VQ_UNMOUNT  HEX: 0010 ; inline
+: VQ_DEAD     HEX: 0020 ; inline
+: VQ_ASSIST   HEX: 0040 ; inline
+: VQ_NOTRESPLOCK  HEX: 0080 ; inline
+: VQ_UPDATE   HEX: 0100 ; inline
+: VQ_FLAG0200 HEX: 0200 ; inline
+: VQ_FLAG0400 HEX: 0400 ; inline
+: VQ_FLAG0800 HEX: 0800 ; inline
+: VQ_FLAG1000 HEX: 1000 ; inline
+: VQ_FLAG2000 HEX: 2000 ; inline
+: VQ_FLAG4000 HEX: 4000 ; inline
+: VQ_FLAG8000 HEX: 8000 ; inline
+
+: NFSV4_MAX_FH_SIZE 128 ; inline
+: NFSV3_MAX_FH_SIZE 64 ; inline
+: NFSV2_MAX_FH_SIZE 32 ; inline
+: NFS_MAX_FH_SIZE NFSV4_MAX_FH_SIZE ; inline
+
+: MFSNAMELEN 15 ; inline
+: MNAMELEN 90 ; inline
+: MFSTYPENAMELEN 16 ; inline
+
+C-STRUCT: fsid_t
+    { { "int32_t" 2 } "val" } ;
+
+C-STRUCT: statfs64
+    { "uint32_t"        "f_bsize" }
+    { "int32_t"         "f_iosize" }
+    { "uint64_t"        "f_blocks" }
+    { "uint64_t"        "f_bfree" }
+    { "uint64_t"        "f_bavail" }
+    { "uint64_t"        "f_files" }
+    { "uint64_t"        "f_ffree" }
+    { "fsid_t"          "f_fsid" }
+    { "uid_t"           "f_owner" }
+    { "uint32_t"        "f_type" }
+    { "uint32_t"        "f_flags" }
+    { "uint32_t"        "f_fssubtype" }
+    { { "char" MFSTYPENAMELEN } "f_fstypename" }
+    { { "char" MAXPATHLEN } "f_mntonname" }
+    { { "char" MAXPATHLEN } "f_mntfromname" }
+    { { "uint32_t" 8 } "f_reserved" } ;
+
+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 mounted ( -- 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 ;

basis/unix/statfs/macosx/tags.txt

@@ -0,0 +1 @@
+unportable

basis/unix/statfs/netbsd/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/unix/statfs/netbsd/netbsd.factor

@@ -0,0 +1,78 @@
+! 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_NAMELEN } "f_mntonname" }
+    { { "char" _VFS_NAMELEN } "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 ;

basis/unix/statfs/netbsd/tags.txt

@@ -0,0 +1 @@
+unportable

basis/unix/statfs/openbsd/32/32.factor

@@ -0,0 +1,26 @@
+! 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" } ;

basis/unix/statfs/openbsd/32/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/unix/statfs/openbsd/32/tags.txt

@@ -0,0 +1 @@
+unportable

basis/unix/statfs/openbsd/64/64.factor

@@ -0,0 +1,32 @@
+! 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" } ;                                        

basis/unix/statfs/openbsd/64/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/unix/statfs/openbsd/64/tags.txt

@@ -0,0 +1 @@
+unportable

basis/unix/statfs/openbsd/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/unix/statfs/openbsd/openbsd.factor

@@ -0,0 +1,53 @@
+! 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 ;
+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" } ;
+
+: ST_RDONLY       1 ; inline
+: ST_NOSUID       2 ; inline
+
+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 ;

basis/unix/statfs/openbsd/tags.txt

@@ -0,0 +1 @@
+unportable

basis/unix/statfs/statfs-tests.factor

@@ -0,0 +1,4 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test unix.statfs ;
+IN: unix.statfs.tests