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

basis/calendar/calendar-docs.factor

@@ -512,6 +512,12 @@ HELP: time-since-midnight
 { $values { "timestamp" timestamp } { "duration" duration } }
 { $description "Calculates a " { $snippet "duration" } " that represents the elapsed time since midnight of the input " { $snippet "timestamp" } "." } ;
 
+HELP: since-1970
+{ $values
+     { "duration" duration }
+     { "timestamp" timestamp } }
+{ $description "Adds the duration to the beginning of Unix time and returns the result as a timestamp." } ;
+
 ARTICLE: "calendar" "Calendar"
 "The two data types used throughout the calendar library:"
 { $subsection timestamp }

basis/calendar/calendar.factor

@@ -2,8 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math math.functions namespaces sequences
 strings system vocabs.loader threads accessors combinators
-locals classes.tuple math.order summary structs
+locals classes.tuple math.order summary combinators.short-circuit ;
-combinators.short-circuit ;
 IN: calendar
 
 HOOK: gmt-offset os ( -- hours minutes seconds )
@@ -402,9 +401,8 @@ PRIVATE>
 : time-since-midnight ( timestamp -- duration )
     dup midnight time- ;
 
-: timeval>unix-time ( timeval -- timestamp )
+: since-1970 ( duration -- timestamp )
-    [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
+    unix-1970 time+ >local-time ;
-    time+ unix-1970 time+ >local-time ;
 
 M: timestamp sleep-until timestamp>millis sleep-until ;
 

basis/calendar/unix/unix.factor

@@ -1,7 +1,23 @@
-USING: alien alien.c-types arrays calendar kernel structs
+! Copyright (C) 2008 Doug Coleman.
-math unix.time namespaces system ;
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.syntax arrays calendar
+kernel math unix unix.time namespaces system ;
 IN: calendar.unix
 
+: timeval>seconds ( timeval -- seconds )
+    [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
+    time+ ;
+
+: timeval>unix-time ( timeval -- timestamp )
+    timeval>seconds since-1970 ;
+
+: timespec>seconds ( timespec -- seconds )
+    [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
+    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/compiler/generator/fixup/fixup.factor

@@ -13,7 +13,7 @@ TUPLE: frame-required n ;
 
 : frame-required ( n -- ) \ frame-required boa , ;
 
-: stack-frame-size ( code -- n )
+: compute-stack-frame-size ( code -- n )
     no-stack-frame [
         dup frame-required? [ n>> max ] [ drop ] if
     ] reduce ;
@@ -37,7 +37,7 @@ M: label fixup*
 
 : if-stack-frame ( frame-size quot -- )
     swap dup no-stack-frame =
-    [ 2drop ] [ stack-frame swap call ] if ; inline
+    [ 2drop ] [ stack-frame-size swap call ] if ; inline
 
 M: word fixup*
     {
@@ -146,7 +146,7 @@ SYMBOL: literal-table
 : fixup ( code -- literals relocation labels code )
     [
         init-fixup
-        dup stack-frame-size swap [ fixup* ] each drop
+        dup compute-stack-frame-size swap [ fixup* ] each drop
 
         literal-table get >array
         relocation-table get >byte-array

basis/compiler/generator/generator.factor

@@ -296,24 +296,20 @@ M: #return-recursive generate-node
 
 : return-size ( ctype -- n )
     #! Amount of space we reserve for a return value.
-    dup large-struct? [ heap-size ] [ drop 0 ] if ;
+    dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
 
 : alien-stack-frame ( params -- n )
-    alien-parameters parameter-sizes drop ;
+    stack-frame new
+        swap
+        [ return>> return-size >>return ]
+        [ alien-parameters parameter-sizes drop >>params ] bi
+        dup [ params>> ] [ return>> ] bi + >>size
+        dup size>> stack-frame-size >>total-size ;
 
-: alien-invoke-frame ( params -- n )
+: with-stack-frame ( params quot -- )
-    #! Two cells for temporary storage, temp@ and on x86.64,
+    swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
-    #! small struct return value unpacking
-    [ return>> return-size ] [ alien-stack-frame ] bi
-    + 2 cells + ;
-
-: set-stack-frame ( n -- )
-    dup [ frame-required ] when* \ stack-frame set ;
-
-: with-stack-frame ( n quot -- )
-    swap set-stack-frame
     call
-    f set-stack-frame ; inline
+    stack-frame off ; inline
 
 GENERIC: reg-size ( register-class -- n )
 
@@ -416,8 +412,8 @@ M: long-long-type flatten-value-type ( type -- types )
     #! parameters. If the C function is returning a structure,
     #! the first parameter is an implicit target area pointer,
     #! so we need to use a different offset.
-    return>> dup large-struct?
+    return>> large-struct?
-    [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+    [ %prepare-box-struct cell ] [ 0 ] if ;
 
 : objects>registers ( params -- )
     #! Generate code for unboxing a list of C types, then
@@ -476,7 +472,7 @@ M: no-such-symbol compiler-error-type
 
 M: #alien-invoke generate-node
     params>>
-    dup alien-invoke-frame [
+    dup [
         end-basic-block
         %prepare-alien-invoke
         dup objects>registers
@@ -490,7 +486,7 @@ M: #alien-invoke generate-node
 ! #alien-indirect
 M: #alien-indirect generate-node
     params>>
-    dup alien-invoke-frame [
+    dup [
         ! Flush registers
         end-basic-block
         ! Save registers for GC
@@ -556,7 +552,7 @@ TUPLE: callback-context ;
 
 : callback-unwind ( params -- n )
     {
-        { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+        { [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] }
         { [ dup return>> large-struct? ] [ drop 4 ] }
         [ drop 0 ]
     } cond ;
@@ -572,7 +568,7 @@ TUPLE: callback-context ;
     dup xt>> dup [
         init-templates
         %prologue-later
-        dup alien-stack-frame [
+        dup [
             [ registers>objects ]
             [ wrap-callback-quot %alien-callback ]
             [ %callback-return ]

basis/core-foundation/run-loop/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-foundation/run-loop/summary.txt

@@ -0,0 +1 @@
+CoreFoundation run loop integration

basis/core-foundation/run-loop/thread/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/core-foundation/run-loop/thread/summary.txt

@@ -0,0 +1 @@
+Vocabulary with init hook for running CoreFoundation event loop

basis/core-foundation/run-loop/thread/tags.txt

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

basis/cpu/architecture/architecture.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic kernel kernel.private math memory
+USING: accessors arrays generic kernel kernel.private math
-namespaces make sequences layouts system hashtables classes
+memory namespaces make sequences layouts system hashtables
-alien byte-arrays combinators words sets ;
+classes alien byte-arrays combinators words sets ;
 IN: cpu.architecture
 
 ! Register classes
@@ -33,10 +33,9 @@ GENERIC# load-literal 1 ( obj vreg -- )
 
 HOOK: load-indirect cpu ( obj reg -- )
 
-HOOK: stack-frame cpu ( frame-size -- n )
+HOOK: stack-frame-size cpu ( frame-size -- n )
 
-: stack-frame* ( -- n )
+TUPLE: stack-frame total-size size params return ;
-    \ stack-frame get stack-frame ;
 
 ! Set up caller stack frame
 HOOK: %prologue cpu ( n -- )
@@ -117,7 +116,7 @@ HOOK: %box cpu ( n reg-class func -- )
 
 HOOK: %box-long-long cpu ( n func -- )
 
-HOOK: %prepare-box-struct cpu ( size -- )
+HOOK: %prepare-box-struct cpu ( -- )
 
 HOOK: %box-small-struct cpu ( c-type -- )
 

basis/cpu/ppc/architecture/architecture.factor

@@ -43,7 +43,7 @@ IN: cpu.ppc.architecture
 
 : xt-save ( n -- i ) 2 cells - ;
 
-M: ppc stack-frame ( n -- i )
+M: ppc stack-frame-size ( n -- i )
     local@ factor-area-size + 4 cells align ;
 
 M: temp-reg v>operand drop 11 ;
@@ -96,9 +96,9 @@ M: ppc %epilogue ( n -- )
     1 1 rot ADDI
     0 MTLR ;
 
-: (%call) ( -- ) 11 MTLR BLRL ;
+: (%call) ( reg -- ) MTLR BLRL ;
 
-: (%jump) ( -- ) 11 MTCTR BCTR ;
+: (%jump) ( reg -- ) MTCTR BCTR ;
 
 : %load-dlsym ( symbol dll register -- )
     0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
@@ -117,7 +117,7 @@ M: ppc %dispatch ( -- )
         "offset" operand "n" operand 1 SRAWI
         11 11 "offset" operand ADD
         11 dup 6 cells LWZ
-        (%jump)
+        11 (%jump)
     ] H{
         { +input+ { { f "n" } } }
         { +scratch+ { { f "offset" } } }
@@ -166,11 +166,13 @@ M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
 M: stack-params %load-param-reg ( stack reg reg-class -- )
     drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
 
+: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
+
 M: stack-params %save-param-reg ( stack reg reg-class -- )
     #! Funky. Read the parameter from the caller's stack frame.
     #! This word is used in callbacks
     drop
-    0 1 rot param@ stack-frame* + LWZ
+    0 1 rot next-param@ LWZ
     0 1 rot local@ STW ;
 
 M: ppc %prepare-unbox ( -- )
@@ -197,10 +199,8 @@ M: ppc %unbox-long-long ( n func -- )
 
 M: ppc %unbox-large-struct ( n c-type -- )
     ! Value must be in r3
-    ! Compute destination address
+    ! Compute destination address and load struct size
-    4 1 roll local@ ADDI
+    [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
-    ! Load struct size
-    heap-size 5 LI
     ! Call the function
     "to_value_struct" f %alien-invoke ;
 
@@ -218,23 +218,18 @@ M: ppc %box-long-long ( n func -- )
         4 1 rot cell + local@ LWZ
     ] when* r> f %alien-invoke ;
 
-: temp@ ( m -- n ) stack-frame* factor-area-size - swap - ;
+: struct-return@ ( n -- n )
+    [ stack-frame get params>> ] unless* local@ ;
 
-: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
+M: ppc %prepare-box-struct ( -- )
-
-M: ppc %prepare-box-struct ( size -- )
     #! Compute target address for value struct return
-    3 1 rot f struct-return@ ADDI
+    3 1 f struct-return@ ADDI
     3 1 0 local@ STW ;
 
 M: ppc %box-large-struct ( n c-type -- )
-    #! If n = f, then we're boxing a returned struct
+    ! If n = f, then we're boxing a returned struct
-    heap-size
+    ! Compute destination address and load struct size
-    [ swap struct-return@ ] keep
+    [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
-    ! Compute destination address
-    3 1 roll ADDI
-    ! Load struct size
-    4 LI
     ! Call the function
     "box_value_struct" f %alien-invoke ;
 
@@ -249,17 +244,17 @@ M: ppc %prepare-alien-invoke
     rs-reg 11 12 STW ;
 
 M: ppc %alien-invoke ( symbol dll -- )
-    11 %load-dlsym (%call) ;
+    11 %load-dlsym 11 (%call) ;
 
 M: ppc %alien-callback ( quot -- )
     3 load-indirect "c_to_factor" f %alien-invoke ;
 
 M: ppc %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
-    3 1 cell temp@ STW ;
+    13 3 MR ;
 
 M: ppc %alien-indirect ( -- )
-    11 1 cell temp@ LWZ (%call) ;
+    13 (%call) ;
 
 M: ppc %callback-value ( ctype -- )
      ! Save top of data stack

basis/cpu/x86/32/32.factor

@@ -1,13 +1,12 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays cpu.x86.assembler
+USING: locals alien.c-types arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
 cpu.architecture kernel kernel.private math namespaces sequences
-stack-checker.known-words
+stack-checker.known-words compiler.generator.registers
-compiler.generator.registers compiler.generator.fixup
+compiler.generator.fixup compiler.generator system layouts
-compiler.generator system layouts combinators
+combinators command-line compiler compiler.units io
-command-line compiler compiler.units io vocabs.loader accessors
+vocabs.loader accessors init ;
-init ;
 IN: cpu.x86.32
 
 ! We implement the FFI for Linux, OS X and Windows all at once.
@@ -18,7 +17,6 @@ IN: cpu.x86.32
 M: x86.32 ds-reg ESI ;
 M: x86.32 rs-reg EDI ;
 M: x86.32 stack-reg ESP ;
-M: x86.32 stack-save-reg EDX ;
 M: x86.32 temp-reg-1 EAX ;
 M: x86.32 temp-reg-2 ECX ;
 
@@ -32,15 +30,20 @@ M: x86.32 struct-small-enough? ( size -- ? )
     heap-size { 1 2 4 8 } member?
     os { linux netbsd solaris } member? not and ;
 
+: struct-return@ ( n -- operand )
+    [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
+
 ! On x86, parameters are never passed in registers.
 M: int-regs return-reg drop EAX ;
 M: int-regs param-regs drop { } ;
 M: int-regs vregs drop { EAX ECX EDX EBP } ;
 M: int-regs push-return-reg return-reg PUSH ;
-: load/store-int-return ( n reg-class -- src dst )
+
-    return-reg stack-reg rot [+] ;
+M: int-regs load-return-reg
-M: int-regs load-return-reg load/store-int-return MOV ;
+    return-reg swap next-stack@ MOV ;
-M: int-regs store-return-reg load/store-int-return swap MOV ;
+
+M: int-regs store-return-reg
+    [ stack@ ] [ return-reg ] bi* MOV ;
 
 M: float-regs param-regs drop { } ;
 M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
@@ -48,23 +51,26 @@ M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 : FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
 
 M: float-regs push-return-reg
-    stack-reg swap reg-size [ SUB  stack-reg [] ] keep FSTP ;
+    stack-reg swap reg-size
+    [ SUB ] [ [ [] ] dip FSTP ] 2bi ;
 
 : FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
 
-: load/store-float-return ( n reg-class -- op size )
+M: float-regs load-return-reg
-    [ stack@ ] [ reg-size ] bi* ;
+    [ next-stack@ ] [ reg-size ] bi* FLD ;
-M: float-regs load-return-reg load/store-float-return FLD ;
+
-M: float-regs store-return-reg load/store-float-return FSTP ;
+M: float-regs store-return-reg
+    [ stack@ ] [ reg-size ] bi* FSTP ;
 
 : align-sub ( n -- )
-    dup 16 align swap - ESP swap SUB ;
+    [ align-stack ] keep - decr-stack-reg ;
 
 : align-add ( n -- )
-    16 align ESP swap ADD ;
+    align-stack incr-stack-reg ;
 
 : with-aligned-stack ( n quot -- )
-    swap dup align-sub slip align-add ; inline
+    [ [ align-sub ] [ call ] bi* ]
+    [ [ align-add ] [ drop ] bi* ] 2bi ; inline
 
 M: x86.32 fixnum>slot@ 1 SHR ;
 
@@ -77,68 +83,51 @@ M: object %load-param-reg 3drop ;
 
 M: object %save-param-reg 3drop ;
 
-: box@ ( n reg-class -- stack@ )
-    #! Used for callbacks; we want to box the values given to
-    #! us by the C function caller. Computes stack location of
-    #! nth parameter; note that we must go back one more stack
-    #! frame, since %box sets one up to call the one-arg boxer
-    #! function. The size of this stack frame so far depends on
-    #! the reg-class of the boxer's arg.
-    reg-size neg + stack-frame* + 20 + ;
-
 : (%box) ( n reg-class -- )
     #! If n is f, push the return register onto the stack; we
     #! are boxing a return value of a C function. If n is an
     #! integer, push [ESP+n] on the stack; we are boxing a
     #! parameter being passed to a callback from C.
-    over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
+    over [ load-return-reg ] [ 2drop ] if ;
-    push-return-reg ;
 
-M: x86.32 %box ( n reg-class func -- )
+M:: x86.32 %box ( n reg-class func -- )
-    over reg-size [
+    n reg-class (%box)
-        >r (%box) r> f %alien-invoke
+    reg-class reg-size [
+        reg-class push-return-reg
+        func f %alien-invoke
     ] with-aligned-stack ;
     
 : (%box-long-long) ( n -- )
-    #! If n is f, push the return registers onto the stack; we
-    #! are boxing a return value of a C function. If n is an
-    #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
-    #! boxing a parameter being passed to a callback from C.
     [
-        int-regs box@
+        EDX over next-stack@ MOV
-        EDX over stack@ MOV
+        EAX swap cell - next-stack@ MOV 
-        EAX swap cell - stack@ MOV 
+    ] when* ;
-    ] when*
-    EDX PUSH
-    EAX PUSH ;
 
 M: x86.32 %box-long-long ( n func -- )
+    [ (%box-long-long) ] dip
     8 [
-        [ (%box-long-long) ] [ f %alien-invoke ] bi*
+        EDX PUSH
+        EAX PUSH
+        f %alien-invoke
     ] with-aligned-stack ;
 
-: struct-return@ ( size n -- n )
+M:: x86.32 %box-large-struct ( n c-type -- )
-    [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
-
-M: x86.32 %box-large-struct ( n c-type -- )
     ! Compute destination address
-    heap-size
+    ECX n struct-return@ LEA
-    [ swap struct-return@ ] keep
-    ECX ESP roll [+] LEA
     8 [
         ! Push struct size
-        PUSH
+        c-type heap-size PUSH
         ! Push destination address
         ECX PUSH
         ! Copy the struct from the C stack
         "box_value_struct" f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86.32 %prepare-box-struct ( size -- )
+M: x86.32 %prepare-box-struct ( -- )
     ! Compute target address for value struct return
-    EAX ESP rot f struct-return@ [+] LEA
+    EAX f struct-return@ LEA
     ! Store it as the first parameter
-    ESP [] EAX MOV ;
+    0 stack@ EAX MOV ;
 
 M: x86.32 %box-small-struct ( c-type -- )
     #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
@@ -207,13 +196,12 @@ M: x86 %unbox-small-struct ( size -- )
     } case ;
 
 M: x86.32 %unbox-large-struct ( n c-type -- )
-    #! Alien must be in EAX.
+    ! Alien must be in EAX.
-    heap-size
     ! Compute destination address
-    ECX ESP roll [+] LEA
+    ECX rot stack@ LEA
     12 [
         ! Push struct size
-        PUSH
+        heap-size PUSH
         ! Push destination address
         ECX PUSH
         ! Push source address
@@ -224,10 +212,10 @@ M: x86.32 %unbox-large-struct ( n c-type -- )
 
 M: x86.32 %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
-    cell temp@ EAX MOV ;
+    EBP EAX MOV ;
 
 M: x86.32 %alien-indirect ( -- )
-    cell temp@ CALL ;
+    EBP CALL ;
 
 M: x86.32 %alien-callback ( quot -- )
     4 [
@@ -239,7 +227,7 @@ M: x86.32 %alien-callback ( quot -- )
 M: x86.32 %callback-value ( ctype -- )
     ! Align C stack
     ESP 12 SUB
-    ! Save top of data stack
+    ! Save top of data stack in non-volatile register
     %prepare-unbox
     EAX PUSH
     ! Restore data/call/retain stacks
@@ -260,7 +248,7 @@ M: x86.32 %cleanup ( alien-node -- )
     {
         {
             [ dup abi>> "stdcall" = ]
-            [ alien-stack-frame ESP swap SUB ]
+            [ drop ESP stack-frame get params>> SUB ]
         } {
             [ dup return>> large-struct? ]
             [ drop EAX PUSH ]

basis/cpu/x86/64/64.factor

@@ -12,7 +12,6 @@ IN: cpu.x86.64
 M: x86.64 ds-reg R14 ;
 M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
-M: x86.64 stack-save-reg RSI ;
 M: x86.64 temp-reg-1 RAX ;
 M: x86.64 temp-reg-2 RCX ;
 
@@ -46,7 +45,9 @@ M: stack-params %load-param-reg
     r> stack@ R11 MOV ;
 
 M: stack-params %save-param-reg
-    >r stack-frame* + cell + swap r> %load-param-reg ;
+    drop
+    R11 swap next-stack@ MOV
+    stack@ R11 MOV ;
 
 : with-return-regs ( quot -- )
     [
@@ -121,7 +122,7 @@ M: x86.64 %unbox-large-struct ( n c-type -- )
     ! Source is in RDI
     heap-size
     ! Load destination address
-    RSI RSP roll [+] LEA
+    RSI rot stack@ LEA
     ! Load structure size
     RDX swap MOV
     ! Copy the struct to the C stack
@@ -145,7 +146,7 @@ M: x86.64 %box-long-long ( n func -- )
 M: x86.64 struct-small-enough? ( size -- ? )
     heap-size 2 cells <= ;
 
-: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
+: box-struct-field@ ( i -- operand ) 1+ cells stack@ ;
 
 : %box-struct-field ( c-type i -- )
     box-struct-field@ swap reg-class>> {
@@ -163,22 +164,22 @@ M: x86.64 %box-small-struct ( c-type -- )
         "box_small_struct" f %alien-invoke
     ] with-return-regs ;
 
-: struct-return@ ( size n -- n )
+: struct-return@ ( n -- operand )
-    [ ] [ \ stack-frame get swap - ] ?if ;
+    [ stack-frame get params>> ] unless* stack@ ;
 
 M: x86.64 %box-large-struct ( n c-type -- )
     ! Struct size is parameter 2
-    heap-size
+    RSI swap heap-size MOV
-    RSI over MOV
     ! Compute destination address
-    swap struct-return@ RDI RSP rot [+] LEA
+    RDI swap struct-return@ LEA
     ! Copy the struct from the C stack
     "box_value_struct" f %alien-invoke ;
 
-M: x86.64 %prepare-box-struct ( size -- )
+M: x86.64 %prepare-box-struct ( -- )
     ! Compute target address for value struct return
-    RAX RSP rot f struct-return@ [+] LEA
+    RAX f struct-return@ LEA
-    RSP 0 [+] RAX MOV ;
+    ! Store it as the first parameter
+    0 stack@ RAX MOV ;
 
 M: x86.64 %prepare-var-args RAX RAX XOR ;
 
@@ -192,10 +193,10 @@ M: x86.64 %alien-invoke
 
 M: x86.64 %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
-    cell temp@ RAX MOV ;
+    RBP RAX MOV ;
 
 M: x86.64 %alien-indirect ( -- )
-    cell temp@ CALL ;
+    RBP CALL ;
 
 M: x86.64 %alien-callback ( quot -- )
     RDI load-indirect "c_to_factor" f %alien-invoke ;
@@ -203,12 +204,14 @@ M: x86.64 %alien-callback ( quot -- )
 M: x86.64 %callback-value ( ctype -- )
     ! Save top of data stack
     %prepare-unbox
-    ! Put former top of data stack in RDI
+    ! Save top of data stack
-    cell temp@ RDI MOV
+    RSP 8 SUB
+    RDI PUSH
     ! Restore data/call/retain stacks
     "unnest_stacks" f %alien-invoke
     ! Put former top of data stack in RDI
-    RDI cell temp@ MOV
+    RDI POP
+    RSP 8 ADD
     ! Unbox former top of data stack to return registers
     unbox-return ;
 

basis/cpu/x86/architecture/architecture.factor

@@ -10,10 +10,16 @@ IN: cpu.x86.architecture
 HOOK: ds-reg cpu ( -- reg )
 HOOK: rs-reg cpu ( -- reg )
 HOOK: stack-reg cpu ( -- reg )
-HOOK: stack-save-reg cpu ( -- reg )
 
 : stack@ ( n -- op ) stack-reg swap [+] ;
 
+: next-stack@ ( n -- operand )
+    #! nth parameter from the next stack frame. Used to box
+    #! input values to callbacks; the callback has its own
+    #! stack frame set up, and we want to read the frame
+    #! set up by the caller.
+    stack-frame get total-size>> + stack@ ;
+
 : reg-stack ( n reg -- op ) swap cells neg [+] ;
 
 M: ds-loc v>operand n>> ds-reg reg-stack ;
@@ -32,8 +38,8 @@ M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
 M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
 
 GENERIC: push-return-reg ( reg-class -- )
-GENERIC: load-return-reg ( stack@ reg-class -- )
+GENERIC: load-return-reg ( n reg-class -- )
-GENERIC: store-return-reg ( stack@ reg-class -- )
+GENERIC: store-return-reg ( n reg-class -- )
 
 ! Only used by inline allocation
 HOOK: temp-reg-1 cpu ( -- reg )
@@ -45,21 +51,27 @@ HOOK: prepare-division cpu ( -- )
 
 M: immediate load-literal v>operand swap v>operand MOV ;
 
-M: x86 stack-frame ( n -- i )
+: align-stack ( n -- n' )
-    3 cells + 16 align cell - ;
+    os macosx? cpu x86.64? or [ 16 align ] when ;
+
+M: x86 stack-frame-size ( n -- i )
+    3 cells + align-stack ;
 
 M: x86 %save-word-xt ( -- )
     temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
 
-: factor-area-size ( -- n ) 4 cells ;
+: decr-stack-reg ( n -- )
+    dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
 
 M: x86 %prologue ( n -- )
-    dup cell + PUSH
+    dup PUSH
     temp-reg v>operand PUSH
-    stack-reg swap 2 cells - SUB ;
+    3 cells - decr-stack-reg ;
 
-M: x86 %epilogue ( n -- )
+: incr-stack-reg ( n -- )
-    stack-reg swap ADD ;
+    dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
+
+M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 
 HOOK: %alien-global cpu ( symbol dll register -- )
 
@@ -137,8 +149,6 @@ M: x86 small-enough? ( n -- ? )
 
 : %tag-fixnum ( reg -- ) tag-bits get SHL ;
 
-: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
-
 M: x86 %return ( -- ) 0 %unwind ;
 
 ! Alien intrinsics

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/db-docs.factor

@@ -26,10 +26,6 @@ HELP: dispose-statements
 { $values { "assoc" assoc } }
 { $description "Disposes an associative list of statements." } ;
 
-HELP: db-dispose
-{ $values { "db" db } }
-{ $description "Disposes of all the statements stored in the " { $link db } " object." } ;
-
 HELP: statement
 { $description "A " { $snippet "statement" } " stores the information about a statemen, such as the SQL statement text, the in/out parameters, and type information." } ;
 
@@ -172,7 +168,7 @@ HELP: sql-row-typed
 HELP: with-db
 { $values
      { "db" db } { "quot" quotation } }
-{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. The database called is based on the " { $snippet "class" } " with the " } ;
+{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. See " { $link "db-custom-database-combinators" } " for help setting up database access." } ;
 
 HELP: with-transaction
 { $values
@@ -285,7 +281,7 @@ ARTICLE: "db-custom-database-combinators" "Custom database combinators"
 { $code <"
 USING: db.sqlite db io.files ;
 : with-sqlite-db ( quot -- )
-    "my-database.db" temp-file <sqlite-db> swap with-db ;"> } 
+    "my-database.db" temp-file <sqlite-db> swap with-db ; inline"> } 
 
 "PostgreSQL example combinator:"
 { $code <" USING: db.postgresql db ;
@@ -296,7 +292,7 @@ USING: db.sqlite db io.files ;
         "erg" >>username
         "secrets?" >>password
         "factor-test" >>database
-    swap with-db ;">
+    swap with-db ; inline">
 } ;
 
 ABOUT: "db"

basis/db/db.factor

@@ -22,14 +22,13 @@ HOOK: db-close db ( handle -- )
 
 : dispose-statements ( assoc -- ) values dispose-each ;
 
-: db-dispose ( db -- ) 
+M: db dispose ( db -- ) 
     dup db [
-        {
+        [ dispose-statements H{ } clone ] change-insert-statements
-            [ insert-statements>> dispose-statements ]
+        [ dispose-statements H{ } clone ] change-update-statements
-            [ update-statements>> dispose-statements ]
+        [ dispose-statements H{ } clone ] change-delete-statements
-            [ delete-statements>> dispose-statements ]
+        [ db-close f ] change-handle
-            [ handle>> db-close ]
+        drop
-        } cleave
     ] with-variable ;
 
 TUPLE: result-set sql in-params out-params handle n max ;

basis/db/postgresql/postgresql.factor

@@ -30,8 +30,8 @@ M: postgresql-db db-open ( db -- db )
         [ password>> ]
     } cleave connect-postgres >>handle ;
 
-M: postgresql-db dispose ( db -- )
+M: postgresql-db db-close ( handle -- )
-    handle>> PQfinish ;
+    PQfinish ;
 
 M: postgresql-statement bind-statement* ( statement -- ) drop ;
 
@@ -230,6 +230,7 @@ M: postgresql-db persistent-table ( -- hashtable )
 
         { +foreign-id+ { f f "references" } }
 
+        { +on-update+ { f f "on update" } }
         { +on-delete+ { f f "on delete" } }
         { +restrict+ { f f "restrict" } }
         { +cascade+ { f f "cascade" } }

basis/db/queries/queries.factor

@@ -114,6 +114,9 @@ M: sequence where ( spec obj -- )
         [ " or " 0% ] [ dupd where ] interleave drop
     ] in-parens ;
 
+M: NULL where ( spec obj -- )
+    drop column-name>> 0% " is NULL" 0% ;
+
 : object-where ( spec obj -- )
     over column-name>> 0% " = " 0% bind# ;
 
@@ -163,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

@@ -19,7 +19,6 @@ M: sqlite-db db-open ( db -- db )
     dup path>> sqlite-open >>handle ;
 
 M: sqlite-db db-close ( handle -- ) sqlite-close ;
-M: sqlite-db dispose ( db -- ) db-dispose ;
 
 TUPLE: sqlite-statement < statement ;
 
@@ -87,9 +86,11 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
         in-params>> [ sqlite-bind-conversion ] with map
     ] keep bind-statement ;
 
+ERROR: sqlite-last-id-fail ;
+
 : last-insert-id ( -- id )
     db get handle>> sqlite3_last_insert_rowid
-    dup zero? [ "last-id failed" throw ] when ;
+    dup zero? [ sqlite-last-id-fail ] when ;
 
 M: sqlite-db insert-tuple-set-key ( tuple statement -- )
     execute-statement last-insert-id swap set-primary-key ;
@@ -177,12 +178,14 @@ M: sqlite-db persistent-table ( -- assoc )
         { +random-id+ { "integer" "integer" f } }
         { +foreign-id+ { "integer" "integer" "references" } }
 
+        { +on-update+ { f f "on update" } }
         { +on-delete+ { f f "on delete" } }
         { +restrict+ { f f "restrict" } }
         { +cascade+ { f f "cascade" } }
         { +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/db/tuples/tuples-docs.factor

@@ -229,7 +229,7 @@ T{ book
 "Now we've created a book. Let's save it to the database."
 { $code <" USING: db db.sqlite fry io.files ;
 : with-book-tutorial ( quot -- )
-     '[ "book-tutorial.db" temp-file sqlite-db _ with-db ] call ;
+     '[ "book-tutorial.db" temp-file <sqlite-db> _ with-db ] call ;
 
 [
     book recreate-table

basis/db/tuples/tuples-tests.factor

@@ -472,7 +472,12 @@ TUPLE: exam id name score ;
         T{ exam } select-tuples
     ] unit-test
 
-    [ 4 ] [ T{ exam } count-tuples ] unit-test ;
+    [ 4 ] [ T{ exam } count-tuples ] unit-test
+
+    [ ] [ T{ exam { score 10 } } insert-tuple ] unit-test
+
+    [ 10 ]
+    [ T{ exam { name NULL } } select-tuples first score>> ] unit-test ;
 
 TUPLE: bignum-test id m n o ;
 : <bignum-test> ( m n o -- obj )

basis/db/types/types.factor

@@ -26,8 +26,8 @@ SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ;
 UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
 
 SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
-+foreign-id+ +has-many+ +on-delete+ +restrict+ +cascade+ +set-null+
++foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+
-+set-default+ ;
++set-null+ +set-default+ ;
 
 SYMBOL: IGNORE
 
@@ -91,7 +91,7 @@ ERROR: not-persistent class ;
 
 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
 
-SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
+SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
 DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
 FACTOR-BLOB NULL URL ;
 

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/backend/backend.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types generic assocs kernel kernel.private
-math io.ports sequences strings structs sbufs threads unix
+math io.ports sequences strings sbufs threads unix
 vectors io.buffers io.backend io.encodings math.parser
 continuations system libc qualified namespaces make io.timeouts
 io.encodings.utf8 destructors accessors summary combinators
-locals ;
+locals unix.time ;
 QUALIFIED: io
 IN: io.unix.backend
 

basis/io/unix/epoll/epoll.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types kernel io.ports io.unix.backend
 bit-arrays sequences assocs unix unix.linux.epoll math
-namespaces structs ;
+namespaces unix.time ;
 IN: io.unix.epoll
 
 TUPLE: epoll-mx < mx events ;

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

@@ -0,0 +1,20 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien.syntax math io.unix.files system
+unix.stat accessors combinators calendar.unix ;
+IN: io.unix.files.bsd
+
+TUPLE: bsd-file-info < unix-file-info birth-time flags gen ;
+
+M: bsd new-file-info ( -- class ) bsd-file-info new ;
+
+M: bsd stat>file-info ( stat -- file-info )
+    [ call-next-method ] keep
+    {
+        [ stat-st_flags >>flags ]
+        [ stat-st_gen >>gen ]
+        [
+            stat-st_birthtimespec timespec>unix-time
+            >>birth-time
+        ]
+    } cleave ;

basis/io/unix/files/bsd/tags.txt

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

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

@@ -0,0 +1,277 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes help.markup help.syntax io.streams.string
+strings math calendar io.files ;
+IN: io.unix.files
+
+HELP: file-group-id
+{ $values
+     { "path" "a pathname string" }
+     { "gid" integer } }
+{ $description "Returns the group id for a given file." } ;
+
+HELP: file-group-name
+{ $values
+     { "path" "a pathname string" }
+     { "string" string } }
+{ $description "Returns the group name for a given file." } ;
+
+HELP: file-permissions
+{ $values
+     { "path" "a pathname string" }
+     { "n" integer } }
+{ $description "Returns the Unix file permissions for a given file." } ;
+
+HELP: file-username
+{ $values
+     { "path" "a pathname string" }
+     { "string" string } }
+{ $description "Returns the username for a given file." } ;
+
+HELP: file-user-id
+{ $values
+     { "path" "a pathname string" }
+     { "uid" integer } }
+{ $description "Returns the user id for a given file." } ;
+
+HELP: group-execute?
+{ $values
+     { "obj" "a pathname string or an integer" }
+     { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "group execute" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: group-read?
+{ $values
+     { "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, " { $link file-info } ", or an integer." } ;
+
+HELP: group-write?
+{ $values
+     { "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, " { $link file-info } ", or an integer." } ;
+
+HELP: other-execute?
+{ $values
+     { "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, " { $link file-info } ", or an integer." } ;
+
+HELP: other-read?
+{ $values
+     { "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, " { $link file-info } ", or an integer." } ;
+
+HELP: other-write?
+{ $values
+     { "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, " { $link file-info } ", or an integer." } ;
+
+HELP: set-file-access-time
+{ $values
+     { "path" "a pathname string" } { "timestamp" timestamp } }
+{ $description "Sets a file's last access timestamp." } ;
+
+HELP: set-file-group
+{ $values
+     { "path" "a pathname string" } { "string/id" "a string or a group id" } }
+{ $description "Sets a file's group id from the given group id or group name." } ;
+
+HELP: set-file-ids
+{ $values
+     { "path" "a pathname string" } { "uid" integer } { "gid" integer } }
+{ $description "Sets the user id and group id of a file with a single library call." } ;
+
+HELP: set-file-permissions
+{ $values
+     { "path" "a pathname string" } { "n" "an integer, interepreted as a string of bits" } }
+{ $description "Sets the file permissions for a given file with the supplied Unix permissions integer. Supplying an octal number with " { $link POSTPONE: OCT: } " is recommended." }
+{ $examples "Using the tradidional octal value:"
+    { $unchecked-example "USING: io.unix.files kernel ;"
+        "\"resource:license.txt\" OCT: 755 set-file-permissions"
+        ""
+    }
+    "Higher-level, setting named bits:"
+    { $unchecked-example "USING: io.unix.files kernel math.bitwise ;"
+    "\"resource:license.txt\""
+    "{ USER-ALL GROUP-READ GROUP-EXECUTE OTHER-READ OTHER-EXECUTE }"
+    "flags set-file-permissions"
+    "" }
+} ;
+
+HELP: set-file-times
+{ $values
+     { "path" "a pathname string" } { "timestamps" "an array of two timestamps" } }
+{ $description "Sets the access and write timestamps for a file as provided in the input array. A value of " { $link f } " provided for either of the timestamps will not change that timestamp." } ;
+
+HELP: set-file-user
+{ $values
+     { "path" "a pathname string" } { "string/id" "a string or a user id" } }
+{ $description "Sets a file's user id from the given user id or username." } ;
+
+HELP: set-file-modified-time
+{ $values
+     { "path" "a pathname string" } { "timestamp" timestamp } }
+{ $description "Sets a file's last modified timestamp, or write timestamp." } ;
+
+HELP: set-gid
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "gid" } " bit of a file to true or false." } ;
+
+HELP: gid?
+{ $values
+     { "obj" "a pathname string, file-info object, or an integer" }
+     { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "gid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: set-group-execute
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "group execute" } " bit of a file to true or false." } ;
+
+HELP: set-group-read
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "group read" } " bit of a file to true or false." } ;
+
+HELP: set-group-write
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "group write" } " bit of a file to true or false." } ;
+
+HELP: set-other-execute
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ;
+
+HELP: set-other-read
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "other read" } " bit of a file to true or false." } ;
+
+HELP: set-other-write
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "other execute" } " bit of a file to true or false." } ;
+
+HELP: set-sticky
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "sticky" } " bit of a file to true or false." } ;
+
+HELP: sticky?
+{ $values
+     { "obj" "a pathname string, file-info object, or an integer" }
+     { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "sticky" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: set-uid
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "uid" } " bit of a file to true or false." } ;
+
+HELP: uid?
+{ $values
+     { "obj" "a pathname string, file-info object, or an integer" }
+     { "?" "a boolean" } }
+{ $description "Tests whether the " { $snippet "uid" } " bit is set on a file, " { $link file-info } ", or an integer." } ;
+
+HELP: set-user-execute
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "user execute" } " bit of a file to true or false." } ;
+
+HELP: set-user-read
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "user read" } " bit of a file to true or false." } ;
+
+HELP: set-user-write
+{ $values
+     { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Sets the " { $snippet "user write" } " bit of a file to true or false." } ;
+
+HELP: user-execute?
+{ $values
+     { "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, " { $link file-info } ", or an integer." } ;
+
+HELP: user-read?
+{ $values
+     { "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, " { $link file-info } ", or an integer." } ;
+
+HELP: user-write?
+{ $values
+     { "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, " { $link file-info } ", or an integer." } ;
+
+ARTICLE: "unix-file-permissions" "Unix file permissions"
+"Reading all file permissions:"
+{ $subsection file-permissions }
+"Reading individual file permissions:"
+{ $subsection uid? }
+{ $subsection gid? }
+{ $subsection sticky? }
+{ $subsection user-read? }
+{ $subsection user-write? }
+{ $subsection user-execute? }
+{ $subsection group-read? }
+{ $subsection group-write? }
+{ $subsection group-execute? }
+{ $subsection other-read? }
+{ $subsection other-write? }
+{ $subsection other-execute? }
+"Writing all file permissions:"
+{ $subsection set-file-permissions }
+"Writing individual file permissions:"
+{ $subsection set-uid }
+{ $subsection set-gid }
+{ $subsection set-sticky }
+{ $subsection set-user-read }
+{ $subsection set-user-write }
+{ $subsection set-user-execute }
+{ $subsection set-group-read }
+{ $subsection set-group-write }
+{ $subsection set-group-execute }
+{ $subsection set-other-read }
+{ $subsection set-other-write }
+{ $subsection set-other-execute } ;
+
+ARTICLE: "unix-file-timestamps" "Unix file timestamps"
+"To read file times, use the accessors on the object returned by the " { $link file-info } " word." $nl
+"Setting multiple file times:"
+{ $subsection set-file-times }
+"Setting just the last access time:"
+{ $subsection set-file-access-time }
+"Setting just the last modified time:"
+{ $subsection set-file-modified-time } ;
+
+
+ARTICLE: "unix-file-ids" "Unix file user and group ids"
+"Reading file user data:"
+{ $subsection file-user-id }
+{ $subsection file-username }
+"Setting file user data:"
+{ $subsection set-file-user }
+"Reading file group data:"
+{ $subsection file-group-id }
+{ $subsection file-group-name }
+"Setting file group data:"
+{ $subsection set-file-group } ;
+
+
+ARTICLE: "io.unix.files" "Unix file attributes"
+"The " { $vocab-link "io.unix.files" } " vocabulary implements the Unix backend for opening files and provides a high-level way to set permissions, timestamps, and user and group ids for files."
+{ $subsection "unix-file-permissions" }
+{ $subsection "unix-file-timestamps" }
+{ $subsection "unix-file-ids" } ;
+
+ABOUT: "io.unix.files"

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

@@ -1,4 +1,6 @@
-USING: tools.test io.files ;
+USING: tools.test io.files continuations kernel io.unix.files
+math.bitwise calendar accessors math.functions math unix.users
+unix.groups arrays sequences ;
 IN: io.unix.files.tests
 
 [ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
@@ -27,3 +29,135 @@ IN: io.unix.files.tests
 [ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
 [ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
 [ t ] [ "/foo" absolute-path? ] unit-test
+
+: test-file ( -- path )
+    "permissions" temp-file ;
+
+: prepare-test-file ( -- )
+    [ test-file delete-file ] ignore-errors
+    test-file touch-file ;
+
+: perms ( -- n )
+    test-file file-permissions OCT: 7777 mask ;
+
+prepare-test-file
+
+[ t ]
+[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test
+
+[ t ] [ test-file user-read? ] unit-test
+[ t ] [ test-file user-write? ] unit-test
+[ t ] [ test-file user-execute? ] unit-test
+[ t ] [ test-file group-read? ] unit-test
+[ t ] [ test-file group-write? ] unit-test
+[ t ] [ test-file group-execute? ] unit-test
+[ t ] [ test-file other-read? ] unit-test
+[ t ] [ test-file other-write? ] unit-test
+[ t ] [ test-file other-execute? ] unit-test
+
+[ t ] [ test-file f set-other-execute perms OCT: 776 = ] unit-test
+[ f ] [ test-file file-info other-execute? ] unit-test
+
+[ t ] [ test-file f set-other-write perms OCT: 774 = ] unit-test
+[ f ] [ test-file file-info other-write? ] unit-test
+
+[ t ] [ test-file f set-other-read perms OCT: 770 = ] unit-test
+[ f ] [ test-file file-info other-read? ] unit-test
+
+[ t ] [ test-file f set-group-execute perms OCT: 760 = ] unit-test
+[ f ] [ test-file file-info group-execute? ] unit-test
+
+[ t ] [ test-file f set-group-write perms OCT: 740 = ] unit-test
+[ f ] [ test-file file-info group-write? ] unit-test
+
+[ t ] [ test-file f set-group-read perms OCT: 700 = ] unit-test
+[ f ] [ test-file file-info group-read? ] unit-test
+
+[ t ] [ test-file f set-user-execute perms OCT: 600 = ] unit-test
+[ f ] [ test-file file-info other-execute? ] unit-test
+
+[ t ] [ test-file f set-user-write perms OCT: 400 = ] unit-test
+[ f ] [ test-file file-info other-write? ] unit-test
+
+[ t ] [ 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
+
+prepare-test-file
+
+[ t ]
+[
+    test-file now
+    [ set-file-access-time ] 2keep
+    [ file-info accessed>> ]
+    [ [ [ truncate >integer ] change-second ] bi@ ] bi* =
+] unit-test
+
+[ t ]
+[
+    test-file now
+    [ set-file-modified-time ] 2keep
+    [ file-info modified>> ]
+    [ [ [ truncate >integer ] change-second ] bi@ ] bi* =
+] unit-test
+
+[ t ]
+[
+    test-file now [ dup 2array set-file-times ] 2keep
+    [ file-info [ modified>> ] [ accessed>> ] bi ] dip
+    3array
+    [ [ truncate >integer ] change-second ] map all-equal?
+] unit-test
+
+[ ] [ test-file f now 2array set-file-times ] unit-test
+[ ] [ test-file now f 2array set-file-times ] unit-test
+[ ] [ test-file f f 2array set-file-times ] unit-test
+
+
+[ ] [ test-file real-username set-file-user ] unit-test
+[ ] [ test-file real-user-id set-file-user ] unit-test
+[ ] [ test-file real-group-name set-file-group ] unit-test
+[ ] [ test-file real-group-id set-file-group ] unit-test
+
+[ t ] [ test-file file-username real-username = ] unit-test
+[ t ] [ test-file file-group-name real-group-name = ] unit-test
+
+[ ]
+[ test-file real-user-id real-group-id set-file-ids ] unit-test
+
+[ ]
+[ test-file f real-group-id set-file-ids ] unit-test
+
+[ ]
+[ test-file real-user-id f set-file-ids ] unit-test
+
+[ ]
+[ 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

@@ -1,11 +1,12 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.backend io.ports io.unix.backend io.files io
 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 ;
+io.files.private destructors vocabs.loader calendar.unix
-
+unix.stat alien.c-types arrays unix.users unix.groups
+environment fry io.encodings.utf8 alien.strings unix.statfs ;
 IN: io.unix.files
 
 M: unix cwd ( -- path )
@@ -74,26 +75,14 @@ M: unix copy-file ( from to -- )
     [ swap file-info permissions>> chmod io-error ]
     2bi ;
 
-: stat>type ( stat -- type )
+HOOK: stat>file-info os ( stat -- file-info )
-    stat-st_mode S_IFMT bitand {
-        { S_IFREG [ +regular-file+ ] }
-        { S_IFDIR [ +directory+ ] }
-        { S_IFCHR [ +character-device+ ] }
-        { S_IFBLK [ +block-device+ ] }
-        { S_IFIFO [ +fifo+ ] }
-        { S_IFLNK [ +symbolic-link+ ] }
-        { S_IFSOCK [ +socket+ ] }
-        [ drop +unknown+ ]
-    } case ;
 
-: stat>file-info ( stat -- info )
+HOOK: stat>type os ( stat -- file-info )
-    {
+
-        [ stat>type ]
+HOOK: new-file-info os ( -- class )
-        [ stat-st_size ]
+
-        [ stat-st_mode ]
+TUPLE: unix-file-info < file-info uid gid dev ino
-        [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
+nlink rdev blocks blocksize ;
-    } cleave
-    \ file-info boa ;
 
 M: unix file-info ( path -- info )
     normalize-path file-status stat>file-info ;
@@ -105,4 +94,227 @@ M: unix make-link ( path1 path2 -- )
     normalize-path symlink io-error ;
 
 M: unix read-link ( path -- path' )
-   normalize-path read-symbolic-link ;
+   normalize-path read-symbolic-link ;
+
+M: unix new-file-info ( -- class ) unix-file-info new ;
+
+M: unix stat>file-info ( stat -- file-info )
+    [ new-file-info ] dip
+    {
+        [ stat>type >>type ]
+        [ stat-st_size >>size ]
+        [ stat-st_mode >>permissions ]
+        [ stat-st_ctimespec timespec>unix-time >>created ]
+        [ stat-st_mtimespec timespec>unix-time >>modified ]
+        [ stat-st_atimespec timespec>unix-time >>accessed ]
+        [ stat-st_uid >>uid ]
+        [ stat-st_gid >>gid ]
+        [ stat-st_dev >>dev ]
+        [ stat-st_ino >>ino ]
+        [ stat-st_nlink >>nlink ]
+        [ stat-st_rdev >>rdev ]
+        [ stat-st_blocks >>blocks ]
+        [ stat-st_blksize >>blocksize ]
+    } cleave ;
+
+M: unix stat>type ( stat -- type )
+    stat-st_mode S_IFMT bitand {
+        { S_IFREG [ +regular-file+ ] }
+        { S_IFDIR [ +directory+ ] }
+        { S_IFCHR [ +character-device+ ] }
+        { S_IFBLK [ +block-device+ ] }
+        { S_IFIFO [ +fifo+ ] }
+        { S_IFLNK [ +symbolic-link+ ] }
+        { S_IFSOCK [ +socket+ ] }
+        [ drop +unknown+ ]
+    } case ;
+
+! Linux has no extra fields in its stat struct
+os {
+    { macosx  [ "io.unix.files.bsd" require ] }
+    { netbsd  [ "io.unix.files.bsd" require ] }
+    { openbsd  [ "io.unix.files.bsd" require ] }
+    { freebsd  [ "io.unix.files.bsd" require ] }
+    { 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 )
+    normalize-path file-status stat-st_mode ;
+    
+: chmod-set-bit ( path mask ? -- ) 
+    [ dup stat-mode ] 2dip 
+    [ bitor ] [ unmask ] if chmod io-error ;
+
+: file-mode? ( path mask -- ? ) [ stat-mode ] dip mask? ;
+
+PRIVATE>
+
+: UID           OCT: 0004000 ; inline
+: GID           OCT: 0002000 ; inline
+: STICKY        OCT: 0001000 ; inline
+: USER-ALL      OCT: 0000700 ; inline
+: USER-READ     OCT: 0000400 ; inline
+: USER-WRITE    OCT: 0000200 ; inline 
+: USER-EXECUTE  OCT: 0000100 ; inline   
+: GROUP-ALL     OCT: 0000070 ; inline
+: GROUP-READ    OCT: 0000040 ; inline 
+: GROUP-WRITE   OCT: 0000020 ; inline  
+: GROUP-EXECUTE OCT: 0000010 ; inline    
+: OTHER-ALL     OCT: 0000007 ; inline
+: OTHER-READ    OCT: 0000004 ; inline
+: OTHER-WRITE   OCT: 0000002 ; inline  
+: OTHER-EXECUTE OCT: 0000001 ; inline    
+
+GENERIC: uid? ( obj -- ? )
+GENERIC: gid? ( obj -- ? )
+GENERIC: sticky? ( obj -- ? )
+GENERIC: user-read? ( obj -- ? )
+GENERIC: user-write? ( obj -- ? )
+GENERIC: user-execute? ( obj -- ? )
+GENERIC: group-read? ( obj -- ? )
+GENERIC: group-write? ( obj -- ? )
+GENERIC: group-execute? ( obj -- ? )
+GENERIC: other-read? ( obj -- ? )
+GENERIC: other-write? ( obj -- ? )
+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 ;
+: set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
+: set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
+: set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ; 
+: set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
+: set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
+: set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ; 
+: set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
+: set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
+: set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ; 
+: set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
+
+: set-file-permissions ( path n -- )
+    [ normalize-path ] dip chmod io-error ;
+
+: file-permissions ( path -- n )
+    normalize-path file-info permissions>> ;
+
+<PRIVATE
+
+: make-timeval-array ( array -- byte-array )
+    [ length "timeval" <c-array> ] keep
+    dup length [ over [ pick set-timeval-nth ] [ 2drop ] if ] 2each ;
+
+: timestamp>timeval ( timestamp -- timeval )
+    unix-1970 time- duration>milliseconds make-timeval ;
+
+: timestamps>byte-array ( timestamps -- byte-array )
+    [ dup [ timestamp>timeval ] when ] map make-timeval-array ;
+
+PRIVATE>
+
+: set-file-times ( path timestamps -- )
+    #! set access, write
+    [ normalize-path ] dip
+    timestamps>byte-array utimes io-error ;
+
+: set-file-access-time ( path timestamp -- )
+    f 2array set-file-times ;
+
+: set-file-modified-time ( path timestamp -- )
+    f swap 2array set-file-times ;
+
+: set-file-ids ( path uid gid -- )
+    [ normalize-path ] 2dip
+    [ [ -1 ] unless* ] bi@ chown io-error ;
+
+GENERIC: set-file-user ( path string/id -- )
+
+GENERIC: set-file-group ( path string/id -- )
+
+M: integer set-file-user ( path uid -- )
+    f set-file-ids ;
+
+M: string set-file-user ( path string -- )
+    user-id f set-file-ids ;
+    
+M: integer set-file-group ( path gid -- )
+    f swap set-file-ids ;
+    
+M: string set-file-group ( path string -- )
+    group-id
+    f swap set-file-ids ;
+
+: file-user-id ( path -- uid )
+    normalize-path file-info uid>> ;
+
+: file-username ( path -- string )
+    file-user-id username ;
+
+: file-group-id ( path -- gid )
+    normalize-path file-info gid>> ;
+
+: file-group-name ( path -- string )
+    file-group-id group-name ;
+
+M: unix home "HOME" os-env ;

basis/io/unix/files/unique/unique.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel io.ports io.unix.backend math.bitwise
 unix io.files.unique.backend system ;
 IN: io.unix.files.unique

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/unix/select/select.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types kernel io.ports io.unix.backend
-bit-arrays sequences assocs unix math namespaces structs
+bit-arrays sequences assocs unix math namespaces
-accessors math.order locals ;
+accessors math.order locals unix.time ;
 IN: io.unix.select
 
 TUPLE: select-mx < mx read-fdset write-fdset ;

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+
@@ -147,18 +175,18 @@ SYMBOLS: +read-only+ +hidden+ +system+
     FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
 
 : WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
+    [ \ file-info new ] dip
     {
-        [ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
+        [ WIN32_FIND_DATA-dwFileAttributes win32-file-type >>type ]
         [
             [ WIN32_FIND_DATA-nFileSizeLow ]
-            [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit
+            [ WIN32_FIND_DATA-nFileSizeHigh ] bi >64bit >>size
         ]
-        [ WIN32_FIND_DATA-dwFileAttributes ]
+        [ WIN32_FIND_DATA-dwFileAttributes >>permissions ]
-        ! [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp ]
+        [ WIN32_FIND_DATA-ftCreationTime FILETIME>timestamp >>created ]
-        [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ]
+        [ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp >>modified ]
-        ! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ]
+        [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp >>accessed ]
-    } cleave
+    } cleave ;
-    \ file-info boa ;
 
 : find-first-file-stat ( path -- WIN32_FIND_DATA )
     "WIN32_FIND_DATA" <c-object> [
@@ -168,23 +196,32 @@ SYMBOLS: +read-only+ +hidden+ +system+
     ] keep ;
 
 : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
+    [ \ file-info new ] dip
     {
-        [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type ]
+        [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
         [
             [ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
-            [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit
+            [ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
+        ]
+        [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ]
+        [
+            BY_HANDLE_FILE_INFORMATION-ftCreationTime
+            FILETIME>timestamp >>created
+        ]
+        [
+            BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
+            FILETIME>timestamp >>modified
+        ]
+        [
+            BY_HANDLE_FILE_INFORMATION-ftLastAccessTime
+            FILETIME>timestamp >>accessed
         ]
-        [ BY_HANDLE_FILE_INFORMATION-dwFileAttributes ]
-        ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ]
-        [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
-        ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
         ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
         ! [
           ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
           ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
         ! ]
-    } cleave
+    } cleave ;
-    \ file-info boa ;
 
 : get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
     [
@@ -209,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 ;
 
@@ -421,7 +440,7 @@ M: lambda-macro definition
     "lambda" word-prop body>> ;
 
 M: lambda-macro reset-word
-    [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+    [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
 
 INTERSECTION: lambda-method method-body lambda-word ;
 
@@ -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/random/random-docs.factor

@@ -15,21 +15,18 @@ HELP: random-bytes*
 { $description "Generates a byte-array of random bytes." } ;
 
 HELP: random
-{ $values { "obj" object } { "elt" "a random element" } }
+{ $values { "seq" sequence } { "elt" "a random element" } }
-{ $description "Outputs a random element of the input object. If the object is an integer, an input of zero always returns a zero, while any other integer integers yield a random integer in the interval between itself and zero, inclusive of zero. On a sequence, an empty sequence always outputs " { $link f } "." }
+{ $description "Outputs a random element of the input sequence. Outputs " { $link f } " if the sequence is empty." }
+{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " outputs an integer in the interval " { $snippet "[0,n)" } "." }
 { $examples
     { $unchecked-example "USING: random prettyprint ;"
         "10 random ."
         "3" }
-    { $example "USING: random prettyprint ;"
-        "0 random ."
-        "0" }
     { $unchecked-example "USING: random prettyprint ;"
-        "-10 random ."
+        "SYMBOL: heads"
-        "-8" }
+        "SYMBOL: tails"
-    { $unchecked-example "USING: random prettyprint ;"
+        "{ heads tails } random ."
-        "{ \"a\" \"b\" \"c\" } random ."
+        "heads" }
-        "\"a\"" }
 } ;
 
 HELP: random-bytes
@@ -74,7 +71,10 @@ ARTICLE: "random-protocol" "Random protocol"
 { $subsection seed-random } ;
 
 ARTICLE: "random" "Generating random integers"
-"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers. The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "."
+"The " { $vocab-link "random" } " vocabulary contains a protocol for generating random or pseudorandom numbers."
+$nl
+"The ``Mersenne Twister'' pseudorandom number generator algorithm is the default generator stored in " { $link random-generator } "."
+$nl
 "Generate a random object:"
 { $subsection random }
 "Combinators to change the random number generator:"

basis/random/random-tests.factor

@@ -16,4 +16,4 @@ IN: random.tests
 
 [ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
 
-[ 0 ] [ 0 random ] unit-test
+[ f ] [ 0 random ] unit-test

basis/random/random.factor

@@ -33,10 +33,6 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
         random-generator get random-bytes*
     ] keep head ;
 
-GENERIC: random ( obj -- elt )
-
-: random-bits ( n -- r ) 2^ random ;
-
 <PRIVATE
 
 : random-integer ( n -- n' )
@@ -46,19 +42,13 @@ GENERIC: random ( obj -- elt )
 
 PRIVATE>
 
-M: sequence random ( seq -- elt )
+: random-bits ( n -- r ) 2^ random-integer ;
+
+: random ( seq -- elt )
     [ f ] [
         [ length random-integer ] keep nth
     ] if-empty ;
 
-ERROR: negative-random n ;
-M: integer random ( integer -- integer' )
-    {
-        { [ dup 0 = ] [ ] }
-        { [ dup 0 < ] [ neg random-integer neg ] }
-        [ random-integer ]
-    } cond ;
-
 : delete-random ( seq -- elt )
     [ length random-integer ] keep [ nth ] 2keep delete-nth ;
 

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/structs/structs.factor

@@ -1,12 +0,0 @@
-USING: alien.c-types alien.syntax kernel math ;
-IN: structs
-
-C-STRUCT: timeval
-    { "long" "sec" }
-    { "long" "usec" } ;
-
-: make-timeval ( ms -- timeval )
-    1000 /mod 1000 *
-    "timeval" <c-object>
-    [ set-timeval-usec ] keep
-    [ set-timeval-sec ] keep ;

basis/structs/summary.txt

@@ -1 +0,0 @@
-Cross-platform C structs

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/shaker/shaker.factor

@@ -321,7 +321,7 @@ IN: tools.deploy.shaker
     ] [ drop ] if ;
 
 : strip-c-io ( -- )
-    deploy-io get 2 = [
+    deploy-io get 2 = os windows? or [
         [
             c-io-backend forget
             "io.streams.c" forget-vocab

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/deploy/test/6/deploy.factor

@@ -1,15 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-threads? f }
-    { deploy-ui? f }
-    { deploy-io 1 }
-    { deploy-c-types? f }
-    { deploy-name "tools.deploy.test.6" }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
     { deploy-word-props? f }
+    { deploy-io 1 }
+    { deploy-name "tools.deploy.test.6" }
+    { deploy-math? t }
+    { deploy-random? f }
+    { deploy-compiler? t }
+    { deploy-ui? f }
+    { deploy-c-types? f }
     { deploy-word-defs? f }
     { "stop-after-last-window?" t }
-    { deploy-random? f }
+    { deploy-threads? f }
-    { deploy-math? f }
 }

basis/tools/deploy/windows/windows.factor

@@ -14,7 +14,7 @@ IN: tools.deploy.windows
             "resource:freetype6.dll"
             "resource:zlib1.dll"
         } swap copy-files-into
-    ] when ;
+    ] [ drop ] if ;
 
 : create-exe-dir ( vocab bundle-name -- vm )
     deploy-ui? get [

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/windows/windows.factor

@@ -420,15 +420,25 @@ M: windows-ui-backend do-events
     style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
 
 : make-RECT ( world -- RECT )
-    dup window-loc>> { 40 40 } vmax dup rot rect-dim v+
+    dup window-loc>> dup rot rect-dim v+
     "RECT" <c-object>
     over first over set-RECT-right
     swap second over set-RECT-bottom
     over first over set-RECT-left
     swap second over set-RECT-top ;
 
+: default-position-RECT ( RECT -- )
+    dup get-RECT-dimensions [ 2drop ] 2dip
+    CW_USEDEFAULT + pick set-RECT-bottom
+    CW_USEDEFAULT + over set-RECT-right
+    CW_USEDEFAULT over set-RECT-left
+    CW_USEDEFAULT swap set-RECT-top ;
+
 : make-adjusted-RECT ( rect -- RECT )
-    make-RECT dup adjust-RECT ;
+    make-RECT
+    dup get-RECT-top-left [ zero? ] both? swap
+    dup adjust-RECT
+    swap [ dup default-position-RECT ] when ;
 
 : create-window ( rect -- hwnd )
     make-adjusted-RECT

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
@@ -48,6 +46,19 @@ C-STRUCT: sockaddr-un
     { "uchar" "family" }
     { { "char" 104 } "path" } ;
 
+C-STRUCT: passwd
+    { "char*"  "pw_name" }
+    { "char*"  "pw_passwd" }
+    { "uid_t"  "pw_uid" }
+    { "gid_t"  "pw_gid" }
+    { "time_t" "pw_change" }
+    { "char*"  "pw_class" }
+    { "char*"  "pw_gecos" }
+    { "char*"  "pw_dir" }
+    { "char*"  "pw_shell" }
+    { "time_t" "pw_expire" }
+    { "int"    "pw_fields" } ;
+
 : max-un-path 104 ; inline
 
 : SOCK_STREAM 1 ; inline
@@ -72,6 +83,16 @@ C-STRUCT: sockaddr-un
 : 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

@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax unix.time ;
 IN: unix
 
 : FD_SETSIZE 1024 ; inline
@@ -13,18 +13,31 @@ C-STRUCT: addrinfo
     { "void*" "addr" }
     { "addrinfo*" "next" } ;
 
-C-STRUCT: passwd
+: _UTX_USERSIZE 256 ; inline
-    { "char*"  "pw_name" }
+: _UTX_LINESIZE 32 ; inline
-    { "char*"  "pw_passwd" }
+: _UTX_IDSIZE 4 ; inline
-    { "uid_t"  "pw_uid" }
+: _UTX_HOSTSIZE 256 ; inline
-    { "gid_t"  "pw_gid" }
+    
-    { "time_t" "pw_change" }
+C-STRUCT: utmpx
-    { "char*"  "pw_class" }
+    { { "char" _UTX_USERSIZE } "ut_user" }
-    { "char*"  "pw_gecos" }
+    { { "char" _UTX_IDSIZE } "ut_id" }
-    { "char*"  "pw_dir" }
+    { { "char" _UTX_LINESIZE } "ut_line" }
-    { "char*"  "pw_shell" }
+    { "pid_t" "ut_pid" }
-    { "time_t" "pw_expire" }
+    { "short" "ut_type" }
-    { "int"    "pw_fields" } ;
+    { "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

basis/unix/bsd/netbsd/netbsd.factor

@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types math vocabs.loader ;
 IN: unix
 
 : FD_SETSIZE 256 ; inline
@@ -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
@@ -111,3 +118,24 @@ C-STRUCT: addrinfo
 : ENOLINK 95 ; inline
 : EPROTO 96 ; inline
 : ELAST 96 ; inline
+
+TYPEDEF: __uint8_t sa_family_t
+
+: _UTX_USERSIZE   32 ; inline
+: _UTX_LINESIZE   32 ; inline
+: _UTX_IDSIZE     4 ; inline
+: _UTX_HOSTSIZE   256 ; inline
+
+: _SS_MAXSIZE ( -- n )
+    128 ; inline
+
+: _SS_ALIGNSIZE ( -- n )
+    "__int64_t" heap-size ; inline
+    
+: _SS_PAD1SIZE ( -- n )
+    _SS_ALIGNSIZE 2 - ; inline
+    
+: _SS_PAD2SIZE ( -- n )
+    _SS_MAXSIZE 2 - _SS_PAD1SIZE - _SS_ALIGNSIZE - ; inline
+
+"unix.bsd.netbsd.structs" require

basis/unix/bsd/netbsd/structs/structs.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax unix.time ;
+IN: unix
+
+C-STRUCT: sockaddr_storage
+    { "__uint8_t" "ss_len" }
+    { "sa_family_t" "ss_family" }
+    { { "char" _SS_PAD1SIZE } "__ss_pad1" }
+    { "__int64_t" "__ss_align" }
+    { { "char" _SS_PAD2SIZE } "__ss_pad2" } ;
+
+C-STRUCT: exit_struct
+    { "uint16_t" "e_termination" }
+    { "uint16_t" "e_exit" } ;
+
+C-STRUCT: utmpx
+    { { "char" _UTX_USERSIZE } "ut_user" }
+    { { "char" _UTX_IDSIZE } "ut_id" }
+    { { "char" _UTX_LINESIZE } "ut_line" }
+    { { "char" _UTX_HOSTSIZE } "ut_host" }
+    { "uint16_t" "ut_session" }
+    { "uint16_t" "ut_type" }
+    { "pid_t" "ut_pid" }
+    { "exit_struct" "ut_exit" }
+    { "sockaddr_storage" "ut_ss" }
+    { "timeval" "ut_tv" }
+    { { "uint32_t" 10 } "ut_pad" } ;
+

basis/unix/bsd/netbsd/structs/tags.txt

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

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-docs.factor

@@ -0,0 +1,108 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string kernel quotations sequences strings math ;
+IN: unix.groups
+
+HELP: all-groups
+{ $values
+    
+     { "seq" sequence } }
+{ $description "Returns a sequence of " { $link group } " tuples that are platform-dependent and field for field complete with the Unix " { $link group } " structure." } ;
+
+HELP: effective-group-id
+{ $values
+    
+     { "string" string } }
+{ $description "Returns the effective group id for the current user." } ;
+
+HELP: effective-group-name
+{ $values
+    
+     { "string" string } }
+{ $description "Returns the effective group name for the current user." } ;
+
+HELP: group
+{ $description "A platform-specific tuple corresponding to every field from the Unix group struct including the group name, the group id, the group passwd, and a list of users in each group." } ;
+
+HELP: group-cache
+{ $description "A symbol containing a cache of groups returned from " { $link all-groups } " and indexed by group id. Can be more efficient than using the system call words for many group lookups." } ;
+
+HELP: group-id
+{ $values
+     { "string" string }
+     { "id" integer } }
+{ $description "Returns the group id given a group name." } ;
+
+HELP: group-name
+{ $values
+     { "id" integer }
+     { "string" string } }
+{ $description "Returns the group name given a group id." } ;
+
+HELP: group-struct
+{ $values
+     { "obj" object }
+     { "group" "a group struct" } }
+{ $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
+
+HELP: real-group-id
+{ $values
+    
+     { "id" integer } }
+{ $description "Returns the real group id for the current user." } ;
+
+HELP: real-group-name
+{ $values
+    
+     { "string" string } }
+{ $description "Returns the real group name for the current user." } ;
+
+HELP: set-effective-group
+{ $values
+     { "obj" object } }
+{ $description "Sets the effective group id for the current user." } ;
+
+HELP: set-real-group
+{ $values
+     { "obj" object } }
+{ $description "Sets the real group id for the current user." } ;
+
+HELP: user-groups
+{ $values
+     { "string/id" "a string or a group id" }
+     { "seq" sequence } }
+{ $description "Returns the sequence of groups to which the user belongs." } ;
+
+HELP: with-effective-group
+{ $values
+     { "string/id" "a string or a group id" } { "quot" quotation } }
+{ $description "Sets the effective group name and calls the quotation. Restors the effective group name on success or on error after the call." } ;
+
+HELP: with-group-cache
+{ $values
+     { "quot" quotation } }
+{ $description "Iterates over the group file using library calls and creates a cache in the " { $link group-cache } " symbol. The cache is a hashtable indexed by group id. When looking up many groups, this approach is much faster than calling system calls." } ;
+
+HELP: with-real-group
+{ $values
+     { "string/id" "a string or a group id" } { "quot" quotation } }
+{ $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
+
+ARTICLE: "unix.groups" "unix.groups"
+"The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
+"Listing all groups:"
+{ $subsection all-groups }
+"Returning a passwd tuple:"
+"Real groups:"
+{ $subsection real-group-name }
+{ $subsection real-group-id }
+{ $subsection set-real-group }
+"Effective groups:"
+{ $subsection effective-group-name }
+{ $subsection effective-group-id }
+{ $subsection set-effective-group }
+"Combinators to change groups:"
+{ $subsection with-real-group }
+{ $subsection with-effective-group } ;
+
+ABOUT: "unix.groups"

basis/unix/groups/groups-tests.factor

@@ -0,0 +1,24 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test unix.groups kernel strings math ;
+IN: unix.groups.tests
+
+
+[ ] [ all-groups drop ] unit-test
+
+\ all-groups must-infer
+
+[ t ] [ real-group-name string? ] unit-test
+[ t ] [ effective-group-name string? ] unit-test
+
+[ t ] [ real-group-id integer? ] unit-test
+[ t ] [ effective-group-id integer? ] unit-test
+
+[ ] [ real-group-id set-real-group ] unit-test
+[ ] [ effective-group-id set-effective-group ] unit-test
+
+[ ] [ real-group-name [ ] with-real-group ] unit-test
+[ ] [ real-group-id [ ] with-real-group ] unit-test
+
+[ ] [ effective-group-name [ ] with-effective-group ] unit-test
+[ ] [ effective-group-id [ ] with-effective-group ] unit-test