From 19eb0471bb27673b09a96724045c25f1506eafe4 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 12 Feb 2009 01:31:54 -0600
Subject: [PATCH 01/28] Creating XML component

---
 basis/html/components/components-docs.factor | 6 +++++-
 basis/html/components/components.factor      | 5 +++++
 basis/html/templates/chloe/chloe-docs.factor | 5 +++--
 basis/html/templates/chloe/chloe.factor      | 1 +
 4 files changed, 14 insertions(+), 3 deletions(-)

diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor
index b432cc0cc6..37dbeba6c1 100644
--- a/basis/html/components/components-docs.factor
+++ b/basis/html/components/components-docs.factor
@@ -57,7 +57,10 @@ HELP: hidden
 { $description "Hidden components render as a hidden form field. For example, a page for editing a weblog post might contain a hidden field with the post ID." } ;
 
 HELP: html
-{ $description "HTML components render HTML verbatim, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
+{ $description "HTML components render HTML verbatim from a string, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
+
+HELP: xml
+{ $description "XML components render XML verbatim, from an XML chunk. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
 
 HELP: inspector
 { $description "Inspector components render an arbitrary object by passing it to the " { $link describe } " word." } ;
@@ -90,6 +93,7 @@ $nl
 { $subsection inspector }
 { $subsection comparison }
 { $subsection html }
+{ $subsection xml }
 "Tuple components:"
 { $subsection field }
 { $subsection password }
diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor
index 2b18e28351..9dddb85619 100644
--- a/basis/html/components/components.factor
+++ b/basis/html/components/components.factor
@@ -171,3 +171,8 @@ M: comparison render*
 SINGLETON: html
 
 M: html render* 2drop <unescaped> ;
+
+! XML component
+SINGLETON: xml
+
+M: xml render* 2drop ;
diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor
index 18e6db66f6..fcfd454478 100644
--- a/basis/html/templates/chloe/chloe-docs.factor
+++ b/basis/html/templates/chloe/chloe-docs.factor
@@ -1,8 +1,8 @@
 IN: html.templates.chloe
-USING: help.markup help.syntax html.components html.forms
+USING: xml.data help.markup help.syntax html.components html.forms
 html.templates html.templates.chloe.syntax
 html.templates.chloe.compiler html.templates.chloe.components
-math xml.data strings quotations namespaces ;
+math strings quotations namespaces ;
 
 HELP: <chloe>
 { $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" chloe } }
@@ -70,6 +70,7 @@ ARTICLE: "html.templates.chloe.tags.component" "Component Chloe tags"
     { { $snippet "t:field" }      { $link field } }
     { { $snippet "t:hidden" }     { $link hidden } }
     { { $snippet "t:html" }       { $link html } }
+    { { $snippet "t:xml" }        { $link xml } }
     { { $snippet "t:inspector" }  { $link inspector } }
     { { $snippet "t:label" }      { $link label } }
     { { $snippet "t:link" }       { $link link } }
diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor
index eafa3c3a5d..439b207063 100644
--- a/basis/html/templates/chloe/chloe.factor
+++ b/basis/html/templates/chloe/chloe.factor
@@ -95,6 +95,7 @@ COMPONENT: password
 COMPONENT: choice
 COMPONENT: checkbox
 COMPONENT: code
+COMPONENT: xml
 
 SYMBOL: template-cache
 

From 6215c38676f038d1313fe14d8058a1c9e7fb407c Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 12 Feb 2009 01:32:06 -0600
Subject: [PATCH 02/28] Fixing minor CSV bug

---
 basis/csv/csv-tests.factor | 5 ++---
 basis/csv/csv.factor       | 9 ++++++---
 2 files changed, 8 insertions(+), 6 deletions(-)

diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor
index 50bc3836f5..6ba8e2d5b8 100644
--- a/basis/csv/csv-tests.factor
+++ b/basis/csv/csv-tests.factor
@@ -7,9 +7,6 @@ IN: csv.tests
 : named-unit-test ( name output input -- ) 
   unit-test drop ; inline
 
-! tests nicked from the wikipedia csv article
-! http://en.wikipedia.org/wiki/Comma-separated_values
-
 "Fields are separated by commas"
 [ { { "1997" "Ford" "E350" } } ] 
 [ "1997,Ford,E350" <string-reader> csv ] named-unit-test
@@ -90,3 +87,5 @@ IN: csv.tests
     { { "writing,some,csv,tests" } } dup "csv-test2-"
     unique-file utf8 [ csv>file ] [ file>csv ] 2bi =
 ] unit-test
+
+[ { { "hello" "" "" "" "goodbye" "" } } ] [ "hello,,\"\",,goodbye," <string-reader> csv ] unit-test
diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor
index 152b3dcbba..5902999a76 100755
--- a/basis/csv/csv.factor
+++ b/basis/csv/csv.factor
@@ -46,13 +46,15 @@ DEFER: quoted-field ( -- endchar )
 
 : (row) ( -- sep )
     field , 
-    dup delimiter get = [ drop (row) ] when ;
+    dup delimiter> = [ drop (row) ] when ;
 
 : row ( -- eof? array[string] )
     [ (row) ] { } make ;
 
 : (csv) ( -- )
-    row harvest [ , ] unless-empty [ (csv) ] when ;
+    row
+    dup [ empty? ] all? [ drop ] [ , ] if
+    [ (csv) ] when ;
   
 PRIVATE>
 
@@ -60,7 +62,8 @@ PRIVATE>
     [ row nip ] with-input-stream ;
 
 : csv ( stream -- rows )
-    [ [ (csv) ] { } make ] with-input-stream ;
+    [ [ (csv) ] { } make ] with-input-stream
+    dup peek { "" } = [ but-last ] when ;
 
 : file>csv ( path encoding -- csv )
     <file-reader> csv ;

From eaaf2af7b77233698f41fc1388ec8462ab6e75cc Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 12 Feb 2009 01:39:14 -0600
Subject: [PATCH 03/28] Fixing db.sqlite bug: database schema don't need
 primary keys

---
 basis/db/sqlite/sqlite-tests.factor | 22 ++++++++++++++++++++++
 basis/db/sqlite/sqlite.factor       | 12 +++++++-----
 2 files changed, 29 insertions(+), 5 deletions(-)

diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor
index 6fb1cd19ad..69d5f1dd43 100644
--- a/basis/db/sqlite/sqlite-tests.factor
+++ b/basis/db/sqlite/sqlite-tests.factor
@@ -73,3 +73,25 @@ IN: db.sqlite.tests
         "select * from person" sql-query length
     ] with-db
 ] unit-test
+
+! You don't need a primary key
+USING: accessors arrays sorting ;
+TUPLE: things one two ;
+
+things "THINGS" {
+    { "one" "ONE" INTEGER +not-null+ }
+    { "two" "TWO" INTEGER +not-null+ }
+} define-persistent
+
+[ { { 0 0 } { 0 1 } { 1 0 } { 1 1 } } ] [
+    test.db [
+       things create-table
+        0 0 things boa insert-tuple
+        0 1 things boa insert-tuple
+        1 1 things boa insert-tuple
+        1 0 things boa insert-tuple
+        f f things boa select-tuples
+        [ [ one>> ] [ two>> ] bi 2array ] map natural-sort
+       things drop-table
+    ] with-db
+] unit-test
diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor
index fe3bb64d45..9b05cf9825 100755
--- a/basis/db/sqlite/sqlite.factor
+++ b/basis/db/sqlite/sqlite.factor
@@ -138,11 +138,13 @@ M: sqlite-db-connection create-sql-statement ( class -- statement )
             modifiers 0%
         ] interleave
 
-        ", " 0%
-        find-primary-key
-        "primary key(" 0%
-        [ "," 0% ] [ column-name>> 0% ] interleave
-        "));" 0%
+        find-primary-key [
+            ", " 0%
+            "primary key(" 0%
+            [ "," 0% ] [ column-name>> 0% ] interleave
+            ")" 0%
+        ] unless-empty
+        ");" 0%
     ] query-make ;
 
 M: sqlite-db-connection drop-sql-statement ( class -- statement )

