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

basis/bitstreams/bitstreams.factor

@@ -158,3 +158,9 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
         writer bytes>> swap push
     ] unless
     writer bytes>> ;
+
+:: byte-array-n>seq ( byte-array n -- seq )
+    byte-array length 8 * n / iota
+    byte-array <msb0-bit-reader> '[
+        drop n _ read
+    ] { } map-as ;

basis/compression/run-length/run-length.factor

@@ -3,5 +3,5 @@
 USING: arrays grouping sequences ;
 IN: compression.run-length
 
-: run-length-uncompress8 ( byte-array -- byte-array' )
+: run-length-uncompress ( byte-array -- byte-array' )
     2 group [ first2 <array> ] map concat ;

basis/constructors/constructors-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit ;
+combinators.short-circuit initializers math ;
 IN: constructors.tests
 
 TUPLE: stock-spread stock spread timestamp ;
@@ -19,3 +19,41 @@ SYMBOL: AAPL
         [ timestamp>> timestamp? ]
     } 1&&
 ] unit-test
+
+TUPLE: ct1 a ;
+TUPLE: ct2 < ct1 b ;
+TUPLE: ct3 < ct2 c ;
+TUPLE: ct4 < ct3 d ;
+
+CONSTRUCTOR: ct1 ( a -- obj )
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct2 ( a b -- obj )
+    initialize-ct1
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct3 ( a b c -- obj )
+    initialize-ct1
+    [ 1 + ] change-a ;
+
+CONSTRUCTOR: ct4 ( a b c d -- obj )
+    initialize-ct3
+    [ 1 + ] change-a ;
+
+[ 1001 ] [ 1000 <ct1> a>> ] unit-test
+[ 2 ] [ 0 0 <ct2> a>> ] unit-test
+[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
+[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
+
+
+TUPLE: rofl a b c ;
+CONSTRUCTOR: rofl ( b c a  -- obj ) ;
+
+[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
+
+
+TUPLE: default { a integer initial: 0 } ;
+
+CONSTRUCTOR: default ( -- obj ) ;
+
+[ 0 ] [ <default> a>> ] unit-test

basis/constructors/constructors.factor

@@ -1,23 +1,54 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: slots kernel sequences fry accessors parser lexer words
+USING: accessors assocs classes.tuple effects.parser fry
-effects.parser macros ;
+generalizations generic.standard kernel lexer locals macros
+parser sequences slots vocabs words ;
 IN: constructors
 
 ! An experiment
 
-MACRO: set-slots ( slots -- quot )
+: initializer-name ( class -- word )
-    <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
+    name>> "initialize-" prepend ;
 
-: construct ( ... class slots -- instance )
+: lookup-initializer ( class -- word/f )
-    [ new ] dip set-slots ; inline
+    initializer-name "initializers" lookup ;
 
-: define-constructor ( name class effect body -- )
+: initializer-word ( class -- word )
-    [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
+    initializer-name
-    define-declared ;
+    "initializers" create-vocab create
+    [ t "initializer" set-word-prop ] [ ] bi ;
+
+: define-initializer-generic ( name -- )
+    initializer-word (( object -- object )) define-simple-generic ;
+
+: define-initializer ( class def -- )
+    [ drop define-initializer-generic ]
+    [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
+
+MACRO:: slots>constructor ( class slots -- quot )
+    class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
+    slots length
+    params length
+    '[
+        _ narray slots swap zip 
+        params swap assoc-union
+        values _ firstn class boa
+    ] ;
+
+:: define-constructor ( constructor-word class effect def -- )
+    constructor-word
+    class def define-initializer
+    class effect in>> '[ _ _ slots>constructor ]
+    class lookup-initializer
+    '[ @ _ execute( obj -- obj ) ] effect define-declared ;
+
+: scan-constructor ( -- class word )
+    scan-word [ name>> "<" ">" surround create-in ] keep ;
 
 SYNTAX: CONSTRUCTOR:
-    scan-word [ name>> "<" ">" surround create-in ] keep
+    scan-constructor
     complete-effect
     parse-definition
     define-constructor ;
+
+"initializers" create-vocab drop

basis/images/bitmap/bitmap.factor

@@ -2,77 +2,146 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types arrays byte-arrays columns
 combinators compression.run-length endian fry grouping images
-images.loader io io.binary io.encodings.binary io.files kernel
+images.loader io io.binary io.encodings.binary io.files
-locals macros math math.bitwise math.functions namespaces
+io.streams.limited kernel locals macros math math.bitwise
-sequences strings summary ;
+math.functions namespaces sequences specialized-arrays.uint
+specialized-arrays.ushort strings summary io.encodings.8-bit
+io.encodings.string ;
+QUALIFIED-WITH: bitstreams b
 IN: images.bitmap
 
-: assert-sequence= ( a b -- )
-    2dup sequence= [ 2drop ] [ assert ] if ;
-
 : read2 ( -- n ) 2 read le> ;
 : read4 ( -- n ) 4 read le> ;
 : write2 ( n -- ) 2 >le write ;
 : write4 ( n -- ) 4 >le write ;
 
-TUPLE: bitmap-image < image ;
+SINGLETON: bitmap-image
-
+"bmp" bitmap-image register-image-class
-! Used to construct the final bitmap-image
 
 TUPLE: loading-bitmap 
-size reserved offset header-length width
+magic size reserved1 reserved2 offset header-length width
 height planes bit-count compression size-image
-x-pels y-pels color-used color-important color-palette color-index
+x-pels y-pels color-used color-important
-uncompressed-bytes ;
+red-mask green-mask blue-mask alpha-mask
+cs-type end-points
+gamma-red gamma-green gamma-blue
+intent profile-data profile-size reserved3
+color-palette color-index bitfields ;
 
-ERROR: bitmap-magic magic ;
+! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
-
-M: bitmap-magic summary
-    drop "First two bytes of bitmap stream must be 'BM'" ;
 
 <PRIVATE
 
-: 8bit>buffer ( bitmap -- array )
+: os2-color-lookup ( loading-bitmap -- seq )
-    [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ]
+    [ color-index>> >array ]
-    [ color-index>> >array ] bi [ swap nth ] with map concat ;
+    [ color-palette>> 3 <sliced-groups> ] bi
+    '[ _ nth ] map concat ;
+
+: os2v2-color-lookup ( loading-bitmap -- seq )
+    [ color-index>> >array ]
+    [ color-palette>> 3 <sliced-groups> ] bi
+    '[ _ nth ] map concat ;
+
+: v3-color-lookup ( loading-bitmap -- seq )
+    [ color-index>> >array ]
+    [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
+    '[ _ nth ] map concat ;
+
+: color-lookup ( loading-bitmap -- seq )
+    dup header-length>> {
+        { 12 [ os2-color-lookup ] }
+        { 64 [ os2v2-color-lookup ] }
+        { 40 [ v3-color-lookup ] }
+        ! { 108 [ v4-color-lookup ] }
+        ! { 124 [ v5-color-lookup ] }
+    } case ;
 
 ERROR: bmp-not-supported n ;
 
-: reverse-lines ( byte-array width -- byte-array )
+: uncompress-bitfield ( seq masks -- bytes' )
-    <sliced-groups> <reversed> concat ; inline
+    '[
+        _ [
+            [ bitand ] [ bit-count ] [ log2 ] tri - shift
+        ] with map
+    ] { } map-as B{ } concat-as ;
 
-: bitmap>bytes ( loading-bitmap -- array )
+: bitmap>bytes ( loading-bitmap -- byte-array )
     dup bit-count>>
     {
         { 32 [ color-index>> ] }
-        { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
+        { 24 [ color-index>> ] }
-        { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
+        { 16 [
+            [
+                ! byte-array>ushort-array
+                2 group [ le> ] map
+                ! 5 6 5
+                ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
+                ! 5 5 5
+                { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
+            ] change-color-index
+            color-index>>
+        ] }
+        { 8 [ color-lookup ] }
+        { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
+        { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
         [ bmp-not-supported ]
     } case >byte-array ;
 
+: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+    dup bit-count>> {
+        { 16 [ dup color-palette>> 4 group [ le> ] map ] }
+        { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
+    } case reverse >>bitfields ;
+
+ERROR: unsupported-bitfield-widths n ;
+
+M: unsupported-bitfield-widths summary
+    drop "Bitmaps only support bitfield compression in 16/32bit images" ;
+
+: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+    set-bitfield-widths
+    dup bit-count>> {
+        { 16 [
+            dup bitfields>> '[
+                byte-array>ushort-array _ uncompress-bitfield
+            ] change-color-index
+        ] }
+        { 32 [
+            dup bitfields>> '[
+                byte-array>uint-array _ uncompress-bitfield
+            ] change-color-index
+        ] }
+        [ unsupported-bitfield-widths ]
+    } case ;
+
 ERROR: unsupported-bitmap-compression compression ;
 
 : uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
     dup compression>> {
+        { f [ ] }
         { 0 [ ] }
-        { 1 [ [ run-length-uncompress8 ] change-color-index ] }
+        { 1 [ [ run-length-uncompress ] change-color-index ] }
-        { 2 [ "run-length encoding 4" unsupported-bitmap-compression ] }
+        { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] }
-        { 3 [ "bitfields" unsupported-bitmap-compression ] }
+        { 3 [ uncompress-bitfield-widths ] }
         { 4 [ "jpeg" unsupported-bitmap-compression ] }
         { 5 [ "png" unsupported-bitmap-compression ] }
     } case ;
 
+: bitmap-padding ( width -- n )
+    3 * 4 mod 4 swap - 4 mod ; inline
+
 : loading-bitmap>bytes ( loading-bitmap -- byte-array )
-    uncompress-bitmap bitmap>bytes ;
+    uncompress-bitmap
+    bitmap>bytes ;
 
 : parse-file-header ( loading-bitmap -- loading-bitmap )
-    2 read "BM" assert-sequence=
+    2 read latin1 decode >>magic
     read4 >>size
-    read4 >>reserved
+    read2 >>reserved1
+    read2 >>reserved2
     read4 >>offset ;
 
-: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
+: read-v3-header ( loading-bitmap -- loading-bitmap )
-    read4 >>header-length
     read4 >>width
     read4 32 >signed >>height
     read2 >>planes
@@ -84,6 +153,50 @@ ERROR: unsupported-bitmap-compression compression ;
     read4 >>color-used
     read4 >>color-important ;
 
+: read-v4-header ( loading-bitmap -- loading-bitmap )
+    read-v3-header
+    read4 >>red-mask
+    read4 >>green-mask
+    read4 >>blue-mask
+    read4 >>alpha-mask
+    read4 >>cs-type
+    read4 read4 read4 3array >>end-points
+    read4 >>gamma-red
+    read4 >>gamma-green
+    read4 >>gamma-blue ;
+
+: read-v5-header ( loading-bitmap -- loading-bitmap )
+    read-v4-header
+    read4 >>intent
+    read4 >>profile-data
+    read4 >>profile-size
+    read4 >>reserved3 ;
+
+: read-os2-header ( loading-bitmap -- loading-bitmap )
+    read2 >>width
+    read2 16 >signed >>height
+    read2 >>planes
+    read2 >>bit-count ;
+
+: read-os2v2-header ( loading-bitmap -- loading-bitmap )
+    read4 >>width
+    read4 32 >signed >>height
+    read2 >>planes
+    read2 >>bit-count ;
+
+ERROR: unknown-bitmap-header n ;
+
+: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
+    read4 [ >>header-length ] keep
+    {
+        { 12 [ read-os2-header ] }
+        { 64 [ read-os2v2-header ] }
+        { 40 [ read-v3-header ] }
+        { 108 [ read-v4-header ] }
+        { 124 [ read-v5-header ] }
+        [ unknown-bitmap-header ]
+    } case ;
+
 : color-palette-length ( loading-bitmap -- n )
     [ offset>> 14 - ] [ header-length>> ] bi - ;
 
@@ -98,56 +211,54 @@ ERROR: unsupported-bitmap-compression compression ;
 : image-size ( loading-bitmap -- n )
     [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
 
-: bitmap-padding ( width -- n )
-    3 * 4 mod 4 swap - 4 mod ; inline
-
-:: fixup-color-index ( loading-bitmap -- loading-bitmap )
-    loading-bitmap width>> :> width
-    width 3 * :> width*3
-    loading-bitmap width>> bitmap-padding :> padding
-    loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
-    loading-bitmap
-    padding 0 > [
-        [
-            stride <sliced-groups>
-            [ width*3 head-slice ] map concat
-        ] change-color-index
-    ] when ;
-
 : parse-bitmap ( loading-bitmap -- loading-bitmap )
     dup color-palette-length read >>color-palette
-    dup color-index-length read >>color-index
+    dup size-image>> dup 0 > [
-    fixup-color-index ;
+        read >>color-index
+    ] [
+        drop dup color-index-length read >>color-index
+    ] if ;
+
+ERROR: unsupported-bitmap-file magic ;
 
 : load-bitmap ( path -- loading-bitmap )
-    binary [
+    binary stream-throws <limited-file-reader> [
         loading-bitmap new
-        parse-file-header parse-bitmap-header parse-bitmap
+        parse-file-header dup magic>> {
-    ] with-file-reader ;
+            { "BM" [ parse-bitmap-header parse-bitmap ] }
+            ! { "BA" [ parse-os2-bitmap-array ] }
+            ! { "CI" [ parse-os2-color-icon ] }
+            ! { "CP" [ parse-os2-color-pointer ] }
+            ! { "IC" [ parse-os2-icon ] }
+            ! { "PT" [ parse-os2-pointer ] }
+            [ unsupported-bitmap-file ]
+        } case 
+    ] with-input-stream ;
 
 ERROR: unknown-component-order bitmap ;
 
 : bitmap>component-order ( loading-bitmap -- object )
     bit-count>> {
-        { 32 [ BGRA ] }
+        { 32 [ BGR ] }
         { 24 [ BGR ] }
+        { 16 [ BGR ] }
         { 8 [ BGR ] }
+        { 4 [ BGR ] }
+        { 1 [ BGR ] }
         [ unknown-component-order ]
     } case ;
 
-: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
+M: bitmap-image load-image* ( path bitmap-image -- bitmap )
+    drop load-bitmap
+    [ image new ] dip
     {
         [ loading-bitmap>bytes >>bitmap ]
         [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
-        [ height>> 0 < [ t >>upside-down? ] when ]
+        [ height>> 0 < not >>upside-down? ]
+        [ compression>> 3 = [ t >>upside-down? ] when ]
         [ bitmap>component-order >>component-order ]
     } cleave ;
 
-M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
-    swap load-bitmap loading-bitmap>bitmap-image ;
-
-"bmp" bitmap-image register-image-class
-
 PRIVATE>
 
 : bitmap>color-index ( bitmap -- byte-array )
@@ -165,6 +276,9 @@ PRIVATE>
         ] if
     ] bi ;
 
+: reverse-lines ( byte-array width -- byte-array )
+    <sliced-groups> <reversed> concat ; inline
+
 : save-bitmap ( image path -- )
     binary [
         B{ CHAR: B CHAR: M } write

basis/images/images.factor

@@ -34,14 +34,7 @@ TUPLE: image dim component-order upside-down? bitmap ;
 
 : has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
 
-GENERIC: load-image* ( path tuple -- image )
+GENERIC: load-image* ( path class -- image )
-
-: make-image ( bitmap -- image )
-    ! bitmap is a sequence of sequences of pixels which are RGBA
-    <image>
-        over [ first length ] [ length ] bi 2array >>dim
-        RGBA >>component-order
-        swap concat concat B{ } like >>bitmap ;
 
 <PRIVATE
 

basis/images/jpeg/jpeg.factor

@@ -7,11 +7,13 @@ io.streams.byte-array kernel locals math math.bitwise
 math.constants math.functions math.matrices math.order
 math.ranges math.vectors memoize multiline namespaces
 sequences sequences.deep images.loader ;
+QUALIFIED-WITH: bitstreams bs
 IN: images.jpeg
 
-QUALIFIED-WITH: bitstreams bs
+SINGLETON: jpeg-image
+{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
 
-TUPLE: jpeg-image < image
+TUPLE: loading-jpeg < image
     { headers }
     { bitstream }
     { color-info initial: { f f f f } }
@@ -21,7 +23,7 @@ TUPLE: jpeg-image < image
 
 <PRIVATE
 
-CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
+CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
 
 SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
 APP JPG COM TEM RES ;
@@ -63,7 +65,7 @@ TUPLE: jpeg-color-info
 
 CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
 
-: jpeg> ( -- jpeg-image ) jpeg-image get ;
+: jpeg> ( -- jpeg-image ) loading-jpeg get ;
 
 : apply-diff ( dc color -- dc' )
     [ diff>> + dup ] [ (>>diff) ] bi ;
@@ -291,9 +293,9 @@ PRIVATE>
     binary [
         parse-marker { SOI } assert=
         parse-headers
-        contents <jpeg-image>
+        contents <loading-jpeg>
     ] with-file-reader
-    dup jpeg-image [
+    dup loading-jpeg [
         baseline-parse
         baseline-decompress
         jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
@@ -302,5 +304,3 @@ PRIVATE>
 
 M: jpeg-image load-image* ( path jpeg-image -- bitmap )
     drop load-jpeg ;
-
-{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each

basis/images/loader/loader.factor

@@ -7,16 +7,18 @@ IN: images.loader
 ERROR: unknown-image-extension extension ;
 
 <PRIVATE
+
 SYMBOL: types
 types [ H{ } clone ] initialize
 
 : image-class ( path -- class )
     file-extension >lower types get ?at
     [ unknown-image-extension ] unless ;
+
 PRIVATE>
 
 : register-image-class ( extension class -- )
     swap types get set-at ;
 
 : load-image ( path -- image )
-    dup image-class new load-image* ;
+    dup image-class load-image* ;

basis/images/png/png.factor

@@ -7,12 +7,15 @@ checksums checksums.crc32 compression.inflate grouping byte-arrays
 images.loader ;
 IN: images.png
 
-TUPLE: png-image < image chunks
+SINGLETON: png-image
+"png" png-image register-image-class
+
+TUPLE: loading-png < image chunks
 width height bit-depth color-type compression-method
 filter-method interlace-method uncompressed ;
 
-CONSTRUCTOR: png-image ( -- image )
+CONSTRUCTOR: loading-png ( -- image )
-V{ } clone >>chunks ;
+    V{ } clone >>chunks ;
 
 TUPLE: png-chunk length type data ;
 
@@ -104,9 +107,8 @@ ERROR: unimplemented-color-type image ;
     } case ;
 
 : load-png ( path -- image )
-    [ binary <file-reader> ] [ file-info size>> ] bi
+    binary stream-throws <limited-file-reader> [
-    stream-throws <limited-stream> [
+        <loading-png>
-        <png-image>
         read-png-header
         read-png-chunks
         parse-ihdr-chunk
@@ -116,5 +118,3 @@ ERROR: unimplemented-color-type image ;
 
 M: png-image load-image*
     drop load-png ;
-
-"png" png-image register-image-class

basis/images/tiff/tiff.factor

@@ -9,10 +9,10 @@ strings math.vectors specialized-arrays.float locals
 images.loader ;
 IN: images.tiff
 
-TUPLE: tiff-image < image ;
+SINGLETON: tiff-image
 
-TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
+TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
-CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
+CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ;
 
 TUPLE: ifd count ifd-entries next
 processed-tags strips bitmap ;
@@ -410,7 +410,7 @@ ERROR: bad-small-ifd-type n ;
         [ nip unhandled-ifd-entry swap ]
     } case ;
 
-: process-ifds ( parsed-tiff -- parsed-tiff )
+: process-ifds ( loading-tiff -- loading-tiff )
     [
         [
             dup ifd-entries>>
@@ -483,18 +483,6 @@ ERROR: unknown-component-order ifd ;
         [ unknown-component-order ]
     } case ;
 
-: normalize-alpha-data ( seq -- byte-array )
-    B{ } like dup
-    byte-array>float-array
-    4 <sliced-groups>
-    [
-        dup fourth dup 0 = [
-            2drop
-        ] [
-            [ 3 head-slice ] dip '[ _ / ] change-each
-        ] if
-    ] each ;
-
 : handle-alpha-data ( ifd -- ifd )
     dup extra-samples find-tag {
         { extra-samples-associated-alpha-data [ ] }
@@ -508,17 +496,17 @@ ERROR: unknown-component-order ifd ;
         [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
         [ ifd-component-order f ]
         [ bitmap>> ]
-    } cleave tiff-image boa ;
+    } cleave image boa ;
 
 : tiff>image ( image -- image )
     ifds>> [ ifd>image ] map first ;
 
-: with-tiff-endianness ( parsed-tiff quot -- )
+: with-tiff-endianness ( loading-tiff quot -- )
     [ dup endianness>> ] dip with-endianness ; inline
 
-: load-tiff-ifds ( path -- parsed-tiff )
+: load-tiff-ifds ( path -- loading-tiff )
     binary [
-        <parsed-tiff>
+        <loading-tiff>
         read-header [
             dup ifd-offset>> read-ifds
             process-ifds
@@ -550,10 +538,10 @@ ERROR: unknown-component-order ifd ;
         drop "no planar configuration" throw
     ] if ;
 
-: process-tif-ifds ( parsed-tiff -- )
+: process-tif-ifds ( loading-tiff -- )
     ifds>> [ process-ifd ] each ;
 
-: load-tiff ( path -- parsed-tiff )
+: load-tiff ( path -- loading-tiff )
     [ load-tiff-ifds dup ] keep
     binary [
         [ process-tif-ifds ] with-tiff-endianness

basis/io/streams/limited/limited.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math io io.encodings destructors accessors
+USING: accessors byte-vectors combinators destructors fry io
-sequences namespaces byte-vectors fry combinators ;
+io.encodings io.files io.files.info kernel math namespaces
+sequences ;
 IN: io.streams.limited
 
 TUPLE: limited-stream stream count limit mode stack ;
@@ -16,6 +17,12 @@ SINGLETONS: stream-throws stream-eofs ;
         swap >>stream
         0 >>count ;
 
+: <limited-file-reader> ( path encoding mode -- stream' )
+    [
+        [ <file-reader> ]
+        [ drop file-info size>> ] 2bi
+    ] dip <limited-stream> ;
+
 GENERIC# limit 2 ( stream limit mode -- stream' )
 
 M: decoder limit ( stream limit mode -- stream' )

basis/opengl/gl/gl.factor

@@ -1872,7 +1872,7 @@ GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint*
 GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ;
 
 GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
-GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
+GL-FUNCTION: GLint glGetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
 
 CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD
 CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0

basis/ui/gadgets/worlds/worlds.factor

@@ -217,4 +217,3 @@ M: world check-world-pixel-format
 : with-world-pixel-format ( world quot -- )
     [ dup dup world-pixel-format-attributes <pixel-format> ]
     dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline
-

basis/ui/ui.factor

@@ -206,8 +206,11 @@ PRIVATE>
 : open-world-window ( world -- )
     dup pref-dim >>dim dup relayout graft ;
 
+: open-window* ( gadget title/attributes -- window )
+    ?attributes <world> [ open-world-window ] keep ;
+
 : open-window ( gadget title/attributes -- )
-    ?attributes <world> open-world-window ;
+    open-window* drop ;
 
 : set-fullscreen ( gadget ? -- )
     [ find-world ] dip (set-fullscreen) ;

extra/game-loop/game-loop.factor

@@ -1,5 +1,5 @@
-USING: accessors calendar destructors kernel math math.order namespaces
+USING: accessors calendar continuations destructors kernel math
-system threads ;
+math.order namespaces system threads ui ui.gadgets.worlds ;
 IN: game-loop
 
 TUPLE: game-loop
@@ -27,6 +27,16 @@ SYMBOL: game-loop
 
 CONSTANT: MAX-FRAMES-TO-SKIP 5
 
+DEFER: stop-loop
+
+TUPLE: game-loop-error game-loop error ;
+
+: ?ui-error ( error -- )
+    ui-running? [ ui-error ] [ rethrow ] if ;
+
+: game-loop-error ( game-loop error -- )
+    [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
+
 <PRIVATE
 
 : redraw ( loop -- )
@@ -54,7 +64,9 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
     [ drop ] if ;
 
 : run-loop ( loop -- )
-    dup game-loop [ (run-loop) ] with-variable ;
+    dup game-loop
+    [ [ (run-loop) ] [ game-loop-error ] recover ]
+    with-variable ;
 
 : benchmark-millis ( loop -- millis )
     millis swap benchmark-time>> - ;
@@ -91,3 +103,6 @@ PRIVATE>
 M: game-loop dispose
     stop-loop ;
 
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "game-loop.prettyprint" require ] when

extra/game-loop/prettyprint/prettyprint.factor

@@ -0,0 +1,9 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors debugger game-loop io ;
+IN: game-loop.prettyprint
+
+M: game-loop-error error.
+    "An error occurred inside a game loop." print
+    "The game loop has been stopped to prevent runaway errors." print
+    "The error was:" print nl
+    error>> error. ;

extra/images/processing/rotation/rotation-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Kobi Lurie, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors fry images.loader images.normalization
+USING: accessors fry images.loader
 images.processing.rotation kernel literals math sequences
 tools.test images.processing.rotation.private ;
 IN: images.processing.rotation.tests
@@ -24,13 +24,13 @@ IN: images.processing.rotation.tests
 CONSTANT: pasted-image
     $[
         "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
-        load-image normalize-image clone-image
+        load-image clone-image
     ]
 
 CONSTANT: pasted-image90
     $[
         "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
-        load-image normalize-image clone-image
+        load-image clone-image
     ]
 
 CONSTANT: lake-image
@@ -55,7 +55,7 @@ CONSTANT: lake-image
     "vocab:images/processing/rotation/test-bitmaps/small.bmp"
     load-image 90 rotate 
     "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"
-    load-image normalize-image =
+    load-image =
 ] unit-test
     
 [ t ] [

extra/managed-server/chat/chat.factor

@@ -126,7 +126,8 @@ M: chat-server handle-client-disconnect
     ] "" append-outputs-as send-everyone ;
 
 M: chat-server handle-already-logged-in
-    username username-taken-string send-line ;
+    username username-taken-string send-line
+    t client (>>quit?) ;
 
 M: chat-server handle-managed-client*
     readln dup f = [ t client (>>quit?) ] when

extra/managed-server/managed-server.factor

@@ -11,7 +11,7 @@ TUPLE: managed-server < threaded-server clients ;
 
 TUPLE: managed-client
 input-stream output-stream local-address remote-address
-username object quit? ;
+username object quit? logged-in? ;
 
 HOOK: handle-login threaded-server ( -- username )
 HOOK: handle-managed-client* managed-server ( -- )
@@ -62,26 +62,39 @@ PRIVATE>
         local-address get >>local-address
         remote-address get >>remote-address ;
 
-: check-logged-in ( username -- username )
+: maybe-login-client ( -- )
-    dup clients key? [ handle-already-logged-in ] when ;
+    username clients key? [
+        handle-already-logged-in
+    ] [
+        t client (>>logged-in?)
+        client username clients set-at
+    ] if ;
 
-: add-managed-client ( -- )
+: when-logged-in ( quot -- )
-    client username check-logged-in clients set-at ;
+    client logged-in?>> [ call ] [ drop ] if ; inline
 
 : delete-managed-client ( -- )
-    username server clients>> delete-at ;
+    [ username server clients>> delete-at ] when-logged-in ;
 
 : handle-managed-client ( -- )
     handle-login <managed-client> managed-client set
-    add-managed-client handle-client-join
+    maybe-login-client [
-    [ handle-managed-client* client quit?>> not ] loop ;
+        handle-client-join
+        [ handle-managed-client* client quit?>> not ] loop
+    ] when-logged-in ;
+
+: cleanup-client ( -- )
+    [
+        delete-managed-client
+        handle-client-disconnect
+    ] when-logged-in ;
 
 PRIVATE>
 
 M: managed-server handle-client*
     managed-server set
     [ handle-managed-client ]
-    [ delete-managed-client handle-client-disconnect ]
+    [ cleanup-client ]
     [ ] cleanup ;
 
 : new-managed-server ( port name encoding class -- server )

extra/ui/gadgets/worlds/null/null.factor

@@ -0,0 +1,27 @@
+USING: accessors kernel ui ui.backend ui.gadgets
+ui.gadgets.worlds ui.pixel-formats ;
+IN: ui.gadgets.worlds.null
+
+TUPLE: null-world < world ;
+M: null-world begin-world drop ;
+M: null-world end-world drop ;
+M: null-world draw-world* drop ;
+M: null-world resize-world drop ;
+M: null-world pref-dim* drop { 512 512 } ;
+
+: null-window ( title -- world )
+    <world-attributes>
+        swap >>title
+        null-world >>world-class
+        {
+            windowed
+            double-buffered
+            backing-store
+            T{ depth-bits f 24 }
+        } >>pixel-format-attributes
+    f swap open-window* ;
+
+: into-window ( world quot -- world )
+    [ dup handle>> ] dip with-gl-context ; inline
+
+