Merge branch 'master' into regexp

basis/alien/complex/complex.factor

@@ -1,6 +1,13 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.complex.functor sequences kernel ;
+USING: alien.c-types alien.structs alien.complex.functor accessors
+sequences kernel ;
 IN: alien.complex
 
-<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >>
+<<
+{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
+
+! This overrides the fact that small structures are never returned
+! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
+"complex-float" c-type t >>return-in-registers? drop
+ >>

basis/alien/structs/structs.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays assocs generic hashtables kernel kernel.private
 math namespaces parser sequences strings words libc fry
 alien.c-types alien.structs.fields cpu.architecture math.order
-quotations ;
+quotations byte-arrays ;
 IN: alien.structs
 
 TUPLE: struct-type
@@ -13,11 +13,14 @@ fields
 { boxer-quot callable }
 { unboxer-quot callable }
 { getter callable }
-{ setter callable } ;
+{ setter callable }
+return-in-registers? ;
+
+M: struct-type c-type ;
 
 M: struct-type heap-size size>> ;
 
-M: struct-type c-type-class drop object ;
+M: struct-type c-type-class drop byte-array ;
 
 M: struct-type c-type-align align>> ;
 
@@ -37,7 +40,7 @@ M: struct-type box-parameter
     [ %box-large-struct ] [ box-parameter ] if-value-struct ;
 
 : if-small-struct ( c-type true false -- ? )
-    [ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline
+    [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
 
 M: struct-type unbox-return
     [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;

basis/bitstreams/bitstreams-tests.factor

@@ -0,0 +1,27 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors bitstreams io io.streams.string kernel tools.test
+grouping compression.lzw multiline byte-arrays io.encodings.binary
+io.streams.byte-array ;
+IN: bitstreams.tests
+
+[ 1 t ]
+[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
+
+[ 254 8 t ]
+[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+
+[ 4095 12 t ]
+[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
+
+[ B{ 254 } ]
+[
+    <string-writer> <bitstream-writer> 254 8 rot
+    [ write-bits ] keep stream>> >byte-array
+] unit-test
+
+[ 255 8 t ]
+[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+
+[ 255 8 f ]
+[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test

basis/bitstreams/bitstreams.factor

@@ -0,0 +1,96 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays destructors fry io kernel locals
+math sequences ;
+IN: bitstreams
+
+TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
+TUPLE: bitstream-reader < bitstream ;
+
+: reset-bitstream ( stream -- stream )
+    0 >>#bits 0 >>current-bits ; inline
+
+: new-bitstream ( stream class -- bitstream )
+    new
+        swap >>stream
+        reset-bitstream ; inline
+
+M: bitstream-reader dispose ( stream -- )
+    stream>> dispose ;
+
+: <bitstream-reader> ( stream -- bitstream )
+    bitstream-reader new-bitstream ; inline
+
+: read-next-byte ( bitstream -- bitstream )
+    dup stream>> stream-read1 [
+        >>current-bits 8 >>#bits
+    ] [
+        0 >>#bits
+        t >>end-of-stream?
+    ] if* ;
+
+: maybe-read-next-byte ( bitstream -- bitstream )
+    dup #bits>> 0 = [ read-next-byte ] when ; inline
+
+: shift-one-bit ( bitstream -- n )
+    [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
+
+: next-bit ( bitstream -- n/f ? )
+    maybe-read-next-byte
+    dup end-of-stream?>> [
+        drop f
+    ] [
+        [ shift-one-bit ]
+        [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
+    ] if dup >boolean ;
+
+: read-bit ( bitstream -- n ? )
+    dup #bits>> 1 = [
+        [ current-bits>> 1 bitand ]
+        [ read-next-byte drop ] bi t
+    ] [
+        next-bit
+    ] if ; inline
+
+: bits>integer ( seq -- n )
+    0 [ [ 1 shift ] dip bitor ] reduce ; inline
+
+: read-bits ( width bitstream -- n width ? )
+    [
+        '[ _ read-bit drop ] replicate
+        [ f = ] trim-tail
+        [ bits>integer ] [ length ] bi
+    ] 2keep drop over = ;
+
+TUPLE: bitstream-writer < bitstream ;
+
+: <bitstream-writer> ( stream -- bitstream )
+    bitstream-writer new-bitstream ; inline
+
+: write-bit ( n bitstream -- )
+    [ 1 shift bitor ] change-current-bits
+    [ 1+ ] change-#bits
+    dup #bits>> 8 = [
+        [ [ current-bits>> ] [ stream>> stream-write1 ] bi ]
+        [ reset-bitstream drop ] bi
+    ] [
+        drop
+    ] if ; inline
+
+ERROR: invalid-bit-width n ;
+
+:: write-bits ( n width bitstream -- )
+    n 0 < [ n invalid-bit-width ] when
+    n 0 = [
+        width [ 0 bitstream write-bit ] times
+    ] [
+        width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times
+        n-length [
+            n-length swap - 1- neg n swap shift 1 bitand
+            bitstream write-bit
+        ] each
+    ] if ;
+
+: flush-bits ( bitstream -- ) stream>> stream-flush ;
+
+: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;

basis/bootstrap/image/image-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax io io.files io.pathnames ;
+USING: help.markup help.syntax io io.files io.pathnames strings ;
 IN: bootstrap.image
 
 ARTICLE: "bootstrap.image" "Bootstrapping new images"
@@ -14,7 +14,7 @@ $nl
 ABOUT: "bootstrap.image"
 
 HELP: make-image
-{ $values { "arch" "a string" } }
+{ $values { "arch" string } }
 { $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:"
-{ $code "x86.32" "x86.64" "ppc" "arm" }
+{ $code "x86.32" "unix-x86.64" "winnt-x86.64" "macosx-ppc" "linux-ppc" }
 "The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ;

basis/combinators/smart/smart-tests.factor

@@ -45,3 +45,5 @@ IN: combinators.smart.tests
 \ nested-smart-combo-test must-infer
 
 [ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
+
+[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test

basis/combinators/smart/smart.factor

@@ -21,6 +21,12 @@ MACRO: reduce-outputs ( quot operation -- newquot )
 : sum-outputs ( quot -- n )
     [ + ] reduce-outputs ; inline
 
+MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
+    [ dup infer out>> ] 2dip
+    [ swap '[ _ _ napply ] ]
+    [ [ 1 [-] ] dip n*quot ] bi-curry* bi
+    '[ @ @ @ ] ;
+
 MACRO: append-outputs-as ( quot exemplar -- newquot )
     [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
 

basis/compiler/alien/alien.factor

@@ -5,7 +5,7 @@ alien.c-types alien.structs cpu.architecture ;
 IN: compiler.alien
 
 : large-struct? ( ctype -- ? )
-    dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
+    dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
 
 : alien-parameters ( params -- seq )
     dup parameters>>

basis/compression/lzw/authors.txt

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

basis/compression/lzw/lzw-tests.factor

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

basis/compression/lzw/lzw.factor

@@ -0,0 +1,204 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs bitstreams byte-vectors combinators io
+io.encodings.binary io.streams.byte-array kernel math sequences
+vectors ;
+IN: compression.lzw
+
+CONSTANT: clear-code 256
+CONSTANT: end-of-information 257
+
+TUPLE: lzw input output end-of-input? table count k omega omega-k #bits
+code old-code ;
+
+SYMBOL: table-full
+
+ERROR: index-too-big n ;
+
+: lzw-bit-width ( n -- n' )
+    {
+        { [ dup 510 <= ] [ drop 9 ] }
+        { [ dup 1022 <= ] [ drop 10 ] }
+        { [ dup 2046 <= ] [ drop 11 ] }
+        { [ dup 4094 <= ] [ drop 12 ] }
+        [ drop table-full ]
+    } cond ;
+
+: lzw-bit-width-compress ( lzw -- n )
+    count>> lzw-bit-width ;
+
+: lzw-bit-width-uncompress ( lzw -- n )
+    table>> length lzw-bit-width ;
+
+: initial-compress-table ( -- assoc )
+    258 iota [ [ 1vector ] keep ] H{ } map>assoc ;
+
+: initial-uncompress-table ( -- seq )
+    258 iota [ 1vector ] V{ } map-as ;
+
+: reset-lzw ( lzw -- lzw )
+    257 >>count
+    V{ } clone >>omega
+    V{ } clone >>omega-k
+    9 >>#bits ;
+
+: reset-lzw-compress ( lzw -- lzw )
+    f >>k
+    initial-compress-table >>table reset-lzw ;
+
+: reset-lzw-uncompress ( lzw -- lzw )
+    initial-uncompress-table >>table reset-lzw ;
+
+: <lzw-compress> ( input -- obj )
+    lzw new
+        swap >>input
+        binary <byte-writer> <bitstream-writer> >>output
+        reset-lzw-compress ;
+
+: <lzw-uncompress> ( input -- obj )
+    lzw new
+        swap >>input
+        BV{ } clone >>output
+        reset-lzw-uncompress ;
+
+: push-k ( lzw -- lzw )
+    [ ]
+    [ k>> ]
+    [ omega>> clone [ push ] keep ] tri >>omega-k ;
+
+: omega-k-in-table? ( lzw -- ? )
+    [ omega-k>> ] [ table>> ] bi key? ;
+
+ERROR: not-in-table ;
+
+: write-output ( lzw -- )
+    [
+        [ omega>> ] [ table>> ] bi at* [ not-in-table ] unless
+    ] [
+        [ lzw-bit-width-compress ]
+        [ output>> write-bits ] bi
+    ] bi ;
+
+: omega-k>omega ( lzw -- lzw )
+    dup omega-k>> clone >>omega ;
+
+: k>omega ( lzw -- lzw )
+    dup k>> 1vector >>omega ;
+
+: add-omega-k ( lzw -- )
+    [ [ 1+ ] change-count count>> ]
+    [ omega-k>> clone ]
+    [ table>> ] tri set-at ;
+
+: lzw-compress-char ( lzw k -- )
+    >>k push-k dup omega-k-in-table? [
+        omega-k>omega drop
+    ] [
+        [ write-output ]
+        [ add-omega-k ]
+        [ k>omega drop ] tri
+    ] if ;
+
+: (lzw-compress-chars) ( lzw -- )
+    dup lzw-bit-width-compress table-full = [
+        drop
+    ] [
+        dup input>> stream-read1
+        [ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ]
+        [ t >>end-of-input? drop ] if*
+    ] if ;
+
+: lzw-compress-chars ( lzw -- )
+    {
+        ! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ]
+        [
+            [ clear-code ] dip
+            [ lzw-bit-width-compress ]
+            [ output>> write-bits ] bi
+        ]
+        [ (lzw-compress-chars) ]
+        [
+            [ k>> ]
+            [ lzw-bit-width-compress ]
+            [ output>> write-bits ] tri
+        ]
+        [
+            [ end-of-information ] dip
+            [ lzw-bit-width-compress ]
+            [ output>> write-bits ] bi
+        ]
+        [ ]
+    } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ;
+
+: lzw-compress ( byte-array -- seq )
+    binary <byte-reader> <lzw-compress>
+    [ lzw-compress-chars ] [ output>> stream>> ] bi ;
+
+: lookup-old-code ( lzw -- vector )
+    [ old-code>> ] [ table>> ] bi nth ;
+
+: lookup-code ( lzw -- vector )
+    [ code>> ] [ table>> ] bi nth ;
+
+: code-in-table? ( lzw -- ? )
+    [ code>> ] [ table>> length ] bi < ;
+
+: code>old-code ( lzw -- lzw )
+    dup code>> >>old-code ;
+
+: write-code ( lzw -- )
+    [ lookup-code ] [ output>> ] bi push-all ;
+
+: add-to-table ( seq lzw -- ) table>> push ;
+
+: lzw-read ( lzw -- lzw n )
+    [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ;
+
+DEFER: lzw-uncompress-char
+: handle-clear-code ( lzw -- )
+    reset-lzw-uncompress
+    lzw-read dup end-of-information = [
+        2drop
+    ] [
+        >>code
+        [ write-code ]
+        [ code>old-code ] bi
+        lzw-uncompress-char
+    ] if ;
+
+: handle-uncompress-code ( lzw -- lzw )
+    dup code-in-table? [
+        [ write-code ]
+        [
+            [
+                [ lookup-old-code ]
+                [ lookup-code first ] bi suffix
+            ] [ add-to-table ] bi
+        ] [ code>old-code ] tri
+    ] [
+        [
+            [ lookup-old-code dup first suffix ] keep
+            [ output>> push-all ] [ add-to-table ] 2bi
+        ] [ code>old-code ] bi
+    ] if ;
+    
+: lzw-uncompress-char ( lzw -- )
+    lzw-read [
+        >>code
+        dup code>> end-of-information = [
+            drop
+        ] [
+            dup code>> clear-code = [
+                handle-clear-code
+            ] [
+                handle-uncompress-code
+                lzw-uncompress-char
+            ] if
+        ] if
+    ] [
+        drop
+    ] if* ;
+
+: lzw-uncompress ( seq -- byte-array )
+    binary <byte-reader> <bitstream-reader>
+    <lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;

basis/compression/zlib/ffi/ffi.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.syntax combinators system ;
-IN: zlib.ffi
+IN: compression.zlib.ffi
 
 << "zlib" {
     { [ os winnt? ] [ "zlib1.dll" ] }

basis/compression/zlib/zlib-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test zlib classes ;
+USING: kernel tools.test compression.zlib classes ;
-IN: zlib.tests
+IN: compression.zlib.tests
 
 : compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
 

basis/compression/zlib/zlib.factor

@@ -3,8 +3,8 @@
 USING: alien alien.c-types alien.syntax byte-arrays combinators
 kernel math math.functions sequences system accessors
 libc ;
-QUALIFIED: zlib.ffi
+QUALIFIED: compression.zlib.ffi
-IN: zlib
+IN: compression.zlib
 
 TUPLE: compressed data length ;
 
@@ -16,7 +16,7 @@ TUPLE: compressed data length ;
 ERROR: zlib-failed n string ;
 
 : zlib-error-message ( n -- * )
-    dup zlib.ffi:Z_ERRNO = [
+    dup compression.zlib.ffi:Z_ERRNO = [
         drop errno "native libc error"
     ] [
         dup {
@@ -27,7 +27,7 @@ ERROR: zlib-failed n string ;
     ] if zlib-failed ;
 
 : zlib-error ( n -- )
-    dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
+    dup compression.zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
 
 : compressed-size ( byte-array -- n )
     length 1001/1000 * ceiling 12 + ;
@@ -35,7 +35,7 @@ ERROR: zlib-failed n string ;
 : compress ( byte-array -- compressed )
     [
         [ compressed-size <byte-array> dup length <ulong> ] keep [
-            dup length zlib.ffi:compress zlib-error
+            dup length compression.zlib.ffi:compress zlib-error
         ] 3keep drop *ulong head
     ] keep length <compressed> ;
 
@@ -44,5 +44,5 @@ ERROR: zlib-failed n string ;
         length>> [ <byte-array> ] keep <ulong> 2dup
     ] [
         data>> dup length
-        zlib.ffi:uncompress zlib-error
+        compression.zlib.ffi:uncompress zlib-error
     ] bi *ulong head ;

basis/cpu/architecture/architecture.factor

@@ -152,7 +152,7 @@ HOOK: %loop-entry cpu ( -- )
 HOOK: small-enough? cpu ( n -- ? )
 
 ! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? cpu ( c-type -- ? )
+HOOK: return-struct-in-registers? cpu ( c-type -- ? )
 
 ! Do we pass this struct by value or hidden reference?
 HOOK: value-struct? cpu ( c-type -- ? )

basis/cpu/ppc/ppc.factor

@@ -659,7 +659,7 @@ M: ppc %callback-value ( ctype -- )
 
 M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
 
-M: ppc struct-small-enough? ( size -- ? ) drop f ;
+M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
 
 M: ppc %box-small-struct
     drop "No small structs" throw ;

basis/cpu/x86/32/32.factor

@@ -48,9 +48,12 @@ M: x86.32 %alien-invoke (CALL) rel-dlsym ;
 
 M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
 
-M: x86.32 struct-small-enough? ( size -- ? )
+M: x86.32 return-struct-in-registers? ( c-type -- ? )
-    heap-size { 1 2 4 8 } member?
+    c-type
-    os { linux netbsd solaris } member? not and ;
+    [ return-in-registers?>> ]
+    [ heap-size { 1 2 4 8 } member? ] bi
+    os { linux netbsd solaris } member? not
+    and or ;
 
 : struct-return@ ( n -- operand )
     [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;

basis/cpu/x86/64/unix/unix.factor

@@ -44,7 +44,7 @@ M: struct-type flatten-value-type ( type -- seq )
         flatten-small-struct
     ] if ;
 
-M: x86.64 struct-small-enough? ( size -- ? )
+M: x86.64 return-struct-in-registers? ( c-type -- ? )
     heap-size 2 cells <= ;
 
 M: x86.64 dummy-stack-params? f ;

basis/cpu/x86/64/winnt/winnt.factor

@@ -10,7 +10,8 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
 
 M: x86.64 reserved-area-size 4 cells ;
 
-M: x86.64 struct-small-enough? heap-size { 1 2 4 8 } member? ;
+M: x86.64 return-struct-in-registers? ( c-type -- ? )
+    heap-size { 1 2 4 8 } member? ;
 
 M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ;
 

basis/db/postgresql/ffi/ffi.factor

@@ -11,46 +11,46 @@ IN: db.postgresql.ffi
 } cond "cdecl" add-library >>
 
 ! ConnSatusType
-: CONNECTION_OK                     HEX: 0 ; inline
+CONSTANT: CONNECTION_OK                     HEX: 0
-: CONNECTION_BAD                    HEX: 1 ; inline
+CONSTANT: CONNECTION_BAD                    HEX: 1
-: CONNECTION_STARTED                HEX: 2 ; inline
+CONSTANT: CONNECTION_STARTED                HEX: 2
-: CONNECTION_MADE                   HEX: 3 ; inline
+CONSTANT: CONNECTION_MADE                   HEX: 3
-: CONNECTION_AWAITING_RESPONSE      HEX: 4 ; inline
+CONSTANT: CONNECTION_AWAITING_RESPONSE      HEX: 4
-: CONNECTION_AUTH_OK                HEX: 5 ; inline
+CONSTANT: CONNECTION_AUTH_OK                HEX: 5
-: CONNECTION_SETENV                 HEX: 6 ; inline
+CONSTANT: CONNECTION_SETENV                 HEX: 6
-: CONNECTION_SSL_STARTUP            HEX: 7 ; inline
+CONSTANT: CONNECTION_SSL_STARTUP            HEX: 7
-: CONNECTION_NEEDED                 HEX: 8 ; inline
+CONSTANT: CONNECTION_NEEDED                 HEX: 8
 
 ! PostgresPollingStatusType
-: PGRES_POLLING_FAILED              HEX: 0 ; inline
+CONSTANT: PGRES_POLLING_FAILED              HEX: 0
-: PGRES_POLLING_READING             HEX: 1 ; inline
+CONSTANT: PGRES_POLLING_READING             HEX: 1
-: PGRES_POLLING_WRITING             HEX: 2 ; inline
+CONSTANT: PGRES_POLLING_WRITING             HEX: 2
-: PGRES_POLLING_OK                  HEX: 3 ; inline
+CONSTANT: PGRES_POLLING_OK                  HEX: 3
-: PGRES_POLLING_ACTIVE              HEX: 4 ; inline
+CONSTANT: PGRES_POLLING_ACTIVE              HEX: 4
 
 ! ExecStatusType;
-: PGRES_EMPTY_QUERY                 HEX: 0 ; inline
+CONSTANT: PGRES_EMPTY_QUERY                 HEX: 0
-: PGRES_COMMAND_OK                  HEX: 1 ; inline
+CONSTANT: PGRES_COMMAND_OK                  HEX: 1
-: PGRES_TUPLES_OK                   HEX: 2 ; inline
+CONSTANT: PGRES_TUPLES_OK                   HEX: 2
-: PGRES_COPY_OUT                    HEX: 3 ; inline
+CONSTANT: PGRES_COPY_OUT                    HEX: 3
-: PGRES_COPY_IN                     HEX: 4 ; inline
+CONSTANT: PGRES_COPY_IN                     HEX: 4
-: PGRES_BAD_RESPONSE                HEX: 5 ; inline
+CONSTANT: PGRES_BAD_RESPONSE                HEX: 5
-: PGRES_NONFATAL_ERROR              HEX: 6 ; inline
+CONSTANT: PGRES_NONFATAL_ERROR              HEX: 6
-: PGRES_FATAL_ERROR                 HEX: 7 ; inline
+CONSTANT: PGRES_FATAL_ERROR                 HEX: 7
 
 ! PGTransactionStatusType;
-: PQTRANS_IDLE                      HEX: 0 ; inline
+CONSTANT: PQTRANS_IDLE                      HEX: 0
-: PQTRANS_ACTIVE                    HEX: 1 ; inline
+CONSTANT: PQTRANS_ACTIVE                    HEX: 1
-: PQTRANS_INTRANS                   HEX: 2 ; inline
+CONSTANT: PQTRANS_INTRANS                   HEX: 2
-: PQTRANS_INERROR                   HEX: 3 ; inline
+CONSTANT: PQTRANS_INERROR                   HEX: 3
-: PQTRANS_UNKNOWN                   HEX: 4 ; inline
+CONSTANT: PQTRANS_UNKNOWN                   HEX: 4
 
 ! PGVerbosity;
-: PQERRORS_TERSE                    HEX: 0 ; inline
+CONSTANT: PQERRORS_TERSE                    HEX: 0
-: PQERRORS_DEFAULT                  HEX: 1 ; inline
+CONSTANT: PQERRORS_DEFAULT                  HEX: 1
-: PQERRORS_VERBOSE                  HEX: 2 ; inline
+CONSTANT: PQERRORS_VERBOSE                  HEX: 2
 
-: InvalidOid 0 ; inline
+CONSTANT: InvalidOid 0
 
 TYPEDEF: int ConnStatusType
 TYPEDEF: int ExecStatusType 
@@ -348,21 +348,21 @@ FUNCTION: int    PQdsplen ( uchar* s, int encoding ) ;
 FUNCTION: int    PQenv2encoding ( ) ;
 
 ! From git, include/catalog/pg_type.h
-: BOOL-OID 16 ; inline
+CONSTANT: BOOL-OID 16
-: BYTEA-OID 17 ; inline
+CONSTANT: BYTEA-OID 17
-: CHAR-OID 18 ; inline
+CONSTANT: CHAR-OID 18
-: NAME-OID 19 ; inline
+CONSTANT: NAME-OID 19
-: INT8-OID 20 ; inline
+CONSTANT: INT8-OID 20
-: INT2-OID 21 ; inline
+CONSTANT: INT2-OID 21
-: INT4-OID 23 ; inline
+CONSTANT: INT4-OID 23
-: TEXT-OID 23 ; inline
+CONSTANT: TEXT-OID 23
-: OID-OID 26 ; inline
+CONSTANT: OID-OID 26
-: FLOAT4-OID 700 ; inline
+CONSTANT: FLOAT4-OID 700
-: FLOAT8-OID 701 ; inline
+CONSTANT: FLOAT8-OID 701
-: VARCHAR-OID 1043 ; inline
+CONSTANT: VARCHAR-OID 1043
-: DATE-OID 1082 ; inline
+CONSTANT: DATE-OID 1082
-: TIME-OID 1083 ; inline
+CONSTANT: TIME-OID 1083
-: TIMESTAMP-OID 1114 ; inline
+CONSTANT: TIMESTAMP-OID 1114
-: TIMESTAMPTZ-OID 1184 ; inline
+CONSTANT: TIMESTAMPTZ-OID 1184
-: INTERVAL-OID 1186 ; inline
+CONSTANT: INTERVAL-OID 1186
-: NUMERIC-OID 1700 ; inline
+CONSTANT: NUMERIC-OID 1700

basis/db/queries/queries.factor

@@ -44,11 +44,11 @@ M: retryable execute-statement* ( statement type -- )
     ] bi attempt-all drop ;
 
 : sql-props ( class -- columns table )
-    [ db-columns ] [ db-table ] bi ;
+    [ db-columns ] [ db-table-name ] bi ;
 
 : query-make ( class quot -- statements )
     #! query, input, outputs, secondary queries
-    over unparse "table" set
+    over db-table-name "table-name" set
     [ sql-props ] dip
     [ 0 sql-counter rot with-variable ] curry
     { "" { } { } { } } nmake

basis/db/sqlite/ffi/ffi.factor

@@ -13,33 +13,33 @@ IN: db.sqlite.ffi
     } cond "cdecl" add-library >>
 
 ! Return values from sqlite functions
-: SQLITE_OK           0   ; inline ! Successful result
+CONSTANT: SQLITE_OK           0 ! Successful result
-: SQLITE_ERROR        1   ; inline ! SQL error or missing database
+CONSTANT: SQLITE_ERROR        1 ! SQL error or missing database
-: SQLITE_INTERNAL     2   ; inline ! An internal logic error in SQLite 
+CONSTANT: SQLITE_INTERNAL     2 ! An internal logic error in SQLite 
-: SQLITE_PERM         3   ; inline ! Access permission denied 
+CONSTANT: SQLITE_PERM         3 ! Access permission denied 
-: SQLITE_ABORT        4   ; inline ! Callback routine requested an abort 
+CONSTANT: SQLITE_ABORT        4 ! Callback routine requested an abort 
-: SQLITE_BUSY         5   ; inline ! The database file is locked 
+CONSTANT: SQLITE_BUSY         5 ! The database file is locked 
-: SQLITE_LOCKED       6   ; inline ! A table in the database is locked 
+CONSTANT: SQLITE_LOCKED       6 ! A table in the database is locked 
-: SQLITE_NOMEM        7   ; inline ! A malloc() failed 
+CONSTANT: SQLITE_NOMEM        7 ! A malloc() failed 
-: SQLITE_READONLY     8   ; inline ! Attempt to write a readonly database 
+CONSTANT: SQLITE_READONLY     8 ! Attempt to write a readonly database 
-: SQLITE_INTERRUPT    9   ; inline ! Operation terminated by sqlite_interrupt() 
+CONSTANT: SQLITE_INTERRUPT    9 ! Operation terminated by sqlite_interrupt() 
-: SQLITE_IOERR       10   ; inline ! Some kind of disk I/O error occurred 
+CONSTANT: SQLITE_IOERR       10 ! Some kind of disk I/O error occurred 
-: SQLITE_CORRUPT     11   ; inline ! The database disk image is malformed 
+CONSTANT: SQLITE_CORRUPT     11 ! The database disk image is malformed 
-: SQLITE_NOTFOUND    12   ; inline ! (Internal Only) Table or record not found 
+CONSTANT: SQLITE_NOTFOUND    12 ! (Internal Only) Table or record not found 
-: SQLITE_FULL        13   ; inline ! Insertion failed because database is full 
+CONSTANT: SQLITE_FULL        13 ! Insertion failed because database is full 
-: SQLITE_CANTOPEN    14   ; inline ! Unable to open the database file 
+CONSTANT: SQLITE_CANTOPEN    14 ! Unable to open the database file 
-: SQLITE_PROTOCOL    15   ; inline ! Database lock protocol error 
+CONSTANT: SQLITE_PROTOCOL    15 ! Database lock protocol error 
-: SQLITE_EMPTY       16   ; inline ! (Internal Only) Database table is empty 
+CONSTANT: SQLITE_EMPTY       16 ! (Internal Only) Database table is empty 
-: SQLITE_SCHEMA      17   ; inline ! The database schema changed 
+CONSTANT: SQLITE_SCHEMA      17 ! The database schema changed 
-: SQLITE_TOOBIG      18   ; inline ! Too much data for one row of a table 
+CONSTANT: SQLITE_TOOBIG      18 ! Too much data for one row of a table 
-: SQLITE_CONSTRAINT  19   ; inline ! Abort due to contraint violation 
+CONSTANT: SQLITE_CONSTRAINT  19 ! Abort due to contraint violation 
-: SQLITE_MISMATCH    20   ; inline ! Data type mismatch 
+CONSTANT: SQLITE_MISMATCH    20 ! Data type mismatch 
-: SQLITE_MISUSE      21   ; inline ! Library used incorrectly 
+CONSTANT: SQLITE_MISUSE      21 ! Library used incorrectly 
-: SQLITE_NOLFS       22   ; inline ! Uses OS features not supported on host 
+CONSTANT: SQLITE_NOLFS       22 ! Uses OS features not supported on host 
-: SQLITE_AUTH        23   ; inline ! Authorization denied 
+CONSTANT: SQLITE_AUTH        23 ! Authorization denied 
-: SQLITE_FORMAT      24   ; inline ! Auxiliary database format error
+CONSTANT: SQLITE_FORMAT      24 ! Auxiliary database format error
-: SQLITE_RANGE       25   ; inline ! 2nd parameter to sqlite3_bind out of range
+CONSTANT: SQLITE_RANGE       25 ! 2nd parameter to sqlite3_bind out of range
-: SQLITE_NOTADB      26   ; inline ! File opened that is not a database file
+CONSTANT: SQLITE_NOTADB      26 ! File opened that is not a database file
 
 : sqlite-error-messages ( -- seq ) {
     "Successful result"
@@ -72,32 +72,32 @@ IN: db.sqlite.ffi
 } ;
 
 ! Return values from sqlite3_step
-: SQLITE_ROW         100  ; inline
+CONSTANT: SQLITE_ROW         100
-: SQLITE_DONE        101  ; inline
+CONSTANT: SQLITE_DONE        101
 
 ! Return values from the sqlite3_column_type function
-: SQLITE_INTEGER     1 ; inline
+CONSTANT: SQLITE_INTEGER     1
-: SQLITE_FLOAT       2 ; inline
+CONSTANT: SQLITE_FLOAT       2
-: SQLITE_TEXT        3 ; inline
+CONSTANT: SQLITE_TEXT        3
-: SQLITE_BLOB        4 ; inline
+CONSTANT: SQLITE_BLOB        4
-: SQLITE_NULL        5 ; inline
+CONSTANT: SQLITE_NULL        5
 
 ! Values for the 'destructor' parameter of the 'bind' routines. 
-: SQLITE_STATIC      0  ; inline
+CONSTANT: SQLITE_STATIC      0
-: SQLITE_TRANSIENT   -1 ; inline
+CONSTANT: SQLITE_TRANSIENT   -1
 
-: SQLITE_OPEN_READONLY         HEX: 00000001 ; inline
+CONSTANT: SQLITE_OPEN_READONLY         HEX: 00000001
-: SQLITE_OPEN_READWRITE        HEX: 00000002 ; inline
+CONSTANT: SQLITE_OPEN_READWRITE        HEX: 00000002
-: SQLITE_OPEN_CREATE           HEX: 00000004 ; inline
+CONSTANT: SQLITE_OPEN_CREATE           HEX: 00000004
-: SQLITE_OPEN_DELETEONCLOSE    HEX: 00000008 ; inline
+CONSTANT: SQLITE_OPEN_DELETEONCLOSE    HEX: 00000008
-: SQLITE_OPEN_EXCLUSIVE        HEX: 00000010 ; inline
+CONSTANT: SQLITE_OPEN_EXCLUSIVE        HEX: 00000010
-: SQLITE_OPEN_MAIN_DB          HEX: 00000100 ; inline
+CONSTANT: SQLITE_OPEN_MAIN_DB          HEX: 00000100
-: SQLITE_OPEN_TEMP_DB          HEX: 00000200 ; inline
+CONSTANT: SQLITE_OPEN_TEMP_DB          HEX: 00000200
-: SQLITE_OPEN_TRANSIENT_DB     HEX: 00000400 ; inline
+CONSTANT: SQLITE_OPEN_TRANSIENT_DB     HEX: 00000400
-: SQLITE_OPEN_MAIN_JOURNAL     HEX: 00000800 ; inline
+CONSTANT: SQLITE_OPEN_MAIN_JOURNAL     HEX: 00000800
-: SQLITE_OPEN_TEMP_JOURNAL     HEX: 00001000 ; inline
+CONSTANT: SQLITE_OPEN_TEMP_JOURNAL     HEX: 00001000
-: SQLITE_OPEN_SUBJOURNAL       HEX: 00002000 ; inline
+CONSTANT: SQLITE_OPEN_SUBJOURNAL       HEX: 00002000
-: SQLITE_OPEN_MASTER_JOURNAL   HEX: 00004000 ; inline
+CONSTANT: SQLITE_OPEN_MASTER_JOURNAL   HEX: 00004000
 
 TYPEDEF: void sqlite3
 TYPEDEF: void sqlite3_stmt

basis/db/sqlite/sqlite-tests.factor

@@ -95,3 +95,73 @@ things "THINGS" {
        things drop-table
     ] with-db
 ] unit-test
+
+! Tables can have different names than the name of the tuple
+TUPLE: foo slot ;
+C: <foo> foo
+foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent
+
+TUPLE: hi bye try ;
+C: <hi> hi
+hi "HELLO" {
+    { "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } }
+    { "try" "RETHROW" INTEGER { +foreign-id+ foo "SOMETHING" } }
+} define-persistent
+
+[ T{ foo { slot 1 } } T{ hi { bye 1 } { try 1 } } ] [
+    test.db [
+        foo create-table
+        hi create-table
+        1 <foo> insert-tuple
+        f <foo> select-tuple
+        1 1 <hi> insert-tuple
+        f <hi> select-tuple
+        hi drop-table
+        foo drop-table
+    ] with-db
+] unit-test
+
+[ ] [
+    test.db [
+        hi create-table
+        hi drop-table
+    ] with-db
+] unit-test
+
+TUPLE: show id ;
+TUPLE: user username data ;
+TUPLE: watch show user ;
+
+user "USER" {
+    { "username" "USERNAME" TEXT +not-null+ +user-assigned-id+ }
+    { "data" "DATA" TEXT }
+} define-persistent
+
+show "SHOW" {
+    { "id" "ID" +db-assigned-id+ }
+} define-persistent
+
+watch "WATCH" {
+    { "user" "USER" TEXT +not-null+
+        { +foreign-id+ user "USERNAME" } +user-assigned-id+ }
+    { "show" "SHOW" BIG-INTEGER +not-null+
+        { +foreign-id+ show "ID" } +user-assigned-id+ }
+} define-persistent
+
+[ T{ user { username "littledan" } { data "foo" } } ] [
+    test.db [
+        user create-table
+        show create-table
+        watch create-table
+        "littledan" "foo" user boa insert-tuple
+        "mark" "bar" user boa insert-tuple
+        show new insert-tuple
+        show new select-tuple
+        "littledan" f user boa select-tuple
+        watch boa insert-tuple
+        watch new select-tuple
+        user>> f user boa select-tuple
+    ] with-db
+] unit-test
+
+[ \ swap ensure-table ] must-fail

basis/db/sqlite/sqlite.factor

@@ -225,11 +225,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : insert-trigger ( -- string )
     [
     <"
-        CREATE TRIGGER fki_${table}_${foreign-table}_id
+        CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
-        BEFORE INSERT ON ${table}
+        BEFORE INSERT ON ${table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
-            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
     "> interpolate
     ] with-string-writer ;
@@ -237,12 +237,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : insert-trigger-not-null ( -- string )
     [
     <"
-        CREATE TRIGGER fki_${table}_${foreign-table}_id
+        CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
-        BEFORE INSERT ON ${table}
+        BEFORE INSERT ON ${table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
             WHERE NEW.${foreign-table-id} IS NOT NULL
-                AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+                AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
     "> interpolate
     ] with-string-writer ;
@@ -250,11 +250,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : update-trigger ( -- string )
     [
     <"
-        CREATE TRIGGER fku_${table}_${foreign-table}_id
+        CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
-        BEFORE UPDATE ON ${table}
+        BEFORE UPDATE ON ${table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
-            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
     "> interpolate
     ] with-string-writer ;
@@ -262,12 +262,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : update-trigger-not-null ( -- string )
     [
     <"
-        CREATE TRIGGER fku_${table}_${foreign-table}_id
+        CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
-        BEFORE UPDATE ON ${table}
+        BEFORE UPDATE ON ${table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
             WHERE NEW.${foreign-table-id} IS NOT NULL
-                AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+                AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
         END;
     "> interpolate
     ] with-string-writer ;
@@ -275,11 +275,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : delete-trigger-restrict ( -- string )
     [
     <"
-        CREATE TRIGGER fkd_${table}_${foreign-table}_id
+        CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
-        BEFORE DELETE ON ${foreign-table}
+        BEFORE DELETE ON ${foreign-table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
+            SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
-            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
+            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
         END;
     "> interpolate
     ] with-string-writer ;
@@ -287,10 +287,10 @@ M: sqlite-db-connection persistent-table ( -- assoc )
 : delete-trigger-cascade ( -- string )
     [
     <"
-        CREATE TRIGGER fkd_${table}_${foreign-table}_id
+        CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
-        BEFORE DELETE ON ${foreign-table}
+        BEFORE DELETE ON ${foreign-table-name}
         FOR EACH ROW BEGIN
-            DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
+            DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
         END;
     "> interpolate
     ] with-string-writer ;
@@ -323,7 +323,7 @@ M: sqlite-db-connection compound ( string seq -- new-string )
         { "default" [ first number>string " " glue ] }
         { "references" [
             [ >reference-string ] keep
-            first2 [ "foreign-table" set ]
+            first2 [ db-table-name "foreign-table-name" set ]
             [ "foreign-table-id" set ] bi*
             create-sqlite-triggers
         ] }

basis/db/types/types.factor

@@ -49,7 +49,7 @@ ERROR: no-slot ;
 
 ERROR: not-persistent class ;
 
-: db-table ( class -- object )
+: db-table-name ( class -- object )
     dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
 
 : db-columns ( class -- object )
@@ -165,7 +165,7 @@ ERROR: no-column column ;
 
 : >reference-string ( string pair -- string )
     first2
-    [ [ unparse " " glue ] [ db-columns ] bi ] dip
+    [ [ db-table-name " " glue ] [ db-columns ] bi ] dip
     swap [ column-name>> = ] with find nip
     [ no-column ] unless*
     column-name>> "(" ")" surround append ;

basis/editors/editors.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser lexer kernel namespaces sequences definitions
 io.files io.backend io.pathnames io summary continuations
 tools.crossref tools.vocabs prettyprint source-files assocs
-vocabs vocabs.loader splitting accessors ;
+vocabs vocabs.loader splitting accessors debugger prettyprint
+help.topics ;
 IN: editors
 
 TUPLE: no-edit-hook ;
@@ -29,11 +30,21 @@ SYMBOL: edit-hook
     [ (normalize-path) ] dip edit-hook get-global
     [ call ] [ no-edit-hook edit-location ] if* ;
 
+ERROR: cannot-find-source definition ;
+
+M: cannot-find-source error.
+    "Cannot find source for ``" write
+    definition>> pprint-short
+    "''" print ;
+
 : edit ( defspec -- )
-    where [ first2 edit-location ] when* ;
+    dup where
+    [ first2 edit-location ]
+    [ dup word-link? [ name>> edit ] [ cannot-find-source ] if ]
+    ?if ;
 
 : edit-vocab ( name -- )
-    vocab-source-path 1 edit-location ;
+    >vocab-link edit ;
 
 GENERIC: error-file ( error -- file )
 

basis/endian/endian.factor

@@ -1,39 +1,39 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types namespaces io.binary fry
-kernel math ;
+kernel math grouping sequences ;
 IN: endian
 
 SINGLETONS: big-endian little-endian ;
 
-: native-endianness ( -- class )
+: compute-native-endianness ( -- class )
     1 <int> *char 0 = big-endian little-endian ? ;
 
 : >signed ( x n -- y )
     2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
 
-native-endianness \ native-endianness set-global
+SYMBOL: native-endianness
+native-endianness [ compute-native-endianness ] initialize
 
 SYMBOL: endianness
+endianness [ native-endianness get-global ] initialize
 
-\ native-endianness get-global endianness set-global
+HOOK: >native-endian native-endianness ( obj n -- bytes )
-
-HOOK: >native-endian native-endianness ( obj n -- str )
 
 M: big-endian >native-endian >be ;
 
 M: little-endian >native-endian >le ;
 
-HOOK: unsigned-native-endian> native-endianness ( obj -- str )
+HOOK: unsigned-native-endian> native-endianness ( obj -- bytes )
 
 M: big-endian unsigned-native-endian> be> ;
 
 M: little-endian unsigned-native-endian> le> ;
 
-: signed-native-endian> ( obj n -- str )
+: signed-native-endian> ( obj n -- n' )
     [ unsigned-native-endian> ] dip >signed ;
 
-HOOK: >endian endianness ( obj n -- str )
+HOOK: >endian endianness ( obj n -- bytes )
 
 M: big-endian >endian >be ;
 
@@ -45,13 +45,13 @@ M: big-endian endian> be> ;
 
 M: little-endian endian> le> ;
 
-HOOK: unsigned-endian> endianness ( obj -- str )
+HOOK: unsigned-endian> endianness ( obj -- bytes )
 
 M: big-endian unsigned-endian> be> ;
 
 M: little-endian unsigned-endian> le> ;
 
-: signed-endian> ( obj n -- str )
+: signed-endian> ( obj n -- bytes )
     [ unsigned-endian> ] dip >signed ;
 
 : with-endianness ( endian quot -- )
@@ -65,3 +65,15 @@ M: little-endian unsigned-endian> le> ;
 
 : with-native-endian ( quot -- )
     \ native-endianness get-global swap with-endianness ; inline
+
+: seq>native-endianness ( seq n -- seq' )
+    native-endianness get-global dup endianness get = [
+        2drop
+    ] [
+        [ [ <sliced-groups> ] keep ] dip
+        little-endian = [
+            '[ be> _ >le ] map
+        ] [
+            '[ le> _ >be ] map
+        ] if concat
+    ] if ; inline

basis/http/client/client-docs.factor

@@ -56,8 +56,7 @@ HELP: http-request
 
 HELP: with-http-request
 { $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } }
-{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." }
+{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read. Does not throw an error if the HTTP request fails; to do so, call " { $link check-response } " on the " { $snippet "response" } "." } ;
-{ $errors "Throws an error if the HTTP request fails." } ;
 
 ARTICLE: "http.client.get" "GET requests with the HTTP client"
 "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"

basis/http/client/client.factor

@@ -141,12 +141,15 @@ ERROR: download-failed response ;
 : check-response ( response -- response )
     dup code>> success? [ download-failed ] unless ;
 
+: check-response-with-body ( response body -- response body )
+    [ >>body check-response ] keep ;
+
 : with-http-request ( request quot -- response )
-    [ (with-http-request) check-response ] with-destructors ; inline
+    [ (with-http-request) ] with-destructors ; inline
 
 : http-request ( request -- response data )
     [ [ % ] with-http-request ] B{ } make
-    over content-charset>> decode ;
+    over content-charset>> decode check-response-with-body ;
 
 : <get-request> ( url -- request )
     "GET" <client-request> ;

basis/http/http-docs.factor

@@ -113,6 +113,12 @@ HELP: set-header
 { $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
 { $side-effects "request/response" } ;
 
+HELP: set-basic-auth
+{ $values { "request" request } { "username" string } { "password" string } }
+{ $description "Sets the " { $snippet "Authorization" } " header of " { $snippet "request" } " to perform HTTP Basic authentication with the given " { $snippet "username" } " and " { $snippet "password" } "." }
+{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
+{ $side-effects "request" } ;
+
 ARTICLE: "http.cookies" "HTTP cookies"
 "Every " { $link request } " and " { $link response } " instance can contain cookies."
 $nl

basis/http/http-tests.factor

@@ -359,3 +359,8 @@ SYMBOL: a
 ! Test cloning
 [ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
 [ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
+
+! Test basic auth
+[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test
+
+

basis/http/http.factor

@@ -7,7 +7,8 @@ calendar.format present urls fry
 io io.encodings io.encodings.iana io.encodings.binary
 io.encodings.8-bit io.crlf
 unicode.case unicode.categories
-http.parsers ;
+http.parsers
+base64 ;
 IN: http
 
 : (read-header) ( -- alist )
@@ -142,6 +143,9 @@ cookies ;
 : set-header ( request/response value key -- request/response )
     pick header>> set-at ;
 
+: set-basic-auth ( request username password -- request )
+    ":" glue >base64 "Basic " prepend "Authorization" set-header ;
+    
 : <request> ( -- request )
     request new
         "1.1" >>version
@@ -156,6 +160,7 @@ cookies ;
 : header ( request/response key -- value )
     swap header>> at ;
 
+
 TUPLE: response
 version
 code

basis/http/server/static/static-docs.factor

@@ -38,7 +38,7 @@ $nl
 "If all you want to do is serve files from a directory, the following phrase does the trick:"
 { $code
     "USING: namespaces http.server http.server.static ;"
-    "/var/www/mysite.com/ <static> main-responder set"
+    "\"/var/www/mysite.com/\" <static> main-responder set"
     "8080 httpd"
 }
 { $subsection "http.server.static.extend" } ;

basis/http/server/static/static.factor

@@ -45,9 +45,8 @@ TUPLE: file-responder root hook special allow-listings ;
     [ file-responder get hook>> call ] [ 2drop <304> ] if ;
 
 : serving-path ( filename -- filename )
-    file-responder get root>> trim-tail-separators
+    [ file-responder get root>> trim-tail-separators "/" ] dip
-    "/"
+    "" or trim-head-separators 3append ;
-    rot "" or trim-head-separators 3append ;
 
 : serve-file ( filename -- response )
     dup mime-type

basis/images/backend/backend.factor

@@ -1,51 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel grouping fry sequences combinators
-math ;
-IN: images.backend
-
-SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
-
-TUPLE: image dim component-order bitmap ;
-
-TUPLE: normalized-image < image ;
-
-GENERIC: load-image* ( path tuple -- image )
-
-GENERIC: >image ( object -- image )
-
-: no-op ( -- ) ;
-
-: normalize-component-order ( image -- image )
-    dup component-order>>
-    {
-        { RGBA [ no-op ] }
-        { BGRA [
-            [
-                [ 4 <sliced-groups> [ [ 0 3 ] dip <slice> reverse-here ] each ]
-                [ RGBA >>component-order ] bi
-            ] change-bitmap
-        ] }
-        { RGB [
-            [ 3 <sliced-groups> [ 255 suffix ] map concat ] change-bitmap
-        ] }
-        { BGR [
-            [
-                3 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
-                [ 255 suffix ] map concat
-            ] change-bitmap
-        ] }
-    } case RGBA >>component-order ;
-
-GENERIC: normalize-scan-line-order ( image -- image )
-
-M: image normalize-scan-line-order ;
-: normalize-image ( image -- image )
-    normalize-component-order
-    normalize-scan-line-order ;
-
-: new-image ( dim component-order bitmap class -- image )
-    new 
-        swap >>bitmap
-        swap >>component-order
-        swap >>dim ; inline

basis/images/bitmap/bitmap-tests.factor

@@ -3,16 +3,16 @@ io.files io.files.unique kernel tools.test ;
 IN: images.bitmap.tests
 
 : test-bitmap24 ( -- path )
-    "resource:extra/images/test-images/thiswayup24.bmp" ;
+    "resource:basis/images/test-images/thiswayup24.bmp" ;
 
 : test-bitmap8 ( -- path )
-    "resource:extra/images/test-images/rgb8bit.bmp" ;
+    "resource:basis/images/test-images/rgb8bit.bmp" ;
 
 : test-bitmap4 ( -- path )
-    "resource:extra/images/test-images/rgb4bit.bmp" ;
+    "resource:basis/images/test-images/rgb4bit.bmp" ;
 
 : test-bitmap1 ( -- path )
-    "resource:extra/images/test-images/1bit.bmp" ;
+    "resource:basis/images/test-images/1bit.bmp" ;
 
 [ t ]
 [

basis/images/bitmap/bitmap.factor

@@ -1,10 +1,9 @@
 ! Copyright (C) 2007, 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types arrays byte-arrays columns
-combinators fry grouping io io.binary io.encodings.binary
+combinators fry grouping io io.binary io.encodings.binary io.files
-io.files kernel libc macros math math.bitwise math.functions
+kernel macros math math.bitwise math.functions namespaces sequences
-namespaces opengl opengl.gl prettyprint sequences strings
+strings images endian summary ;
-summary ui ui.gadgets.panes images.backend ;
 IN: images.bitmap
 
 TUPLE: bitmap-image < image ;
@@ -102,12 +101,12 @@ ERROR: unknown-component-order bitmap ;
         [ unknown-component-order ]
     } case ;
 
-M: bitmap >image ( bitmap -- bitmap-image )
+: >image ( bitmap -- bitmap-image )
     {
         [ [ width>> ] [ height>> ] bi 2array ]
         [ bitmap>component-order ]
         [ buffer>> ]
-    } cleave bitmap-image new-image ;
+    } cleave bitmap-image boa ;
 
 M: bitmap-image load-image* ( path bitmap -- bitmap-image )
     drop load-bitmap >image ;

basis/images/images.factor

@@ -1,21 +1,62 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: constructors kernel splitting unicode.case combinators
+USING: kernel accessors grouping sequences combinators
-accessors images.bitmap images.tiff images.backend io.backend
+math specialized-arrays.direct.uint byte-arrays
-io.pathnames ;
+specialized-arrays.direct.ushort ;
 IN: images
 
-ERROR: unknown-image-extension extension ;
+SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+R16G16B16 R32G32B32 ;
 
-: image-class ( path -- class )
+TUPLE: image dim component-order bitmap ;
-    file-extension >lower {
-        { "bmp" [ bitmap-image ] }
-        { "tiff" [ tiff-image ] }
-        [ unknown-image-extension ]
-    } case ;
 
-: load-image ( path -- image )
+: <image> ( -- image ) image new ; inline
-    dup image-class new load-image* ;
 
-: <image> ( path -- image )
+GENERIC: load-image* ( path tuple -- image )
-    load-image normalize-image ;
+
+: add-dummy-alpha ( seq -- seq' )
+    3 <sliced-groups>
+    [ 255 suffix ] map concat ;
+
+: normalize-component-order ( image -- image )
+    dup component-order>>
+    {
+        { RGBA [ ] }
+        { R32G32B32 [
+            [
+                dup length 4 / <direct-uint-array>
+                [ bits>float 255.0 * >integer ] map
+                >byte-array add-dummy-alpha
+            ] change-bitmap
+        ] }
+        { R16G16B16 [
+            [
+                dup length 2 / <direct-ushort-array>
+                [ -8 shift ] map
+                >byte-array add-dummy-alpha
+            ] change-bitmap
+        ] }
+        { BGRA [
+            [
+                4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
+            ] change-bitmap
+        ] }
+        { RGB [ [ add-dummy-alpha ] change-bitmap ] }
+        { BGR [
+            [
+                3 <sliced-groups>
+                [ [ [ 0 3 ] dip <slice> reverse-here ] each ]
+                [ add-dummy-alpha ] bi
+            ] change-bitmap
+        ] }
+    } case
+    RGBA >>component-order ;
+
+GENERIC: normalize-scan-line-order ( image -- image )
+
+M: image normalize-scan-line-order ;
+
+: normalize-image ( image -- image )
+    [ >byte-array ] change-bitmap
+    normalize-component-order
+    normalize-scan-line-order ;

basis/images/loader/authors.txt

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

basis/images/loader/loader.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: constructors kernel splitting unicode.case combinators
+accessors images.bitmap images.tiff images io.backend
+io.pathnames ;
+IN: images.loader
+
+ERROR: unknown-image-extension extension ;
+
+: image-class ( path -- class )
+    file-extension >lower {
+        { "bmp" [ bitmap-image ] }
+        { "tif" [ tiff-image ] }
+        { "tiff" [ tiff-image ] }
+        [ unknown-image-extension ]
+    } case ;
+
+: load-image ( path -- image )
+    dup image-class new load-image* normalize-image ;

basis/images/tiff/tiff.factor

@@ -1,9 +1,11 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators io io.encodings.binary io.files kernel
+USING: accessors arrays assocs byte-arrays classes combinators
-pack endian constructors sequences arrays math.order math.parser
+compression.lzw constructors endian fry grouping images io
-prettyprint classes io.binary assocs math math.bitwise byte-arrays
+io.binary io.encodings.ascii io.encodings.binary
-grouping images.backend ;
+io.encodings.string io.encodings.utf8 io.files kernel math
+math.bitwise math.order math.parser pack prettyprint sequences
+strings ;
 IN: images.tiff
 
 TUPLE: tiff-image < image ;
@@ -115,8 +117,9 @@ ERROR: bad-extra-samples n ;
 
 SINGLETONS: image-length image-width x-resolution y-resolution
 rows-per-strip strip-offsets strip-byte-counts bits-per-sample
-samples-per-pixel new-subfile-type orientation
+samples-per-pixel new-subfile-type orientation software
-unhandled-ifd-entry ;
+date-time photoshop exif-ifd sub-ifd inter-color-profile
+xmp iptc unhandled-ifd-entry ;
 
 ERROR: bad-tiff-magic bytes ;
 : tiff-endianness ( byte-array -- ? )
@@ -185,6 +188,7 @@ ERROR: unknown-ifd-type n ;
         { 10 [ 8 * ] }
         { 11 [ 4 * ] }
         { 12 [ 8 * ] }
+        { 13 [ 4 * ] }
         [ unknown-ifd-type ]
     } case ;
 
@@ -200,6 +204,7 @@ ERROR: bad-small-ifd-type n ;
         { 8 [ 2 head endian> 16 >signed ] }
         { 9 [ endian> 32 >signed ] }
         { 11 [ endian> bits>float ] }
+        { 13 [ endian> 32 >signed ] }
         [ bad-small-ifd-type ]
     } case ;
 
@@ -242,51 +247,93 @@ ERROR: bad-small-ifd-type n ;
         { 277 [ samples-per-pixel ] }
         { 278 [ rows-per-strip ] }
         { 279 [ strip-byte-counts ] }
-        { 282 [ x-resolution ] }
+        { 282 [ first x-resolution ] }
-        { 283 [ y-resolution ] }
+        { 283 [ first y-resolution ] }
         { 284 [ planar-configuration ] }
         { 296 [ lookup-resolution-unit resolution-unit ] }
+        { 305 [ ascii decode software ] }
+        { 306 [ ascii decode date-time ] }
         { 317 [ lookup-predictor predictor ] }
+        { 330 [ sub-ifd ] }
         { 338 [ lookup-extra-samples extra-samples ] }
         { 339 [ lookup-sample-format sample-format ] }
-        [ nip unhandled-ifd-entry ]
+        { 700 [ utf8 decode xmp ] }
+        { 34377 [ photoshop ] }
+        { 34665 [ exif-ifd ] }
+        { 33723 [ iptc ] }
+        { 34675 [ inter-color-profile ] }
+        [ nip unhandled-ifd-entry swap ]
     } case ;
 
 : process-ifd ( ifd -- ifd )
     dup ifd-entries>>
     [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
 
+ERROR: unhandled-compression compression ;
+
+: (uncompress-strips) ( strips compression -- uncompressed-strips )
+    {
+        { compression-none [ ] }
+        { compression-lzw [ [ lzw-uncompress ] map ] }
+        [ unhandled-compression ]
+    } case ;
+
+: uncompress-strips ( ifd -- ifd )
+    dup '[
+        _ compression find-tag (uncompress-strips)
+    ] change-strips ;
+
 : strips>bitmap ( ifd -- ifd )
     dup strips>> concat >>bitmap ;
 
 ERROR: unknown-component-order ifd ;
 
+: fix-bitmap-endianness ( ifd -- ifd )
+    dup [ bitmap>> ] [ bits-per-sample find-tag ] bi
+    {
+        { { 32 32 32 32 } [ 4 seq>native-endianness ] }
+        { { 32 32 32 } [ 4 seq>native-endianness ] }
+        { { 16 16 16 16 } [ 2 seq>native-endianness ] }
+        { { 16 16 16 } [ 2 seq>native-endianness ] }
+        { { 8 8 8 8 } [ ] }
+        { { 8 8 8 } [ ] }
+        [ unknown-component-order ]
+    } case >>bitmap ;
+
 : ifd-component-order ( ifd -- byte-order )
-    bits-per-sample find-tag sum {
+    bits-per-sample find-tag {
-        { 32 [ RGBA ] }
+        { { 32 32 32 } [ R32G32B32 ] }
-        { 24 [ RGB ] }
+        { { 16 16 16 } [ R16G16B16 ] }
+        { { 8 8 8 8 } [ RGBA ] }
+        { { 8 8 8 } [ RGB ] }
         [ unknown-component-order ]
     } case ;
 
-M: ifd >image ( ifd -- image )
+: ifd>image ( ifd -- image )
     {
         [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
         [ ifd-component-order ]
         [ bitmap>> ]
-    } cleave tiff-image new-image ;
+    } cleave tiff-image boa ;
 
-M: parsed-tiff >image ( image -- image )
+: tiff>image ( image -- image )
-    ifds>> [ >image ] map first ;
+    ifds>> [ ifd>image ] map first ;
 
 : load-tiff ( path -- parsed-tiff )
     binary [
         <parsed-tiff>
         read-header dup endianness>> [
             read-ifds
-            dup ifds>> [ process-ifd read-strips strips>bitmap drop ] each
+            dup ifds>> [
+                process-ifd read-strips
+                uncompress-strips
+                strips>bitmap
+                fix-bitmap-endianness
+                drop
+            ] each
         ] with-endianness
     ] with-file-reader ;
 
 ! tiff files can store several images -- we just take the first for now
 M: tiff-image load-image* ( path tiff-image -- image )
-    drop load-tiff >image ;
+    drop load-tiff tiff>image ;

basis/tools/hexdump/hexdump.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays io io.streams.string kernel math math.parser
-namespaces sequences splitting grouping strings ascii byte-arrays ;
+namespaces sequences splitting grouping strings ascii
+byte-arrays byte-vectors ;
 IN: tools.hexdump
 
 <PRIVATE
@@ -26,13 +27,17 @@ IN: tools.hexdump
 : write-hex-line ( bytes lineno -- )
     write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
 
+: hexdump-bytes ( bytes -- )
+    [ length write-header ]
+    [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
+
 PRIVATE>
 
 GENERIC: hexdump. ( byte-array -- )
 
-M: byte-array hexdump.
+M: byte-array hexdump. hexdump-bytes ;
-    [ length write-header ]
+
-    [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
+M: byte-vector hexdump. hexdump-bytes ;
 
 : hexdump ( byte-array -- str )
     [ hexdump. ] with-string-writer ;

basis/xml/syntax/syntax.factor

@@ -174,6 +174,8 @@ PRIVATE>
 : [XML
     "XML]" [ string>chunk ] parse-def ; parsing
 
+<PRIVATE
+
 : remove-blanks ( seq -- newseq )
     [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
 
@@ -241,3 +243,5 @@ M: interpolated [undo-xml]
     [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
 
 \ interpolate-xml 1 [ undo-xml ] define-pop-inverse
+
+PRIVATE>

basis/xml/tests/test.factor

@@ -3,7 +3,7 @@
 IN: xml.tests
 USING: kernel xml tools.test io namespaces make sequences
 xml.errors xml.entities.html parser strings xml.data io.files
-xml.traversal continuations assocs
+xml.traversal continuations assocs io.encodings.binary
 sequences.deep accessors io.streams.string ;
 
 ! This is insufficient
@@ -12,8 +12,14 @@ sequences.deep accessors io.streams.string ;
 \ string>xml must-infer
 
 SYMBOL: xml-file
-[ ] [ "resource:basis/xml/tests/test.xml"
+[ ] [
-    [ file>xml ] with-html-entities xml-file set ] unit-test
+    "resource:basis/xml/tests/test.xml"
+    [ file>xml ] with-html-entities xml-file set
+] unit-test
+[ t ] [
+    "resource:basis/xml/tests/test.xml" binary file-contents
+    [ bytes>xml ] with-html-entities xml-file get =
+] unit-test
 [ "1.0" ] [ xml-file get prolog>> version>> ] unit-test
 [ f ] [ xml-file get prolog>> standalone>> ] unit-test
 [ "a" ] [ xml-file get space>> ] unit-test

basis/xml/xml-docs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax xml.data io strings ;
+USING: help.markup help.syntax xml.data io strings byte-arrays ;
 IN: xml
 
 HELP: string>xml
@@ -16,7 +16,11 @@ HELP: file>xml
 { $values { "filename" string } { "xml" xml } }
 { $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ;
 
-{ string>xml read-xml file>xml } related-words
+HELP: bytes>xml
+{ $values { "byte-array" byte-array } { "xml" xml } }
+{ $description "Parses a byte array as an XML document. The encoding is automatically detected." } ;
+
+{ string>xml read-xml file>xml bytes>xml } related-words
 
 HELP: read-xml-chunk
 { $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }
@@ -68,6 +72,7 @@ ARTICLE: { "xml" "reading" } "Reading XML"
     { $subsection read-xml-chunk }
     { $subsection string>xml-chunk }
     { $subsection file>xml }
+    { $subsection bytes>xml }
     "To read a DTD:"
     { $subsection read-dtd }
     { $subsection file>dtd }

basis/xml/xml.factor

@@ -4,7 +4,7 @@ USING: accessors arrays io io.encodings.binary io.files
 io.streams.string kernel namespaces sequences strings io.encodings.utf8
 xml.data xml.errors xml.elements ascii xml.entities
 xml.writer xml.state xml.autoencoding assocs xml.tokenize
-combinators.short-circuit xml.name splitting ;
+combinators.short-circuit xml.name splitting io.streams.byte-array ;
 IN: xml
 
 <PRIVATE
@@ -184,6 +184,9 @@ PRIVATE>
 : file>xml ( filename -- xml )
     binary <file-reader> read-xml ;
 
+: bytes>xml ( byte-array -- xml )
+    binary <byte-reader> read-xml ;
+
 : read-dtd ( stream -- dtd )
     [
         H{ } clone extra-entities set

core/classes/tuple/tuple-docs.factor

@@ -241,7 +241,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
 }
 "An example of using a changer:"
 { $code
-    ": positions"
+    ": positions ( -- seq )"
     "    {"
     "        \"junior programmer\""
     "        \"senior programmer\""

core/kernel/kernel.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel.private slots.private math.private
 classes.tuple.private ;
@@ -51,7 +51,7 @@ DEFER: if
 
 ! Default
 : ?if ( default cond true false -- )
-    pick [ roll 2drop call ] [ 2nip call ] if ; inline
+    pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
 
 ! Slippers and dippers.
 ! Not declared inline because the compiler special-cases them
@@ -138,6 +138,69 @@ DEFER: if
 : 2tri@ ( u v w y x z quot -- )
     dup dup 2tri* ; inline
 
+! Quotation building
+: 2curry ( obj1 obj2 quot -- curry )
+    curry curry ; inline
+
+: 3curry ( obj1 obj2 obj3 quot -- curry )
+    curry curry curry ; inline
+
+: with ( param obj quot -- obj curry )
+    swapd [ swapd call ] 2curry ; inline
+
+: prepose ( quot1 quot2 -- compose )
+    swap compose ; inline
+
+! Curried cleavers
+<PRIVATE
+
+: [curry] ( quot -- quot' ) [ curry ] curry ; inline
+
+PRIVATE>
+
+: bi-curry ( x p q -- p' q' ) [ [curry] ] bi@ bi ; inline
+
+: tri-curry ( x p q r -- p' q' r' ) [ [curry] ] tri@ tri ; inline
+
+: bi-curry* ( x y p q -- p' q' ) [ [curry] ] bi@ bi* ; inline
+
+: tri-curry* ( x y z p q r -- p' q' r' ) [ [curry] ] tri@ tri* ; inline
+
+: bi-curry@ ( x y q -- p' q' ) [curry] bi@ ; inline
+
+: tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline
+
+! Booleans
+: not ( obj -- ? ) [ f ] [ t ] if ; inline
+
+: and ( obj1 obj2 -- ? ) over ? ; inline
+
+: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
+
+: or ( obj1 obj2 -- ? ) dupd ? ; inline
+
+: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline
+
+: both? ( x y quot -- ? ) bi@ and ; inline
+
+: either? ( x y quot -- ? ) bi@ or ; inline
+
+: most ( x y quot -- z )
+    [ 2dup ] dip call [ drop ] [ nip ] if ; inline
+
+! Loops
+: loop ( pred: ( -- ? ) -- )
+    [ call ] keep [ loop ] curry when ; inline recursive
+
+: do ( pred body tail -- pred body tail )
+    over 3dip ; inline
+
+: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
+    [ pick 3dip [ do while ] 3curry ] keep if ; inline recursive
+
+: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
+    [ [ not ] compose ] 2dip while ; inline
+
 ! Object protocol
 GENERIC: hashcode* ( depth obj -- code )
 
@@ -171,50 +234,6 @@ GENERIC: new ( class -- tuple )
 
 GENERIC: boa ( ... class -- tuple )
 
-! Quotation building
-: 2curry ( obj1 obj2 quot -- curry )
-    curry curry ; inline
-
-: 3curry ( obj1 obj2 obj3 quot -- curry )
-    curry curry curry ; inline
-
-: with ( param obj quot -- obj curry )
-    swapd [ swapd call ] 2curry ; inline
-
-: prepose ( quot1 quot2 -- compose )
-    swap compose ; inline
-
-! Booleans
-: not ( obj -- ? ) [ f ] [ t ] if ; inline
-
-: and ( obj1 obj2 -- ? ) over ? ; inline
-
-: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
-
-: or ( obj1 obj2 -- ? ) dupd ? ; inline
-
-: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline
-
-: both? ( x y quot -- ? ) bi@ and ; inline
-
-: either? ( x y quot -- ? ) bi@ or ; inline
-
-: most ( x y quot -- z )
-    [ 2dup ] dip call [ drop ] [ nip ] if ; inline
-
-! Loops
-: loop ( pred: ( -- ? ) -- )
-    dup slip swap [ loop ] [ drop ] if ; inline recursive
-
-: do ( pred body tail -- pred body tail )
-    over 3dip ; inline
-
-: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
-    [ pick 3dip [ do while ] 3curry ] keep if ; inline recursive
-
-: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
-    [ [ not ] compose ] 2dip while ; inline
-
 ! Error handling -- defined early so that other files can
 ! throw errors before continuations are loaded
 : throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;

extra/images/viewer/viewer.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors images images.backend io.pathnames kernel
+USING: accessors images images.loader io.pathnames kernel
 namespaces opengl opengl.gl sequences strings ui ui.gadgets
 ui.gadgets.panes ui.render ;
 IN: images.viewer
@@ -23,15 +23,15 @@ M: image-gadget draw-gadget* ( gadget -- )
         swap >>image ;
 
 : image-window ( path -- gadget )
-    [ <image> <image-gadget> dup ] [ open-window ] bi ;
+    [ load-image <image-gadget> dup ] [ open-window ] bi ;
 
 GENERIC: image. ( object -- )
 
 : default-image. ( path -- )
     <image-gadget> gadget. ;
 
-M: string image. ( image -- ) <image> default-image. ;
+M: string image. ( image -- ) load-image default-image. ;
 
-M: pathname image. ( image -- ) <image> default-image. ;
+M: pathname image. ( image -- ) load-image default-image. ;
 
 M: image image. ( image -- ) default-image. ;

extra/system-info/linux/linux.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: unix alien alien.c-types kernel math sequences strings
-io.backend.unix splitting ;
+io.backend.unix splitting io.encodings.utf8 io.encodings.string ;
 IN: system-info.linux
 
 : (uname) ( buf -- int )
@@ -9,7 +9,7 @@ IN: system-info.linux
 
 : uname ( -- seq )
     65536 "char" <c-array> [ (uname) io-error ] keep
-    "\0" split harvest [ >string ] map
+    "\0" split harvest [ utf8 decode ] map
     6 "" pad-tail ;
 
 : sysname ( -- string ) uname first ;

extra/tar/tar.factor

@@ -5,8 +5,8 @@ system tools.hexdump io.encodings.binary summary accessors
 io.backend byte-arrays ;
 IN: tar
 
-: zero-checksum 256 ; inline
+CONSTANT: zero-checksum 256
-: block-size 512 ; inline
+CONSTANT: block-size 512
 
 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
 linkname magic version uname gname devmajor devminor prefix ;
@@ -89,8 +89,7 @@ M: unknown-typeflag summary ( obj -- str )
 
 ! Symlink
 : typeflag-2 ( header -- )
-    [ name>> ] [ linkname>> ] bi
+    [ name>> ] [ linkname>> ] bi make-link ;
-    [ make-link ] 2curry ignore-errors ;
 
 ! character special
 : typeflag-3 ( header -- ) unknown-typeflag ;

extra/twitter/twitter.factor

@@ -0,0 +1,100 @@
+USING: accessors assocs combinators hashtables http
+http.client json.reader kernel macros namespaces sequences
+urls.secure urls.encoding ;
+IN: twitter
+
+SYMBOLS: twitter-username twitter-password twitter-source ;
+
+twitter-source [ "factor" ] initialize
+
+TUPLE: twitter-status
+    created-at
+    id
+    text
+    source
+    truncated?
+    in-reply-to-status-id
+    in-reply-to-user-id
+    favorited?
+    user ;
+TUPLE: twitter-user
+    id
+    name
+    screen-name
+    description
+    location
+    profile-image-url 
+    url
+    protected?
+    followers-count ;
+
+MACRO: keys-boa ( keys class -- )
+    [ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ;
+
+: <twitter-user> ( assoc -- user )
+    {
+        "id"
+        "name"
+        "screen_name"
+        "description"
+        "location"
+        "profile_image_url"
+        "url"
+        "protected"
+        "followers_count"
+    } twitter-user keys-boa ;
+
+: <twitter-status> ( assoc -- tweet )
+    clone "user" over [ <twitter-user> ] change-at 
+    {
+        "created_at"
+        "id"
+        "text"
+        "source"
+        "truncated"
+        "in_reply_to_status_id"
+        "in_reply_to_user_id"
+        "favorited"
+        "user"
+    } twitter-status keys-boa ;
+
+: json>twitter-statuses ( json-array -- tweets )
+    json> [ <twitter-status> ] map ;
+
+: json>twitter-status ( json-object -- tweet )
+    json> <twitter-status> ;
+
+: set-twitter-credentials ( username password -- )
+    [ twitter-username set ] [ twitter-password set ] bi* ; 
+
+: set-request-twitter-auth ( request -- request )
+    twitter-username twitter-password [ get ] bi@ set-basic-auth ;
+
+: update-post-data ( update -- assoc )
+    "status" associate
+    [ twitter-source get "source" ] dip [ set-at ] keep ;
+
+: (tweet) ( string -- json )
+    update-post-data "https://twitter.com/statuses/update.json" <post-request>
+        set-request-twitter-auth 
+    http-request nip ;
+
+: tweet* ( string -- tweet )
+    (tweet) json>twitter-status ;
+
+: tweet ( string -- ) (tweet) drop ;
+
+: public-timeline ( -- tweets )
+    "https://twitter.com/statuses/public_timeline.json" <get-request>
+        set-request-twitter-auth
+    http-request nip json>twitter-statuses ;
+
+: friends-timeline ( -- tweets )
+    "https://twitter.com/statuses/friends_timeline.json" <get-request>
+        set-request-twitter-auth
+    http-request nip json>twitter-statuses ;
+
+: user-timeline ( username -- tweets )
+    "https://twitter.com/statuses/user_timeline/" ".json" surround <get-request>
+        set-request-twitter-auth
+    http-request nip json>twitter-statuses ;

extra/ui/render/test/test.factor

@@ -4,7 +4,7 @@ USING: accessors colors arrays kernel sequences math byte-arrays
 namespaces grouping fry cap images.bitmap
 ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids
 ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons
-ui.render ui opengl opengl.gl images ;
+ui.render ui opengl opengl.gl images images.loader ;
 IN: ui.render.test
 
 SINGLETON: line-test
@@ -38,7 +38,7 @@ SYMBOL: render-output
     screenshot
     [ render-output set-global ]
     [
-        "resource:extra/ui/render/test/reference.bmp" <image>
+        "resource:extra/ui/render/test/reference.bmp" load-image
         bitmap= "is perfect" "needs work" ?
         "Your UI rendering " prepend
         message-window