From dd57fe7a2310c58ce10ea8e53916dc0b9d593580 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Feb 2009 02:19:31 -0600
Subject: [PATCH 04/28] editors: better error message if definition does not
 have an associated source file when editing a word-link, go to the word
 itself if the word has no help

---
 basis/editors/editors.factor | 19 +++++++++++++++----
 1 file changed, 15 insertions(+), 4 deletions(-)

diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor
index 53887bd353..d060a3dfe6 100644
--- a/basis/editors/editors.factor
+++ b/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 )
 

From 13af3b48019a91d27d32b30136f96865c7de6cad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Feb 2009 02:19:41 -0600
Subject: [PATCH 05/28] combinators.smart: add map-reduce-outputs

---
 basis/combinators/smart/smart-tests.factor | 4 +++-
 basis/combinators/smart/smart.factor       | 6 ++++++
 2 files changed, 9 insertions(+), 1 deletion(-)

diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor
index 69a3a821e5..1cca697dde 100644
--- a/basis/combinators/smart/smart-tests.factor
+++ b/basis/combinators/smart/smart-tests.factor
@@ -44,4 +44,6 @@ IN: combinators.smart.tests
 
 \ nested-smart-combo-test must-infer
 
-[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
\ No newline at end of file
+[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
+
+[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
\ No newline at end of file
diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor
index e93d84e394..e7bdd75ced 100644
--- a/basis/combinators/smart/smart.factor
+++ b/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 ] ;
 

From 22205159470b9ea159dfb6209bc9609eb83e2a5e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Feb 2009 02:41:37 -0600
Subject: [PATCH 06/28] Re-organize images and images.backend into images and
 images.loader

---
 basis/images/backend/authors.txt              |   1 -
 basis/images/backend/backend.factor           |  51 -----------------
 basis/images/bitmap/bitmap-tests.factor       |   8 +--
 basis/images/bitmap/bitmap.factor             |   4 +-
 basis/images/images.factor                    |  52 +++++++++++++-----
 basis/images/loader/authors.txt               |   1 +
 basis/images/loader/loader.factor             |  21 +++++++
 {extra => basis}/images/test-images/1bit.bmp  | Bin
 .../images/test-images/octagon.tiff           | Bin
 {extra => basis}/images/test-images/rgb.tiff  | Bin
 .../images/test-images/rgb4bit.bmp            | Bin
 .../images/test-images/rgb8bit.bmp            | Bin
 .../images/test-images/thiswayup24.bmp        | Bin
 basis/images/tiff/tiff.factor                 |   8 +--
 extra/images/viewer/viewer.factor             |   2 +-
 15 files changed, 71 insertions(+), 77 deletions(-)
 delete mode 100644 basis/images/backend/authors.txt
 delete mode 100644 basis/images/backend/backend.factor
 create mode 100644 basis/images/loader/authors.txt
 create mode 100644 basis/images/loader/loader.factor
 rename {extra => basis}/images/test-images/1bit.bmp (100%)
 rename {extra => basis}/images/test-images/octagon.tiff (100%)
 rename {extra => basis}/images/test-images/rgb.tiff (100%)
 rename {extra => basis}/images/test-images/rgb4bit.bmp (100%)
 rename {extra => basis}/images/test-images/rgb8bit.bmp (100%)
 rename {extra => basis}/images/test-images/thiswayup24.bmp (100%)

diff --git a/basis/images/backend/authors.txt b/basis/images/backend/authors.txt
deleted file mode 100644
index b4bd0e7b35..0000000000
--- a/basis/images/backend/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
\ No newline at end of file
diff --git a/basis/images/backend/backend.factor b/basis/images/backend/backend.factor
deleted file mode 100644
index 756b98efee..0000000000
--- a/basis/images/backend/backend.factor
+++ /dev/null
@@ -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
diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor
index a7deae3178..102c13c295 100644
--- a/basis/images/bitmap/bitmap-tests.factor
+++ b/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 ]
 [
diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor
index 46f90e33f8..5530fa12b7 100755
--- a/basis/images/bitmap/bitmap.factor
+++ b/basis/images/bitmap/bitmap.factor
@@ -4,7 +4,7 @@ USING: accessors alien alien.c-types arrays byte-arrays columns
 combinators fry grouping io io.binary io.encodings.binary
 io.files kernel libc macros math math.bitwise math.functions
 namespaces opengl opengl.gl prettyprint sequences strings
-summary ui ui.gadgets.panes images.backend ;
+summary ui ui.gadgets.panes images ;
 IN: images.bitmap
 
 TUPLE: bitmap-image < image ;
@@ -102,7 +102,7 @@ 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 ]
diff --git a/basis/images/images.factor b/basis/images/images.factor
index 3df7b5d2d1..9f4d14e7bf 100644
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -1,21 +1,45 @@
 ! 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.backend io.backend
-io.pathnames ;
 IN: images
 
-ERROR: unknown-image-extension extension ;
+SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
 
-: image-class ( path -- class )
-    file-extension >lower {
-        { "bmp" [ bitmap-image ] }
-        { "tiff" [ tiff-image ] }
-        [ unknown-image-extension ]
-    } case ;
+TUPLE: image dim component-order bitmap ;
 
-: load-image ( path -- image )
-    dup image-class new load-image* ;
+GENERIC: load-image* ( path tuple -- image )
 
-: <image> ( path -- image )
-    load-image normalize-image ;
+: normalize-component-order ( image -- image )
+    dup component-order>>
+    {
+        { RGBA [ ] }
+        { 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
diff --git a/basis/images/loader/authors.txt b/basis/images/loader/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/images/loader/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor
new file mode 100644
index 0000000000..7aeba9f24a
--- /dev/null
+++ b/basis/images/loader/loader.factor
@@ -0,0 +1,21 @@
+! 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 ] }
+        { "tiff" [ tiff-image ] }
+        [ unknown-image-extension ]
+    } case ;
+
+: load-image ( path -- image )
+    dup image-class new load-image* ;
+
+: <image> ( path -- image )
+    load-image normalize-image ;
diff --git a/extra/images/test-images/1bit.bmp b/basis/images/test-images/1bit.bmp
similarity index 100%
rename from extra/images/test-images/1bit.bmp
rename to basis/images/test-images/1bit.bmp
diff --git a/extra/images/test-images/octagon.tiff b/basis/images/test-images/octagon.tiff
similarity index 100%
rename from extra/images/test-images/octagon.tiff
rename to basis/images/test-images/octagon.tiff
diff --git a/extra/images/test-images/rgb.tiff b/basis/images/test-images/rgb.tiff
similarity index 100%
rename from extra/images/test-images/rgb.tiff
rename to basis/images/test-images/rgb.tiff
diff --git a/extra/images/test-images/rgb4bit.bmp b/basis/images/test-images/rgb4bit.bmp
similarity index 100%
rename from extra/images/test-images/rgb4bit.bmp
rename to basis/images/test-images/rgb4bit.bmp
diff --git a/extra/images/test-images/rgb8bit.bmp b/basis/images/test-images/rgb8bit.bmp
similarity index 100%
rename from extra/images/test-images/rgb8bit.bmp
rename to basis/images/test-images/rgb8bit.bmp
diff --git a/extra/images/test-images/thiswayup24.bmp b/basis/images/test-images/thiswayup24.bmp
similarity index 100%
rename from extra/images/test-images/thiswayup24.bmp
rename to basis/images/test-images/thiswayup24.bmp
diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor
index dac071b4b4..c81d052a7f 100755
--- a/basis/images/tiff/tiff.factor
+++ b/basis/images/tiff/tiff.factor
@@ -3,7 +3,7 @@
 USING: accessors combinators io io.encodings.binary io.files kernel
 pack endian constructors sequences arrays math.order math.parser
 prettyprint classes io.binary assocs math math.bitwise byte-arrays
-grouping images.backend ;
+grouping images ;
 IN: images.tiff
 
 TUPLE: tiff-image < image ;
@@ -268,14 +268,14 @@ ERROR: unknown-component-order ifd ;
         [ 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 ;
 
-M: parsed-tiff >image ( image -- image )
+: tiff>image ( image -- image )
     ifds>> [ >image ] map first ;
 
 : load-tiff ( path -- parsed-tiff )
@@ -289,4 +289,4 @@ M: parsed-tiff >image ( image -- image )
 
 ! 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 ;
diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor
index 92277dfdef..0795900150 100644
--- a/extra/images/viewer/viewer.factor
+++ b/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

From 7361bb90fa79283b6eea5b373e7b385382cc41e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Feb 2009 02:41:47 -0600
Subject: [PATCH 07/28] images: fix load errors

---
 basis/images/images.factor    | 1 +
 basis/images/tiff/tiff.factor | 2 +-
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/basis/images/images.factor b/basis/images/images.factor
index 9f4d14e7bf..5fdc9ee5e9 100644
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -1,5 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors grouping sequences combinators ;
 IN: images
 
 SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor
index c81d052a7f..dd4319a474 100755
--- a/basis/images/tiff/tiff.factor
+++ b/basis/images/tiff/tiff.factor
@@ -276,7 +276,7 @@ ERROR: unknown-component-order ifd ;
     } cleave tiff-image new-image ;
 
 : tiff>image ( image -- image )
-    ifds>> [ >image ] map first ;
+    ifds>> [ ifd>image ] map first ;
 
 : load-tiff ( path -- parsed-tiff )
     binary [

From 421631eebbe226c01f2cc8c3aecf5309cd1f55f3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Feb 2009 04:16:08 -0600
Subject: [PATCH 08/28] bootstrap.image: update documentation (found by
 mnestic)

---
 basis/bootstrap/image/image-docs.factor | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/basis/bootstrap/image/image-docs.factor b/basis/bootstrap/image/image-docs.factor
index 3856382ffb..835c39c171 100644
--- a/basis/bootstrap/image/image-docs.factor
+++ b/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" } "." } ;

From a550c9874c2ffc9c1f43e59c989f2c1951f43d63 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Feb 2009 04:23:35 -0600
Subject: [PATCH 09/28] kernel: add {bi,tri}-curry{,*,@} combinators from
 new_ui branch

---
 core/kernel/kernel.factor | 111 ++++++++++++++++++++++----------------
 1 file changed, 65 insertions(+), 46 deletions(-)

diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index be1de76650..06fe289281 100644
--- a/core/kernel/kernel.factor
+++ b/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) ;

From cf9e7d1e75e748319123f5addaabc90f4594e50c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Feb 2009 04:25:33 -0600
Subject: [PATCH 10/28] Add byte-order slot to image tuple; rename <image> to
 load-image, add <image> for making images from scratch

---
 basis/images/bitmap/bitmap.factor | 10 +++++-----
 basis/images/images.factor        | 10 +++-------
 basis/images/loader/loader.factor |  5 +----
 basis/images/tiff/tiff.factor     |  3 ++-
 extra/images/viewer/viewer.factor |  6 +++---
 5 files changed, 14 insertions(+), 20 deletions(-)

diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor
index 5530fa12b7..c9bb15192b 100755
--- a/basis/images/bitmap/bitmap.factor
+++ b/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
-io.files kernel libc macros math math.bitwise math.functions
-namespaces opengl opengl.gl prettyprint sequences strings
-summary ui ui.gadgets.panes images ;
+combinators fry grouping io io.binary io.encodings.binary io.files
+kernel macros math math.bitwise math.functions namespaces sequences
+strings images endian summary ;
 IN: images.bitmap
 
 TUPLE: bitmap-image < image ;
@@ -106,8 +105,9 @@ ERROR: unknown-component-order bitmap ;
     {
         [ [ width>> ] [ height>> ] bi 2array ]
         [ bitmap>component-order ]
+        [ drop little-endian ] ! XXX
         [ buffer>> ]
-    } cleave bitmap-image new-image ;
+    } cleave bitmap-image boa ;
 
 M: bitmap-image load-image* ( path bitmap -- bitmap-image )
     drop load-bitmap >image ;
diff --git a/basis/images/images.factor b/basis/images/images.factor
index 5fdc9ee5e9..a2d90cc131 100644
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -5,7 +5,9 @@ IN: images
 
 SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
 
-TUPLE: image dim component-order bitmap ;
+TUPLE: image dim component-order byte-order bitmap ;
+
+: <image> ( -- image ) image new ; inline
 
 GENERIC: load-image* ( path tuple -- image )
 
@@ -38,9 +40,3 @@ 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
diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor
index 7aeba9f24a..9e3f901269 100644
--- a/basis/images/loader/loader.factor
+++ b/basis/images/loader/loader.factor
@@ -15,7 +15,4 @@ ERROR: unknown-image-extension extension ;
     } case ;
 
 : load-image ( path -- image )
-    dup image-class new load-image* ;
-
-: <image> ( path -- image )
-    load-image normalize-image ;
+    dup image-class new load-image* normalize-image ;
diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor
index dd4319a474..b4daf675f1 100755
--- a/basis/images/tiff/tiff.factor
+++ b/basis/images/tiff/tiff.factor
@@ -272,8 +272,9 @@ ERROR: unknown-component-order ifd ;
     {
         [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
         [ ifd-component-order ]
+        [ drop big-endian ] ! XXX
         [ bitmap>> ]
-    } cleave tiff-image new-image ;
+    } cleave tiff-image boa ;
 
 : tiff>image ( image -- image )
     ifds>> [ ifd>image ] map first ;
diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor
index 0795900150..06e4c686f3 100644
--- a/extra/images/viewer/viewer.factor
+++ b/extra/images/viewer/viewer.factor
@@ -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. ;

From facd455e9229d54a916781b1de30549913d61459 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@lisp.internal.stack-effects.com>
Date: Thu, 12 Feb 2009 06:25:07 -0600
Subject: [PATCH 11/28] Working on complex float support in FFI on NetBSD

---
 basis/alien/structs/structs.factor         | 5 +++--
 basis/compiler/alien/alien.factor          | 2 +-
 basis/cpu/architecture/architecture.factor | 2 +-
 basis/cpu/ppc/ppc.factor                   | 2 +-
 basis/cpu/x86/32/32.factor                 | 9 ++++++---
 basis/cpu/x86/64/unix/unix.factor          | 2 +-
 basis/cpu/x86/64/winnt/winnt.factor        | 3 ++-
 7 files changed, 15 insertions(+), 10 deletions(-)

diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index 8ec694198d..9c28b71cc6 100755
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -13,7 +13,8 @@ fields
 { boxer-quot callable }
 { unboxer-quot callable }
 { getter callable }
-{ setter callable } ;
+{ setter callable }
+return-in-registers ;
 
 M: struct-type heap-size size>> ;
 
@@ -37,7 +38,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 ;
diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor
index 4a41014ab2..59901cf79a 100644
--- a/basis/compiler/alien/alien.factor
+++ b/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>>
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 5670110f04..2c9675426b 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/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 -- ? )
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index b177c71d77..f245bcb7e1 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/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 ;
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index affd39ffc5..c409cfb164 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/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 -- ? )
-    heap-size { 1 2 4 8 } member?
-    os { linux netbsd solaris } member? not and ;
+M: x86.32 return-struct-in-registers? ( c-type -- ? )
+    c-type
+    [ return-in-registers?>> ]
+    [ heap-size { 1 2 4 8 } member? ] bi
+    os { linux netbsd solaris } member? not
+    and and ;
 
 : struct-return@ ( n -- operand )
     [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor
index f5fb5b9640..eea960d03d 100644
--- a/basis/cpu/x86/64/unix/unix.factor
+++ b/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 ;
diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor
index 4c6af6c1e7..8091be65ae 100644
--- a/basis/cpu/x86/64/winnt/winnt.factor
+++ b/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? ;
 

From 3c1ddde1f903f9feab002865bd6817677dbc9d23 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@lisp.internal.stack-effects.com>
Date: Thu, 12 Feb 2009 08:10:21 -0600
Subject: [PATCH 12/28] Fix complex float support on NetBSD

---
 basis/alien/complex/complex.factor | 11 +++++++++--
 basis/alien/structs/structs.factor |  4 +++-
 basis/cpu/x86/32/32.factor         |  2 +-
 3 files changed, 13 insertions(+), 4 deletions(-)

diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor
index 60a84b9394..079ad57aa5 100644
--- a/basis/alien/complex/complex.factor
+++ b/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.complex.functor accessors
+sequences kernel ;
 IN: alien.complex
 
-<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >>
\ No newline at end of file
+<<
+{ "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
+ >>
diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index 9c28b71cc6..3e26e4fb39 100755
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -14,7 +14,9 @@ fields
 { unboxer-quot callable }
 { getter callable }
 { setter callable }
-return-in-registers ;
+return-in-registers? ;
+
+M: struct-type c-type ;
 
 M: struct-type heap-size size>> ;
 
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index c409cfb164..f881792ac6 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -53,7 +53,7 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
     [ return-in-registers?>> ]
     [ heap-size { 1 2 4 8 } member? ] bi
     os { linux netbsd solaris } member? not
-    and and ;
+    and or ;
 
 : struct-return@ ( n -- operand )
     [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;

From 76ae3fd22448f7166e19f7f594f24794bed0c8ae Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 08:39:52 -0600
Subject: [PATCH 13/28] Fix compile error in ui.render.test; images API
 changed...

---
 extra/ui/render/test/test.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor
index dcbc5b9600..bd3c082652 100755
--- a/extra/ui/render/test/test.factor
+++ b/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

From 2c88d339d0c70fa965350a4d015d600fc0f5acff Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Feb 2009 09:20:32 -0600
Subject: [PATCH 14/28] Improve type inference for struct returns

---
 basis/alien/structs/structs.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index 8ec694198d..234ad64a34 100755
--- a/basis/alien/structs/structs.factor
+++ b/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
@@ -17,7 +17,7 @@ fields
 
 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>> ;
 

From 489bb32a9848baf04c336c03c08a16c0c445847e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 12 Feb 2009 09:48:50 -0600
Subject: [PATCH 15/28] Fix potential load order issue with alien.complex; it
 used a slot defined in alien.structs but didn't reference that file by name

---
 basis/alien/complex/complex.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor
index 079ad57aa5..c80ead73f0 100644
--- a/basis/alien/complex/complex.factor
+++ b/basis/alien/complex/complex.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.complex.functor accessors
+USING: alien.c-types alien.structs alien.complex.functor accessors
 sequences kernel ;
 IN: alien.complex
 

From d46764d34612c2232edd78a424d74080171bb7bc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 16:36:29 -0600
Subject: [PATCH 16/28] use CONSTANT: in db

---
 basis/db/postgresql/ffi/ffi.factor | 98 +++++++++++++++---------------
 basis/db/sqlite/ffi/ffi.factor     | 96 ++++++++++++++---------------
 2 files changed, 97 insertions(+), 97 deletions(-)

diff --git a/basis/db/postgresql/ffi/ffi.factor b/basis/db/postgresql/ffi/ffi.factor
index 4358d7f3de..fc407b06bd 100644
--- a/basis/db/postgresql/ffi/ffi.factor
+++ b/basis/db/postgresql/ffi/ffi.factor
@@ -11,46 +11,46 @@ IN: db.postgresql.ffi
 } cond "cdecl" add-library >>
 
 ! ConnSatusType
-: CONNECTION_OK                     HEX: 0 ; inline
-: CONNECTION_BAD                    HEX: 1 ; inline
-: CONNECTION_STARTED                HEX: 2 ; inline
-: CONNECTION_MADE                   HEX: 3 ; inline
-: CONNECTION_AWAITING_RESPONSE      HEX: 4 ; inline
-: CONNECTION_AUTH_OK                HEX: 5 ; inline
-: CONNECTION_SETENV                 HEX: 6 ; inline
-: CONNECTION_SSL_STARTUP            HEX: 7 ; inline
-: CONNECTION_NEEDED                 HEX: 8 ; inline
+CONSTANT: CONNECTION_OK                     HEX: 0
+CONSTANT: CONNECTION_BAD                    HEX: 1
+CONSTANT: CONNECTION_STARTED                HEX: 2
+CONSTANT: CONNECTION_MADE                   HEX: 3
+CONSTANT: CONNECTION_AWAITING_RESPONSE      HEX: 4
+CONSTANT: CONNECTION_AUTH_OK                HEX: 5
+CONSTANT: CONNECTION_SETENV                 HEX: 6
+CONSTANT: CONNECTION_SSL_STARTUP            HEX: 7
+CONSTANT: CONNECTION_NEEDED                 HEX: 8
 
 ! PostgresPollingStatusType
-: PGRES_POLLING_FAILED              HEX: 0 ; inline
-: PGRES_POLLING_READING             HEX: 1 ; inline
-: PGRES_POLLING_WRITING             HEX: 2 ; inline
-: PGRES_POLLING_OK                  HEX: 3 ; inline
-: PGRES_POLLING_ACTIVE              HEX: 4 ; inline
+CONSTANT: PGRES_POLLING_FAILED              HEX: 0
+CONSTANT: PGRES_POLLING_READING             HEX: 1
+CONSTANT: PGRES_POLLING_WRITING             HEX: 2
+CONSTANT: PGRES_POLLING_OK                  HEX: 3
+CONSTANT: PGRES_POLLING_ACTIVE              HEX: 4
 
 ! ExecStatusType;
-: PGRES_EMPTY_QUERY                 HEX: 0 ; inline
-: PGRES_COMMAND_OK                  HEX: 1 ; inline
-: PGRES_TUPLES_OK                   HEX: 2 ; inline
-: PGRES_COPY_OUT                    HEX: 3 ; inline
-: PGRES_COPY_IN                     HEX: 4 ; inline
-: PGRES_BAD_RESPONSE                HEX: 5 ; inline
-: PGRES_NONFATAL_ERROR              HEX: 6 ; inline
-: PGRES_FATAL_ERROR                 HEX: 7 ; inline
+CONSTANT: PGRES_EMPTY_QUERY                 HEX: 0
+CONSTANT: PGRES_COMMAND_OK                  HEX: 1
+CONSTANT: PGRES_TUPLES_OK                   HEX: 2
+CONSTANT: PGRES_COPY_OUT                    HEX: 3
+CONSTANT: PGRES_COPY_IN                     HEX: 4
+CONSTANT: PGRES_BAD_RESPONSE                HEX: 5
+CONSTANT: PGRES_NONFATAL_ERROR              HEX: 6
+CONSTANT: PGRES_FATAL_ERROR                 HEX: 7
 
 ! PGTransactionStatusType;
-: PQTRANS_IDLE                      HEX: 0 ; inline
-: PQTRANS_ACTIVE                    HEX: 1 ; inline
-: PQTRANS_INTRANS                   HEX: 2 ; inline
-: PQTRANS_INERROR                   HEX: 3 ; inline
-: PQTRANS_UNKNOWN                   HEX: 4 ; inline
+CONSTANT: PQTRANS_IDLE                      HEX: 0
+CONSTANT: PQTRANS_ACTIVE                    HEX: 1
+CONSTANT: PQTRANS_INTRANS                   HEX: 2
+CONSTANT: PQTRANS_INERROR                   HEX: 3
+CONSTANT: PQTRANS_UNKNOWN                   HEX: 4
 
 ! PGVerbosity;
-: PQERRORS_TERSE                    HEX: 0 ; inline
-: PQERRORS_DEFAULT                  HEX: 1 ; inline
-: PQERRORS_VERBOSE                  HEX: 2 ; inline
+CONSTANT: PQERRORS_TERSE                    HEX: 0
+CONSTANT: PQERRORS_DEFAULT                  HEX: 1
+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
-: BYTEA-OID 17 ; inline
-: CHAR-OID 18 ; inline
-: NAME-OID 19 ; inline
-: INT8-OID 20 ; inline
-: INT2-OID 21 ; inline
-: INT4-OID 23 ; inline
-: TEXT-OID 23 ; inline
-: OID-OID 26 ; inline
-: FLOAT4-OID 700 ; inline
-: FLOAT8-OID 701 ; inline
-: VARCHAR-OID 1043 ; inline
-: DATE-OID 1082 ; inline
-: TIME-OID 1083 ; inline
-: TIMESTAMP-OID 1114 ; inline
-: TIMESTAMPTZ-OID 1184 ; inline
-: INTERVAL-OID 1186 ; inline
-: NUMERIC-OID 1700 ; inline
+CONSTANT: BOOL-OID 16
+CONSTANT: BYTEA-OID 17
+CONSTANT: CHAR-OID 18
+CONSTANT: NAME-OID 19
+CONSTANT: INT8-OID 20
+CONSTANT: INT2-OID 21
+CONSTANT: INT4-OID 23
+CONSTANT: TEXT-OID 23
+CONSTANT: OID-OID 26
+CONSTANT: FLOAT4-OID 700
+CONSTANT: FLOAT8-OID 701
+CONSTANT: VARCHAR-OID 1043
+CONSTANT: DATE-OID 1082
+CONSTANT: TIME-OID 1083
+CONSTANT: TIMESTAMP-OID 1114
+CONSTANT: TIMESTAMPTZ-OID 1184
+CONSTANT: INTERVAL-OID 1186
+CONSTANT: NUMERIC-OID 1700
diff --git a/basis/db/sqlite/ffi/ffi.factor b/basis/db/sqlite/ffi/ffi.factor
index 9f033a1d3c..341995634e 100644
--- a/basis/db/sqlite/ffi/ffi.factor
+++ b/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
-: SQLITE_ERROR        1   ; inline ! SQL error or missing database
-: SQLITE_INTERNAL     2   ; inline ! An internal logic error in SQLite 
-: SQLITE_PERM         3   ; inline ! Access permission denied 
-: SQLITE_ABORT        4   ; inline ! Callback routine requested an abort 
-: SQLITE_BUSY         5   ; inline ! The database file is locked 
-: SQLITE_LOCKED       6   ; inline ! A table in the database is locked 
-: SQLITE_NOMEM        7   ; inline ! A malloc() failed 
-: SQLITE_READONLY     8   ; inline ! Attempt to write a readonly database 
-: SQLITE_INTERRUPT    9   ; inline ! Operation terminated by sqlite_interrupt() 
-: SQLITE_IOERR       10   ; inline ! Some kind of disk I/O error occurred 
-: SQLITE_CORRUPT     11   ; inline ! The database disk image is malformed 
-: SQLITE_NOTFOUND    12   ; inline ! (Internal Only) Table or record not found 
-: SQLITE_FULL        13   ; inline ! Insertion failed because database is full 
-: SQLITE_CANTOPEN    14   ; inline ! Unable to open the database file 
-: SQLITE_PROTOCOL    15   ; inline ! Database lock protocol error 
-: SQLITE_EMPTY       16   ; inline ! (Internal Only) Database table is empty 
-: SQLITE_SCHEMA      17   ; inline ! The database schema changed 
-: SQLITE_TOOBIG      18   ; inline ! Too much data for one row of a table 
-: SQLITE_CONSTRAINT  19   ; inline ! Abort due to contraint violation 
-: SQLITE_MISMATCH    20   ; inline ! Data type mismatch 
-: SQLITE_MISUSE      21   ; inline ! Library used incorrectly 
-: SQLITE_NOLFS       22   ; inline ! Uses OS features not supported on host 
-: SQLITE_AUTH        23   ; inline ! Authorization denied 
-: SQLITE_FORMAT      24   ; inline ! Auxiliary database format error
-: SQLITE_RANGE       25   ; inline ! 2nd parameter to sqlite3_bind out of range
-: SQLITE_NOTADB      26   ; inline ! File opened that is not a database file
+CONSTANT: SQLITE_OK           0 ! Successful result
+CONSTANT: SQLITE_ERROR        1 ! SQL error or missing database
+CONSTANT: SQLITE_INTERNAL     2 ! An internal logic error in SQLite 
+CONSTANT: SQLITE_PERM         3 ! Access permission denied 
+CONSTANT: SQLITE_ABORT        4 ! Callback routine requested an abort 
+CONSTANT: SQLITE_BUSY         5 ! The database file is locked 
+CONSTANT: SQLITE_LOCKED       6 ! A table in the database is locked 
+CONSTANT: SQLITE_NOMEM        7 ! A malloc() failed 
+CONSTANT: SQLITE_READONLY     8 ! Attempt to write a readonly database 
+CONSTANT: SQLITE_INTERRUPT    9 ! Operation terminated by sqlite_interrupt() 
+CONSTANT: SQLITE_IOERR       10 ! Some kind of disk I/O error occurred 
+CONSTANT: SQLITE_CORRUPT     11 ! The database disk image is malformed 
+CONSTANT: SQLITE_NOTFOUND    12 ! (Internal Only) Table or record not found 
+CONSTANT: SQLITE_FULL        13 ! Insertion failed because database is full 
+CONSTANT: SQLITE_CANTOPEN    14 ! Unable to open the database file 
+CONSTANT: SQLITE_PROTOCOL    15 ! Database lock protocol error 
+CONSTANT: SQLITE_EMPTY       16 ! (Internal Only) Database table is empty 
+CONSTANT: SQLITE_SCHEMA      17 ! The database schema changed 
+CONSTANT: SQLITE_TOOBIG      18 ! Too much data for one row of a table 
+CONSTANT: SQLITE_CONSTRAINT  19 ! Abort due to contraint violation 
+CONSTANT: SQLITE_MISMATCH    20 ! Data type mismatch 
+CONSTANT: SQLITE_MISUSE      21 ! Library used incorrectly 
+CONSTANT: SQLITE_NOLFS       22 ! Uses OS features not supported on host 
+CONSTANT: SQLITE_AUTH        23 ! Authorization denied 
+CONSTANT: SQLITE_FORMAT      24 ! Auxiliary database format error
+CONSTANT: SQLITE_RANGE       25 ! 2nd parameter to sqlite3_bind out of range
+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
-: SQLITE_DONE        101  ; inline
+CONSTANT: SQLITE_ROW         100
+CONSTANT: SQLITE_DONE        101
 
 ! Return values from the sqlite3_column_type function
-: SQLITE_INTEGER     1 ; inline
-: SQLITE_FLOAT       2 ; inline
-: SQLITE_TEXT        3 ; inline
-: SQLITE_BLOB        4 ; inline
-: SQLITE_NULL        5 ; inline
+CONSTANT: SQLITE_INTEGER     1
+CONSTANT: SQLITE_FLOAT       2
+CONSTANT: SQLITE_TEXT        3
+CONSTANT: SQLITE_BLOB        4
+CONSTANT: SQLITE_NULL        5
 
 ! Values for the 'destructor' parameter of the 'bind' routines. 
-: SQLITE_STATIC      0  ; inline
-: SQLITE_TRANSIENT   -1 ; inline
+CONSTANT: SQLITE_STATIC      0
+CONSTANT: SQLITE_TRANSIENT   -1
 
-: SQLITE_OPEN_READONLY         HEX: 00000001 ; inline
-: SQLITE_OPEN_READWRITE        HEX: 00000002 ; inline
-: SQLITE_OPEN_CREATE           HEX: 00000004 ; inline
-: SQLITE_OPEN_DELETEONCLOSE    HEX: 00000008 ; inline
-: SQLITE_OPEN_EXCLUSIVE        HEX: 00000010 ; inline
-: SQLITE_OPEN_MAIN_DB          HEX: 00000100 ; inline
-: SQLITE_OPEN_TEMP_DB          HEX: 00000200 ; inline
-: SQLITE_OPEN_TRANSIENT_DB     HEX: 00000400 ; inline
-: SQLITE_OPEN_MAIN_JOURNAL     HEX: 00000800 ; inline
-: SQLITE_OPEN_TEMP_JOURNAL     HEX: 00001000 ; inline
-: SQLITE_OPEN_SUBJOURNAL       HEX: 00002000 ; inline
-: SQLITE_OPEN_MASTER_JOURNAL   HEX: 00004000 ; inline
+CONSTANT: SQLITE_OPEN_READONLY         HEX: 00000001
+CONSTANT: SQLITE_OPEN_READWRITE        HEX: 00000002
+CONSTANT: SQLITE_OPEN_CREATE           HEX: 00000004
+CONSTANT: SQLITE_OPEN_DELETEONCLOSE    HEX: 00000008
+CONSTANT: SQLITE_OPEN_EXCLUSIVE        HEX: 00000010
+CONSTANT: SQLITE_OPEN_MAIN_DB          HEX: 00000100
+CONSTANT: SQLITE_OPEN_TEMP_DB          HEX: 00000200
+CONSTANT: SQLITE_OPEN_TRANSIENT_DB     HEX: 00000400
+CONSTANT: SQLITE_OPEN_MAIN_JOURNAL     HEX: 00000800
+CONSTANT: SQLITE_OPEN_TEMP_JOURNAL     HEX: 00001000
+CONSTANT: SQLITE_OPEN_SUBJOURNAL       HEX: 00002000
+CONSTANT: SQLITE_OPEN_MASTER_JOURNAL   HEX: 00004000
 
 TYPEDEF: void sqlite3
 TYPEDEF: void sqlite3_stmt

From 1f6c50fd9192a2614d88830c5c04eb0d18cab1e3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 16:40:45 -0600
Subject: [PATCH 17/28] use constant in tar, remove ignore-errors

---
 extra/tar/tar.factor | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor
index a4413c07b3..37c022fe43 100755
--- a/extra/tar/tar.factor
+++ b/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
-: block-size 512 ; inline
+CONSTANT: zero-checksum 256
+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
-    [ make-link ] 2curry ignore-errors ;
+    [ name>> ] [ linkname>> ] bi make-link ;
 
 ! character special
 : typeflag-3 ( header -- ) unknown-typeflag ;

From c4f45e3f74687bf705143a39fd0e861ed7d81dba Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 12 Feb 2009 17:13:01 -0600
Subject: [PATCH 18/28] Fixing bug in db (don't use unparse!), adding
 still-failing unit test

---
 basis/db/queries/queries.factor     |  2 +-
 basis/db/sqlite/sqlite-tests.factor | 23 +++++++++++++++++++++++
 basis/db/types/types.factor         |  2 +-
 3 files changed, 25 insertions(+), 2 deletions(-)

diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor
index 495c25ea68..c714f43687 100755
--- a/basis/db/queries/queries.factor
+++ b/basis/db/queries/queries.factor
@@ -48,7 +48,7 @@ M: retryable execute-statement* ( statement type -- )
 
 : query-make ( class quot -- statements )
     #! query, input, outputs, secondary queries
-    over unparse "table" set
+    over db-table "table" set
     [ sql-props ] dip
     [ 0 sql-counter rot with-variable ] curry
     { "" { } { } { } } nmake
diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor
index 69d5f1dd43..657415c048 100644
--- a/basis/db/sqlite/sqlite-tests.factor
+++ b/basis/db/sqlite/sqlite-tests.factor
@@ -95,3 +95,26 @@ 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 ;
+C: <hi> hi
+hi "HELLO"
+{ { "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } } } define-persistent
+
+[ T{ foo { slot 1 } } T{ hi { bye 1 } } ] [
+    test.db [
+        foo create-table
+        hi create-table
+        1 <foo> insert-tuple
+        f <foo> select-tuple
+        1 <hi> insert-tuple
+        f <hi> select-tuple
+        hi drop-table
+        foo drop-table
+    ] with-db
+] unit-test
diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor
index b5a7db987a..51e4b42bdc 100755
--- a/basis/db/types/types.factor
+++ b/basis/db/types/types.factor
@@ -165,7 +165,7 @@ ERROR: no-column column ;
 
 : >reference-string ( string pair -- string )
     first2
-    [ [ unparse " " glue ] [ db-columns ] bi ] dip
+    [ [ db-table " " glue ] [ db-columns ] bi ] dip
     swap [ column-name>> = ] with find nip
     [ no-column ] unless*
     column-name>> "(" ")" surround append ;

From 8993e0536b2d1e3c5fdbdcd67707bb2388c53c81 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 17:29:31 -0600
Subject: [PATCH 19/28] rename db-table to db-table-name, use db-table-name
 instead of class name in creating triggers for sqlite

---
 basis/db/queries/queries.factor |  4 +--
 basis/db/sqlite/sqlite.factor   | 48 ++++++++++++++++-----------------
 basis/db/types/types.factor     |  4 +--
 3 files changed, 28 insertions(+), 28 deletions(-)

diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor
index c714f43687..2730340bfc 100755
--- a/basis/db/queries/queries.factor
+++ b/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 db-table "table" set
+    over db-table-name "table-name" set
     [ sql-props ] dip
     [ 0 sql-counter rot with-variable ] curry
     { "" { } { } { } } nmake
diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor
index 9b05cf9825..d006145ea8 100755
--- a/basis/db/sqlite/sqlite.factor
+++ b/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
-        BEFORE INSERT ON ${table}
+        CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+        BEFORE INSERT ON ${table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
-            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+            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-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
-        BEFORE INSERT ON ${table}
+        CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+        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
-        BEFORE UPDATE ON ${table}
+        CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+        BEFORE UPDATE ON ${table-name}
         FOR EACH ROW BEGIN
-            SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
-            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+            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-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
-        BEFORE UPDATE ON ${table}
+        CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+        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
-        BEFORE DELETE ON ${foreign-table}
+        CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+        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"')
-            WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
+            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-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
-        BEFORE DELETE ON ${foreign-table}
+        CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+        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
         ] }
diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor
index 51e4b42bdc..e39a5977ef 100755
--- a/basis/db/types/types.factor
+++ b/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
-    [ [ db-table " " 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 ;

From 745e011ccc11d25e97937fcb8678f2db0f6fc5f6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 17:44:04 -0600
Subject: [PATCH 20/28] add lzw compression

---
 basis/compression/lzw/authors.txt      |   1 +
 basis/compression/lzw/lzw-tests.factor |  10 ++
 basis/compression/lzw/lzw.factor       | 190 +++++++++++++++++++++++++
 3 files changed, 201 insertions(+)
 create mode 100644 basis/compression/lzw/authors.txt
 create mode 100644 basis/compression/lzw/lzw-tests.factor
 create mode 100644 basis/compression/lzw/lzw.factor

diff --git a/basis/compression/lzw/authors.txt b/basis/compression/lzw/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/compression/lzw/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/compression/lzw/lzw-tests.factor b/basis/compression/lzw/lzw-tests.factor
new file mode 100644
index 0000000000..6cb41b97a0
--- /dev/null
+++ b/basis/compression/lzw/lzw-tests.factor
@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors tools.test compression.lzw ;
+IN: compression.lzw.tests
+
+[ V{ 7 258 8 8 258 6 } ]
+[ B{ 7 7 7 8 8 7 7 6 6 } lzw-compress output>> ] unit-test
+
+[ B{ 7 7 7 8 8 7 7 6 6 } ]
+[ V{ 7 258 8 8 258 6 } lzw-uncompress output>> ] unit-test
diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor
new file mode 100644
index 0000000000..fe24e97007
--- /dev/null
+++ b/basis/compression/lzw/lzw.factor
@@ -0,0 +1,190 @@
+! 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 ] [ reset-lzw-compress drop ] bi ]
+        [ (lzw-compress-chars) ]
+        [ end-of-information lzw-compress-char ]
+        [ ]
+    } 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 ;
+
+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 ;

From 6ffe298189c5c16d0515b696a8d1d6fa0aec57d9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 17:44:15 -0600
Subject: [PATCH 21/28] support lzw uncompression in images.tiff

---
 basis/images/images.factor    |  3 +--
 basis/images/tiff/tiff.factor | 22 ++++++++++++++++++++--
 2 files changed, 21 insertions(+), 4 deletions(-)

diff --git a/basis/images/images.factor b/basis/images/images.factor
index a2d90cc131..46c0936644 100644
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -17,8 +17,7 @@ GENERIC: load-image* ( path tuple -- image )
         { RGBA [ ] }
         { BGRA [
             [
-                [ 4 <sliced-groups> [ [ 0 3 ] dip <slice> reverse-here ] each ]
-                [ RGBA >>component-order ] bi
+                4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
             ] change-bitmap
         ] }
         { RGB [
diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor
index b4daf675f1..0b749d0ade 100755
--- a/basis/images/tiff/tiff.factor
+++ b/basis/images/tiff/tiff.factor
@@ -3,7 +3,7 @@
 USING: accessors combinators io io.encodings.binary io.files kernel
 pack endian constructors sequences arrays math.order math.parser
 prettyprint classes io.binary assocs math math.bitwise byte-arrays
-grouping images ;
+grouping images compression.lzw fry ;
 IN: images.tiff
 
 TUPLE: tiff-image < image ;
@@ -256,6 +256,20 @@ ERROR: bad-small-ifd-type n ;
     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 ;
 
@@ -284,7 +298,11 @@ ERROR: unknown-component-order ifd ;
         <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 drop
+            ] each
         ] with-endianness
     ] with-file-reader ;
 

From 18276a863b81aeca6d6f8fcd6bca29c78f21ac98 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 17:44:43 -0600
Subject: [PATCH 22/28] initial bitstreams checkin

---
 basis/bitstreams/authors.txt             |  1 +
 basis/bitstreams/bitstreams-tests.factor | 31 +++++++++
 basis/bitstreams/bitstreams.factor       | 87 ++++++++++++++++++++++++
 3 files changed, 119 insertions(+)
 create mode 100644 basis/bitstreams/authors.txt
 create mode 100644 basis/bitstreams/bitstreams-tests.factor
 create mode 100644 basis/bitstreams/bitstreams.factor

diff --git a/basis/bitstreams/authors.txt b/basis/bitstreams/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/bitstreams/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor
new file mode 100644
index 0000000000..8fac3f52f9
--- /dev/null
+++ b/basis/bitstreams/bitstreams-tests.factor
@@ -0,0 +1,31 @@
+! 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 ;
+IN: bitstreams.tests
+
+[ 1 ]
+[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
+
+[ 254 ]
+[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+
+[ 4095 ]
+[ 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
+
+
+/*
+[
+    
+] [
+    B{ 7 7 7 8 8 7 7 9 7 }
+    [ byte-array>bignum >bin 72 CHAR: 0 pad-head 9 group [ bin> ] map ]
+    [ lzw-compress ] bi
+] unit-test
+*/
diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor
new file mode 100644
index 0000000000..ae980795bc
--- /dev/null
+++ b/basis/bitstreams/bitstreams.factor
@@ -0,0 +1,87 @@
+! 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 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 0 ? >>#bits ] bi ; inline
+
+: 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 )
+    maybe-read-next-byte [
+        shift-one-bit
+    ] [
+        [ 1- ] change-#bits maybe-read-next-byte drop
+    ] bi ; inline
+
+: read-bit ( bitstream -- n )
+    dup #bits>> 1 = [
+        [ current-bits>> 1 bitand ]
+        [ read-next-byte drop ] bi
+    ] [
+        next-bit
+    ] if ; inline
+
+: bits>integer ( seq -- n )
+    0 [ [ 1 shift ] dip bitor ] reduce ; inline
+
+: read-bits ( width bitstream -- n )
+    '[ _ read-bit ] replicate bits>integer ; inline
+
+
+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 ;

From 81d0f52e32d96b5d699608f9332d8d3010252d95 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 21:43:25 -0600
Subject: [PATCH 23/28] remove bad lzw tests, real tests still to come..

---
 basis/compression/lzw/lzw-tests.factor | 6 ------
 1 file changed, 6 deletions(-)

diff --git a/basis/compression/lzw/lzw-tests.factor b/basis/compression/lzw/lzw-tests.factor
index 6cb41b97a0..698e35d87e 100644
--- a/basis/compression/lzw/lzw-tests.factor
+++ b/basis/compression/lzw/lzw-tests.factor
@@ -2,9 +2,3 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors tools.test compression.lzw ;
 IN: compression.lzw.tests
-
-[ V{ 7 258 8 8 258 6 } ]
-[ B{ 7 7 7 8 8 7 7 6 6 } lzw-compress output>> ] unit-test
-
-[ B{ 7 7 7 8 8 7 7 6 6 } ]
-[ V{ 7 258 8 8 258 6 } lzw-uncompress output>> ] unit-test

From 127ff76c085959ae0e4284016643894d7550d0b7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 21:45:34 -0600
Subject: [PATCH 24/28] add using

---
 basis/bitstreams/bitstreams-tests.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor
index 8fac3f52f9..2aadf7b02d 100644
--- a/basis/bitstreams/bitstreams-tests.factor
+++ b/basis/bitstreams/bitstreams-tests.factor
@@ -1,7 +1,7 @@
 ! 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 ;
+grouping compression.lzw multiline byte-arrays ;
 IN: bitstreams.tests
 
 [ 1 ]
@@ -16,7 +16,7 @@ IN: bitstreams.tests
 [ B{ 254 } ]
 [
     <string-writer> <bitstream-writer> 254 8 rot
-    [ write-bits ] keep stream>> >byte-array
+    [ write-bits ] keep output>> >byte-array
 ] unit-test
 
 

From d09567e31eb83a378d7902a9b70b2a34030379ee Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Thu, 12 Feb 2009 21:59:59 -0600
Subject: [PATCH 25/28] Failing test case for db.sqlite

---
 basis/db/sqlite/sqlite-tests.factor | 19 ++++++++++++++-----
 1 file changed, 14 insertions(+), 5 deletions(-)

diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor
index 657415c048..e05d992014 100644
--- a/basis/db/sqlite/sqlite-tests.factor
+++ b/basis/db/sqlite/sqlite-tests.factor
@@ -101,20 +101,29 @@ TUPLE: foo slot ;
 C: <foo> foo
 foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent
 
-TUPLE: hi bye ;
+TUPLE: hi bye try ;
 C: <hi> hi
-hi "HELLO"
-{ { "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } } } define-persistent
+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 } } ] [
+[ 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 <hi> insert-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

From b5cb425708166bce4c86479c57dee27290131812 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 22:10:32 -0600
Subject: [PATCH 26/28] new bitstream api works, refactor time

---
 basis/bitstreams/bitstreams-tests.factor | 24 +++++++---------
 basis/bitstreams/bitstreams.factor       | 35 +++++++++++++++---------
 2 files changed, 32 insertions(+), 27 deletions(-)

diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor
index 2aadf7b02d..d55910b131 100644
--- a/basis/bitstreams/bitstreams-tests.factor
+++ b/basis/bitstreams/bitstreams-tests.factor
@@ -1,31 +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 ;
+grouping compression.lzw multiline byte-arrays io.encodings.binary
+io.streams.byte-array ;
 IN: bitstreams.tests
 
-[ 1 ]
+[ 1 t ]
 [ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
 
-[ 254 ]
+[ 254 8 t ]
 [ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
 
-[ 4095 ]
+[ 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 output>> >byte-array
+    [ write-bits ] keep stream>> >byte-array
 ] unit-test
 
+[ 255 8 t ]
+[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
 
-/*
-[
-    
-] [
-    B{ 7 7 7 8 8 7 7 9 7 }
-    [ byte-array>bignum >bin 72 CHAR: 0 pad-head 9 group [ bin> ] map ]
-    [ lzw-compress ] bi
-] unit-test
-*/
+[ 255 8 f ]
+[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor
index ae980795bc..7113b650fd 100644
--- a/basis/bitstreams/bitstreams.factor
+++ b/basis/bitstreams/bitstreams.factor
@@ -4,7 +4,7 @@ USING: accessors byte-arrays destructors fry io kernel locals
 math sequences ;
 IN: bitstreams
 
-TUPLE: bitstream stream current-bits #bits disposed ;
+TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
 TUPLE: bitstream-reader < bitstream ;
 
 : reset-bitstream ( stream -- stream )
@@ -22,8 +22,12 @@ M: bitstream-reader dispose ( stream -- )
     bitstream-reader new-bitstream ; inline
 
 : read-next-byte ( bitstream -- bitstream )
-    dup stream>> stream-read1
-    [ >>current-bits ] [ 8 0 ? >>#bits ] bi ; inline
+    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
@@ -31,17 +35,19 @@ M: bitstream-reader dispose ( stream -- )
 : shift-one-bit ( bitstream -- n )
     [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
 
-: next-bit ( bitstream -- n )
-    maybe-read-next-byte [
-        shift-one-bit
+: next-bit ( bitstream -- n/f ? )
+    maybe-read-next-byte
+    dup end-of-stream?>> [
+        drop f
     ] [
-        [ 1- ] change-#bits maybe-read-next-byte drop
-    ] bi ; inline
+        [ shift-one-bit ]
+        [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
+    ] if dup >boolean ;
 
-: read-bit ( bitstream -- n )
+: read-bit ( bitstream -- n ? )
     dup #bits>> 1 = [
         [ current-bits>> 1 bitand ]
-        [ read-next-byte drop ] bi
+        [ read-next-byte drop ] bi t
     ] [
         next-bit
     ] if ; inline
@@ -49,9 +55,12 @@ M: bitstream-reader dispose ( stream -- )
 : bits>integer ( seq -- n )
     0 [ [ 1 shift ] dip bitor ] reduce ; inline
 
-: read-bits ( width bitstream -- n )
-    '[ _ read-bit ] replicate bits>integer ; 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 ;
 

From 12ee26566ea3abe8b039d6c4420c08a2c54e9ed6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 22:11:11 -0600
Subject: [PATCH 27/28] working on lzw compression

---
 basis/compression/lzw/lzw.factor | 20 +++++++++++++++++---
 1 file changed, 17 insertions(+), 3 deletions(-)

diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor
index fe24e97007..67248474d3 100644
--- a/basis/compression/lzw/lzw.factor
+++ b/basis/compression/lzw/lzw.factor
@@ -110,9 +110,23 @@ ERROR: not-in-table ;
 
 : lzw-compress-chars ( lzw -- )
     {
-        [ [ clear-code lzw-compress-char ] [ reset-lzw-compress drop ] bi ]
+        ! [ [ 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) ]
-        [ end-of-information lzw-compress-char ]
+        [
+            [ 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 ;
 
@@ -138,7 +152,7 @@ ERROR: not-in-table ;
 : add-to-table ( seq lzw -- ) table>> push ;
 
 : lzw-read ( lzw -- lzw n )
-    [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits ;
+    [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ;
 
 DEFER: lzw-uncompress-char
 : handle-clear-code ( lzw -- )

From 237f16b4db03d50d03558fa2ad9ec9c9b9ff8169 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 12 Feb 2009 22:13:34 -0600
Subject: [PATCH 28/28] move zlib to zlib.compression and update

---
 basis/compression/zlib/authors.txt       |  1 +
 basis/compression/zlib/ffi/authors.txt   |  1 +
 basis/compression/zlib/ffi/ffi.factor    | 30 +++++++++++++++
 basis/compression/zlib/zlib-tests.factor |  9 +++++
 basis/compression/zlib/zlib.factor       | 48 ++++++++++++++++++++++++
 5 files changed, 89 insertions(+)
 create mode 100755 basis/compression/zlib/authors.txt
 create mode 100755 basis/compression/zlib/ffi/authors.txt
 create mode 100755 basis/compression/zlib/ffi/ffi.factor
 create mode 100755 basis/compression/zlib/zlib-tests.factor
 create mode 100755 basis/compression/zlib/zlib.factor

diff --git a/basis/compression/zlib/authors.txt b/basis/compression/zlib/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/compression/zlib/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/compression/zlib/ffi/authors.txt b/basis/compression/zlib/ffi/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/compression/zlib/ffi/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/compression/zlib/ffi/ffi.factor b/basis/compression/zlib/ffi/ffi.factor
new file mode 100755
index 0000000000..d369c22e4c
--- /dev/null
+++ b/basis/compression/zlib/ffi/ffi.factor
@@ -0,0 +1,30 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.syntax combinators system ;
+IN: compression.zlib.ffi
+
+<< "zlib" {
+    { [ os winnt? ] [ "zlib1.dll" ] }
+    { [ os macosx? ] [ "libz.dylib" ] }
+    { [ os unix? ] [ "libz.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: zlib
+
+CONSTANT: Z_OK 0
+CONSTANT: Z_STREAM_END 1
+CONSTANT: Z_NEED_DICT 2
+CONSTANT: Z_ERRNO -1
+CONSTANT: Z_STREAM_ERROR -2
+CONSTANT: Z_DATA_ERROR -3
+CONSTANT: Z_MEM_ERROR -4
+CONSTANT: Z_BUF_ERROR -5
+CONSTANT: Z_VERSION_ERROR -6
+
+TYPEDEF: void Bytef
+TYPEDEF: ulong uLongf
+TYPEDEF: ulong uLong
+
+FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
+FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ;
+FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
diff --git a/basis/compression/zlib/zlib-tests.factor b/basis/compression/zlib/zlib-tests.factor
new file mode 100755
index 0000000000..1baeba73d9
--- /dev/null
+++ b/basis/compression/zlib/zlib-tests.factor
@@ -0,0 +1,9 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test compression.zlib classes ;
+IN: compression.zlib.tests
+
+: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
+
+[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test
+[ t ] [ compress-me compress compressed instance? ] unit-test
diff --git a/basis/compression/zlib/zlib.factor b/basis/compression/zlib/zlib.factor
new file mode 100755
index 0000000000..7818173498
--- /dev/null
+++ b/basis/compression/zlib/zlib.factor
@@ -0,0 +1,48 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.syntax byte-arrays combinators
+kernel math math.functions sequences system accessors
+libc ;
+QUALIFIED: compression.zlib.ffi
+IN: compression.zlib
+
+TUPLE: compressed data length ;
+
+: <compressed> ( data length -- compressed )
+    compressed new
+        swap >>length
+        swap >>data ;
+
+ERROR: zlib-failed n string ;
+
+: zlib-error-message ( n -- * )
+    dup compression.zlib.ffi:Z_ERRNO = [
+        drop errno "native libc error"
+    ] [
+        dup {
+            "no error" "libc_error"
+            "stream error" "data error"
+            "memory error" "buffer error" "zlib version error"
+        } ?nth
+    ] if zlib-failed ;
+
+: zlib-error ( n -- )
+    dup compression.zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
+
+: compressed-size ( byte-array -- n )
+    length 1001/1000 * ceiling 12 + ;
+
+: compress ( byte-array -- compressed )
+    [
+        [ compressed-size <byte-array> dup length <ulong> ] keep [
+            dup length compression.zlib.ffi:compress zlib-error
+        ] 3keep drop *ulong head
+    ] keep length <compressed> ;
+
+: uncompress ( compressed -- byte-array )
+    [
+        length>> [ <byte-array> ] keep <ulong> 2dup
+    ] [
+        data>> dup length
+        compression.zlib.ffi:uncompress zlib-error
+    ] bi *ulong head ;