Merge remote-tracking branch 'factorcode/master'

basis/alien/enums/enums-tests.factor

@@ -33,3 +33,19 @@ ENUM: instrument_t < ushort trombone trumpet ;
 
 { V{ { red 0 } { green 3 } { blue 4 } } }
 [ color_t "c-type" word-prop members>> ] unit-test
+
+ENUM: colores { rojo red } { verde green } { azul blue } { colorado rojo } ;
+
+[ { 0 3 4 0 } ] [ { rojo verde azul colorado } [ enum>number ] map ] unit-test
+
+SYMBOLS: couleurs rouge vert bleu jaune azure ;
+
+<< \ couleurs int {
+    { rouge red }
+    { vert green }
+    { bleu blue }
+    { jaune 14 }
+    { azure bleu }
+} define-enum >>
+
+[ { 0 3 4 14 4 } ] [ { rouge vert bleu jaune azure } [ enum>number ] map ] unit-test

basis/alien/enums/enums.factor

@@ -30,16 +30,13 @@ M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
 M: enum-c-type c-type-setter
    [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
 
+: define-enum-value ( class value -- )
+    enum>number "enum-value" set-word-prop ;
+
 <PRIVATE
 
-: define-enum-value ( class value -- )
-    "enum-value" set-word-prop ;
-
 : define-enum-members ( members -- )
-    [
+    [ first define-singleton-class ] each ;
-        [ drop define-singleton-class ]
-        [ define-enum-value ] 2bi
-    ] assoc-each ;
 
 : define-enum-constructor ( word -- )
     [ name>> "<" ">" surround create-in ] keep
@@ -47,10 +44,14 @@ M: enum-c-type c-type-setter
 
 PRIVATE>
 
-: define-enum ( word base-type members -- )
+: (define-enum) ( word base-type members -- )
     [ dup define-enum-constructor ] 2dip
     [ define-enum-members ]
     [ <enum-c-type> swap typedef ] bi ;
 
+: define-enum ( word base-type members -- )
+    [ (define-enum) ]
+    [ [ define-enum-value ] assoc-each ] bi ;
+    
 PREDICATE: enum-c-type-word < c-type-word
     "c-type" word-prop enum-c-type? ;

basis/alien/parser/parser.factor

@@ -4,7 +4,7 @@ USING: accessors alien alien.c-types alien.libraries arrays
 assocs classes combinators combinators.short-circuit
 compiler.units effects grouping kernel parser sequences
 splitting words fry locals lexer namespaces summary math
-vocabs.parser words.constant classes.parser ;
+vocabs.parser words.constant classes.parser alien.enums ;
 IN: alien.parser
 
 SYMBOL: current-library
@@ -84,7 +84,8 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
     [ [ <pointer> ] dip parse-pointers ] when ;
 
 : next-enum-member ( members name value -- members value' )
-    [ 2array suffix! ] [ 1 + ] bi ;
+    [ define-enum-value ]
+    [ [ 2array suffix! ] [ enum>number 1 + ] bi ] 2bi ;
 
 : parse-enum-name ( -- name )
     scan (CREATE-C-TYPE) dup save-location ;

basis/alien/syntax/syntax.factor

@@ -29,7 +29,7 @@ SYNTAX: TYPEDEF:
     scan-c-type CREATE-C-TYPE dup save-location typedef ;
 
 SYNTAX: ENUM:
-    parse-enum define-enum ;
+    parse-enum (define-enum) ;
 
 SYNTAX: C-TYPE:
     void CREATE-C-TYPE typedef ;

basis/bit-arrays/bit-arrays-tests.factor

@@ -2,6 +2,8 @@ USING: alien sequences sequences.private arrays bit-arrays kernel
 tools.test math random ;
 IN: bit-arrays.tests
 
+[ -1 <bit-array> ] [ T{ bad-array-length f -1 } = ] must-fail-with
+
 [ 100 ] [ 100 <bit-array> length ] unit-test
 
 [

basis/bit-arrays/bit-arrays.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2010 Slava Pestov.
+! Copyright (C) 2007, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.data accessors io.binary math math.bitwise
 alien.accessors kernel kernel.private sequences
@@ -41,8 +41,12 @@ TUPLE: bit-array
 
 PRIVATE>
 
+ERROR: bad-array-length n ;
+
 : <bit-array> ( n -- bit-array )
-    dup bits>bytes <byte-array> bit-array boa ; inline
+    dup 0 < [ bad-array-length ] when
+    dup bits>bytes <byte-array>
+    bit-array boa ; inline
 
 M: bit-array length length>> ; inline
 

basis/cocoa/cocoa.factor

@@ -43,7 +43,9 @@ SYNTAX: IMPORT: scan [ ] import-objc-class ;
         "NSApplication"
         "NSArray"
         "NSAutoreleasePool"
+        "NSBitmapImageRep"
         "NSBundle"
+        "NSColorSpace"
         "NSData"
         "NSDictionary"
         "NSError"

basis/cocoa/messages/messages.factor

@@ -109,7 +109,7 @@ H{
     { "d" c:double }
     { "B" c:bool }
     { "v" c:void }
-    { "*" c:c-string }
+    { "*" c:void* }
     { "?" unknown_type }
     { "@" id }
     { "#" Class }

basis/gdk/pixbuf/ffi/ffi.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2010 Anton Gorenko.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.libraries alien.syntax combinators
+USING: alien alien.data alien.libraries alien.syntax
-gobject-introspection kernel system vocabs.loader ;
+combinators gio.ffi glib.ffi gmodule.ffi gobject-introspection
+gobject.ffi kernel libc sequences system ;
+EXCLUDE: alien.c-types => pointer ;
 IN: gdk.pixbuf.ffi
 
-<<
 "gio.ffi" require
->>
 
 LIBRARY: gdk.pixbuf
 
@@ -18,3 +18,12 @@ LIBRARY: gdk.pixbuf
 >>
 
 GIR: vocab:gdk/pixbuf/GdkPixbuf-2.0.gir
+
+: data>GInputStream ( data -- GInputStream )
+    [ malloc-byte-array &free ] [ length ] bi
+    f g_memory_input_stream_new_from_data ;
+
+: GInputStream>GdkPixbuf ( GInputStream -- GdkPixbuf )
+    f { { pointer: GError initial: f } }
+    [ gdk_pixbuf_new_from_stream ] with-out-parameters
+    handle-GError ;

basis/glib/ffi/ffi.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2010 Anton Gorenko.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.destructors alien.libraries alien.syntax
+USING: accessors alien alien.c-types alien.destructors
-combinators kernel gobject-introspection
+alien.libraries alien.strings alien.syntax combinators
-gobject-introspection.standard-types system ;
+gobject-introspection gobject-introspection.standard-types
+io.encodings.utf8 kernel system vocabs.parser words ;
 IN: glib.ffi
 
 LIBRARY: glib
@@ -15,7 +16,62 @@ LIBRARY: glib
 } cond
 >>
 
-IMPLEMENT-STRUCTS: GPollFD GSource GSourceFuncs ;
+
+TYPEDEF: char gchar
+TYPEDEF: uchar guchar
+TYPEDEF: short gshort
+TYPEDEF: ushort gushort
+TYPEDEF: long glong
+TYPEDEF: ulong gulong
+TYPEDEF: int gint
+TYPEDEF: uint guint
+
+<<
+int c-type clone
+    [ >c-bool ] >>unboxer-quot
+    [ c-bool> ] >>boxer-quot
+    object >>boxed-class
+"gboolean" current-vocab create typedef
+>>
+
+TYPEDEF: char gint8
+TYPEDEF: uchar guint8
+TYPEDEF: short gint16
+TYPEDEF: ushort guint16
+TYPEDEF: int gint32
+TYPEDEF: uint guint32
+TYPEDEF: longlong gint64
+TYPEDEF: ulonglong guint64
+
+TYPEDEF: float gfloat
+TYPEDEF: double gdouble
+
+TYPEDEF: long ssize_t
+TYPEDEF: long time_t
+TYPEDEF: size_t gsize
+TYPEDEF: ssize_t gssize
+TYPEDEF: size_t GType
+
+TYPEDEF: void* gpointer
+TYPEDEF: void* gconstpointer
+
+TYPEDEF: guint8 GDateDay
+TYPEDEF: guint16 GDateYear
+TYPEDEF: gint GPid
+TYPEDEF: guint32 GQuark
+TYPEDEF: gint32 GTime
+TYPEDEF: glong gintptr
+TYPEDEF: gint64 goffset
+TYPEDEF: gulong guintptr
+TYPEDEF: guint32 gunichar
+TYPEDEF: guint16 gunichar2
+
+TYPEDEF: gpointer pointer
+
+REPLACE-C-TYPE: long\sdouble double
+REPLACE-C-TYPE: any gpointer
+
+IMPLEMENT-STRUCTS: GError GPollFD GSource GSourceFuncs ;
 
 CONSTANT: G_MININT8   HEX: -80
 CONSTANT: G_MAXINT8   HEX:  7f
@@ -38,3 +94,18 @@ DESTRUCTOR: g_free
 CALLBACK: gboolean GSourceFuncsPrepareFunc ( GSource* source, gint* timeout_ ) ;
 CALLBACK: gboolean GSourceFuncsCheckFunc ( GSource* source ) ;
 CALLBACK: gboolean GSourceFuncsDispatchFunc ( GSource* source, GSourceFunc callback, gpointer user_data ) ;
+
+ERROR: g-error domain code message ;
+
+: GError>g-error ( GError -- g-error )
+    [ domain>> g_quark_to_string utf8 alien>string ]
+    [ code>> ]
+    [ message>> utf8 alien>string ] tri
+    \ g-error boa ;
+
+: handle-GError ( GError/f -- )
+    [
+        [ GError>g-error ]
+        [ g_error_free ] bi
+        throw
+    ] when* ;

basis/images/cocoa/authors.txt

@@ -0,0 +1 @@
+Joe Groff

basis/images/cocoa/cocoa.factor

@@ -0,0 +1,66 @@
+! (c)2010 Joe Groff bsd license
+USING: accessors alien.data cocoa cocoa.classes cocoa.messages
+combinators core-foundation.data core-graphics.types fry images
+images.loader io kernel literals math sequences ;
+IN: images.cocoa
+
+SINGLETON: ns-image
+"png" ns-image register-image-class
+"tif" ns-image register-image-class
+"tiff" ns-image register-image-class
+"gif" ns-image register-image-class
+"jpg" ns-image register-image-class
+"jpeg" ns-image register-image-class
+"bmp" ns-image register-image-class
+"ico" ns-image register-image-class
+
+CONSTANT: NSImageRepLoadStatusUnknownType     -1
+CONSTANT: NSImageRepLoadStatusReadingHeader   -2
+CONSTANT: NSImageRepLoadStatusWillNeedAllData -3
+CONSTANT: NSImageRepLoadStatusInvalidData     -4
+CONSTANT: NSImageRepLoadStatusUnexpectedEOF   -5
+CONSTANT: NSImageRepLoadStatusCompleted       -6
+
+CONSTANT: NSColorRenderingIntentDefault                 0
+CONSTANT: NSColorRenderingIntentAbsoluteColorimetric    1
+CONSTANT: NSColorRenderingIntentRelativeColorimetric    2
+CONSTANT: NSColorRenderingIntentPerceptual              3
+CONSTANT: NSColorRenderingIntentSaturation              4
+
+ERROR: ns-image-unknown-type ;
+ERROR: ns-image-invalid-data ;
+ERROR: ns-image-unexpected-eof ;
+ERROR: ns-image-planar-images-not-supported ;
+
+<PRIVATE
+
+: check-return ( n -- )
+    {
+        { $ NSImageRepLoadStatusUnknownType   [ ns-image-unknown-type   ] }
+        { $ NSImageRepLoadStatusInvalidData   [ ns-image-invalid-data   ] }
+        { $ NSImageRepLoadStatusUnexpectedEOF [ ns-image-unexpected-eof ] }
+        [ drop ]
+    } case ;
+
+PRIVATE>
+
+: load-image-rep ( -- image-rep )
+    NSBitmapImageRep contents <CFData> -> autorelease -> imageRepWithData:
+    NSColorSpace -> genericRGBColorSpace
+    NSColorRenderingIntentDefault
+    -> bitmapImageRepByConvertingToColorSpace:renderingIntent: ;
+
+: image-rep>image ( image-rep -- image )
+    image new swap {
+        [ -> size CGSize>dim [ >integer ] map >>dim ]
+        [ -> bitmapData ]
+        [ -> bytesPerPlane memory>byte-array >>bitmap ]
+    } cleave
+        RGBA >>component-order
+        ubyte-components >>component-type
+        t >>premultiplied-alpha?
+        f >>upside-down? ;
+
+M: ns-image stream>image
+    drop
+    [ load-image-rep ] with-input-stream image-rep>image ;

basis/images/cocoa/platforms.txt

@@ -0,0 +1 @@
+macosx

basis/images/cocoa/summary.txt

@@ -0,0 +1 @@
+Image loading using MacOS X's native Cocoa APIs

basis/images/gdiplus/gdiplus.factor

@@ -0,0 +1,63 @@
+! (c)2010 Joe Groff bsd license
+USING: accessors alien.c-types alien.data alien.enums
+classes.struct destructors images images.loader
+io.streams.limited kernel locals math windows.com
+windows.gdiplus windows.streams windows.types typed
+byte-arrays grouping sequences ;
+IN: images.gdiplus
+
+SINGLETON: gdi+-image
+"png" gdi+-image register-image-class
+"tif" gdi+-image register-image-class
+"tiff" gdi+-image register-image-class
+"gif" gdi+-image register-image-class
+"jpg" gdi+-image register-image-class
+"jpeg" gdi+-image register-image-class
+"bmp" gdi+-image register-image-class
+"ico" gdi+-image register-image-class
+
+<PRIVATE
+: <GpRect> ( x y w h -- rect )
+    GpRect <struct-boa> ; inline
+
+: stream>gdi+-bitmap ( stream -- bitmap )
+    stream>IStream &com-release
+    { void* } [ GdipCreateBitmapFromStream check-gdi+-status ]
+    [ ] with-out-parameters &GdipFree ;
+
+: gdi+-bitmap-width ( bitmap -- w )
+    { UINT } [ GdipGetImageWidth check-gdi+-status ]
+    [ ] with-out-parameters ;
+: gdi+-bitmap-height ( bitmap -- w )
+    { UINT } [ GdipGetImageHeight check-gdi+-status ]
+    [ ] with-out-parameters ;
+: gdi+-lock-bitmap ( bitmap rect mode format -- data )
+    { BitmapData } [ GdipBitmapLockBits check-gdi+-status ]
+    [ clone ] with-out-parameters ;
+
+:: gdi+-bitmap>data ( bitmap -- w h pixels )
+    bitmap [ gdi+-bitmap-width ] [ gdi+-bitmap-height ] bi :> ( w h )
+    bitmap 0 0 w h <GpRect> ImageLockModeRead enum>number
+    PixelFormat32bppARGB gdi+-lock-bitmap :> bitmap-data
+    bitmap-data [ Scan0>> ] [ Stride>> ] [ Height>> * ] tri
+    memory>byte-array :> pixels
+    bitmap bitmap-data GdipBitmapUnlockBits check-gdi+-status
+    w h pixels ;
+    
+:: data>image ( w h pixels -- image )
+    image new
+        { w h } >>dim
+        pixels >>bitmap
+        BGRA >>component-order
+        ubyte-components >>component-type
+        f >>upside-down? ;
+
+PRIVATE>
+
+M: gdi+-image stream>image
+    drop [
+        start-gdi+ &stop-gdi+ drop
+        stream>gdi+-bitmap
+        gdi+-bitmap>data
+        data>image
+    ] with-destructors ;

basis/images/gdiplus/platforms.txt

@@ -0,0 +1 @@
+windows

basis/images/gtk/authors.txt

@@ -0,0 +1 @@
+Philipp Brüschweiler

basis/images/gtk/gtk.factor

@@ -0,0 +1,68 @@
+! Copyright (C) 2010 Philipp Brüschweiler.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data arrays combinators
+destructors gdk.pixbuf.ffi gobject.ffi grouping images
+images.loader io kernel locals math sequences
+specialized-arrays ;
+IN: images.gtk
+SPECIALIZED-ARRAY: uchar
+
+SINGLETON: gtk-image
+"png"  gtk-image register-image-class
+"tif"  gtk-image register-image-class
+"tiff" gtk-image register-image-class
+"gif"  gtk-image register-image-class
+"jpg"  gtk-image register-image-class
+"jpeg" gtk-image register-image-class
+"bmp"  gtk-image register-image-class
+"ico"  gtk-image register-image-class
+
+<PRIVATE
+
+: image-data ( GdkPixbuf -- data )
+    {
+        [ gdk_pixbuf_get_pixels ]
+        [ gdk_pixbuf_get_width ]
+        [ gdk_pixbuf_get_height ]
+        [ gdk_pixbuf_get_rowstride ]
+        [ gdk_pixbuf_get_n_channels ]
+        [ gdk_pixbuf_get_bits_per_sample ]
+    } cleave
+    [let :> ( pixels w h rowstride channels bps )
+        bps channels * 7 + 8 /i w * :> bytes-per-row
+
+        bytes-per-row rowstride =
+        [ pixels h rowstride * memory>byte-array ]
+        [
+            pixels rowstride h * <direct-uchar-array>
+            rowstride <sliced-groups>
+            [ bytes-per-row head-slice ] map concat
+        ] if
+    ] ;
+
+: component-type ( GdkPixbuf -- component-type )
+    gdk_pixbuf_get_bits_per_sample {
+        {  8 [ ubyte-components ] }
+        { 16 [ ushort-components ] }
+        { 32 [ uint-components ] }
+    } case ;
+
+: GdkPixbuf>image ( GdkPixbuf -- image )
+    [ image new ] dip
+        {
+            [ [ gdk_pixbuf_get_width ] [ gdk_pixbuf_get_height ] bi 2array >>dim ]
+            [ image-data >>bitmap ]
+            [ gdk_pixbuf_get_has_alpha RGBA RGB ? >>component-order ]
+            [ component-type >>component-type ]
+        } cleave
+        f >>premultiplied-alpha?
+        f >>upside-down? ;
+
+PRIVATE>
+
+M: gtk-image stream>image
+    drop [
+        stream-contents data>GInputStream &g_object_unref
+        GInputStream>GdkPixbuf &g_object_unref
+        GdkPixbuf>image
+    ] with-destructors ;

basis/images/gtk/platforms.txt

@@ -0,0 +1,2 @@
+linux
+bsd

basis/images/gtk/summary.txt

@@ -0,0 +1 @@
+Image loading using GTK's GdkPixbuf API

basis/images/images-tests.factor

@@ -3,7 +3,7 @@
 USING: images tools.test kernel accessors ;
 IN: images.tests
 
-[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA ubyte-components f B{
+[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA ubyte-components f f B{
     0 0 0 0 
     0 0 0 0 
     0 0 0 0 
@@ -19,7 +19,7 @@ IN: images.tests
     57 57 57 255
     0 0 0 0 
     0 0 0 0 
-} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA ubyte-components f B{
+} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA ubyte-components f f B{
     0 0 0 0 
     0 0 0 0 
     0 0 0 0 

basis/images/images.factor

@@ -62,7 +62,10 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB LA A INTENSITY ;
 
 UNION: alpha-channel-precedes-colors ABGR ARGB XBGR XRGB ;
 
-TUPLE: image dim component-order component-type upside-down? bitmap ;
+TUPLE: image
+    dim component-order component-type
+    upside-down? premultiplied-alpha?
+    bitmap ;
 
 : <image> ( -- image ) image new ; inline
 

basis/images/tesselation/tesselation-tests.factor

@@ -10,12 +10,12 @@ IN: images.tesselation
 [
     {
         {
-            T{ image f { 2 2 } L ubyte-components f B{ 1 2 5 6 } }
+            T{ image f { 2 2 } L ubyte-components f f B{ 1 2 5 6 } }
-            T{ image f { 2 2 } L ubyte-components f B{ 3 4 7 8 } }
+            T{ image f { 2 2 } L ubyte-components f f B{ 3 4 7 8 } }
         }
         {
-            T{ image f { 2 2 } L ubyte-components f B{ 9 10 13 14 } }
+            T{ image f { 2 2 } L ubyte-components f f B{ 9 10 13 14 } }
-            T{ image f { 2 2 } L ubyte-components f B{ 11 12 15 16 } }
+            T{ image f { 2 2 } L ubyte-components f f B{ 11 12 15 16 } }
         }
     }
 ] [
@@ -30,12 +30,12 @@ IN: images.tesselation
 [
     {
         {
-            T{ image f { 2 2 } L ubyte-components f B{ 1 2 4 5 } }
+            T{ image f { 2 2 } L ubyte-components f f B{ 1 2 4 5 } }
-            T{ image f { 1 2 } L ubyte-components f B{ 3 6 } }
+            T{ image f { 1 2 } L ubyte-components f f B{ 3 6 } }
         }
         {
-            T{ image f { 2 1 } L ubyte-components f B{ 7 8 } }
+            T{ image f { 2 1 } L ubyte-components f f B{ 7 8 } }
-            T{ image f { 1 1 } L ubyte-components f B{ 9 } }
+            T{ image f { 1 1 } L ubyte-components f f B{ 9 } }
         }
     }
 ] [

basis/nibble-arrays/nibble-arrays-tests.factor

@@ -1,6 +1,8 @@
 USING: nibble-arrays tools.test sequences kernel math ;
 IN: nibble-arrays.tests
 
+[ -1 <nibble-array> ] [ T{ bad-array-length f -1 } = ] must-fail-with
+
 [ t ] [ 16 iota dup >nibble-array sequence= ] unit-test
 [ N{ 4 2 1 3 } ] [ N{ 3 1 2 4 } reverse ] unit-test
 [ N{ 1 4 9 0 9 4 } ] [ N{ 1 2 3 4 5 6 } [ sq ] map ] unit-test

basis/nibble-arrays/nibble-arrays.factor

@@ -30,7 +30,10 @@ CONSTANT: nibble BIN: 1111
 
 PRIVATE>
 
+ERROR: bad-array-length n ;
+
 : <nibble-array> ( n -- nibble-array )
+    dup 0 < [ bad-array-length ] when
     dup nibbles>bytes <byte-array> nibble-array boa ; inline
 
 M: nibble-array length length>> ;

basis/opengl/textures/textures.factor

@@ -312,12 +312,21 @@ TUPLE: single-texture < disposable image dim loc texture-coords texture display-
     [ init-texture texture-coords>> gl-texture-coord-pointer ] tri
     swap gl-fill-rect ;
 
+: set-blend-mode ( texture -- )
+    image>> dup has-alpha?
+    [ premultiplied-alpha?>> [ GL_ONE GL_ONE_MINUS_SRC_ALPHA glBlendFunc ] when ]
+    [ drop GL_BLEND glDisable ] if ;
+
+: reset-blend-mode ( texture -- )
+    image>> dup has-alpha?
+    [ premultiplied-alpha?>> [ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc ] when ]
+    [ drop GL_BLEND glEnable ] if ;
+
 : draw-textured-rect ( dim texture -- )
     [
-        [ image>> has-alpha? [ GL_BLEND glDisable ] unless ]
+        [ set-blend-mode ]
         [ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
-        [ image>> has-alpha? [ GL_BLEND glEnable ] unless ]
+        [ reset-blend-mode ] tri
-        tri
     ] with-texturing ;
 
 : texture-coords ( texture -- coords )

basis/tools/deploy/shaker/shaker.factor

@@ -100,6 +100,13 @@ IN: tools.deploy.shaker
         run-file
     ] when ;
 
+: strip-gtk-icon ( -- )
+    "ui.backend.gtk" vocab [
+        "Stripping GTK icon loading code" show
+        "vocab:tools/deploy/shaker/strip-gtk-icon.factor"
+        run-file
+    ] when ;
+
 : strip-specialized-arrays ( -- )
     strip-dictionary? "specialized-arrays" vocab and [
         "Stripping specialized arrays" show
@@ -542,6 +549,7 @@ SYMBOL: deploy-vocab
     strip-call
     strip-cocoa
     strip-gobject
+    strip-gtk-icon
     strip-debugger
     strip-ui-error-hook
     strip-specialized-arrays

basis/tools/deploy/shaker/strip-gtk-icon.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2010 Philipp Brüschweiler
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.deploy.shaker literals namespaces
+vocabs.loader io.pathnames io.files io.encodings.binary ;
+IN: ui.backend.gtk
+
+CONSTANT: get-icon-data
+    $[
+        deploy-vocab get
+        dup vocab-dir "icon.png" append-path vocab-append-path
+        [ exists? ] keep "resource:misc/icons/Factor_48x48.png" ?
+        binary file-contents
+    ]

basis/tools/deploy/unix/unix.factor

@@ -1,9 +1,8 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.pathnames io.directories io.files
+USING: io io.backend io.directories io.files.info.unix kernel
-io.files.info.unix io.backend kernel namespaces make sequences
+namespaces sequences system tools.deploy.backend
-system tools.deploy.backend tools.deploy.config
+tools.deploy.config tools.deploy.config.editor ;
-tools.deploy.config.editor assocs hashtables prettyprint ;
 IN: tools.deploy.unix
 
 : create-app-dir ( vocab bundle-name -- vm )
@@ -14,12 +13,12 @@ IN: tools.deploy.unix
     deploy-name get ;
 
 M: unix deploy* ( vocab -- )
-    "." resource-path [
+    "resource:" [
         dup deploy-config [
             [ bundle-name create-app-dir ] keep
             [ bundle-name image-name ] keep
             namespace make-deploy-image
             bundle-name "" [ copy-resources ] [ copy-libraries ] 3bi
-            bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print
+            bundle-name normalize-path "Binary deployed to " "." surround print
         ] bind
     ] with-directory ;

basis/ui/backend/gtk/gtk.factor

@@ -3,14 +3,18 @@
 USING: accessors alien.accessors alien.c-types alien.data
 alien.strings arrays assocs classes.struct command-line
 continuations destructors environment gdk.ffi gdk.gl.ffi
-glib.ffi gobject-introspection.standard-types gobject.ffi
+gdk.pixbuf.ffi glib.ffi
-gtk.ffi gtk.gl.ffi io.encodings.utf8 kernel libc literals locals
+gobject-introspection.standard-types
-math math.bitwise math.order math.vectors namespaces sequences
+gobject.ffi gtk.ffi gtk.gl.ffi io.backend
-strings system threads ui ui.backend ui.backend.gtk.input-methods
+io.backend.unix.multiplexers io.encodings.binary
-ui.backend.gtk.io ui.clipboards ui.event-loop ui.gadgets
+io.encodings.utf8 io.files io.thread kernel libc literals
-ui.gadgets.private ui.gadgets.worlds ui.gestures
+locals math math.bitwise math.order math.vectors namespaces
-ui.pixel-formats ui.pixel-formats.private ui.private
+sequences strings system threads ui ui.backend ui.backend.gtk.input-methods
-vocabs.loader combinators prettyprint io ;
+ui.backend.gtk.io ui.clipboards
+ui.commands ui.event-loop ui.gadgets ui.gadgets.editors
+ui.gadgets.menus ui.gadgets.private ui.gadgets.worlds
+ui.gestures ui.pixel-formats ui.pixel-formats.private
+ui.private vocabs.loader combinators io ;
 IN: ui.backend.gtk
 
 SINGLETON: gtk-ui-backend
@@ -156,9 +160,6 @@ CONSTANT: action-key-codes
         { $ GDK_SCROLL_RIGHT { 1 0 } }
     } at ;
 
-: mouse-event>gesture ( event -- modifiers button loc )
-    [ event-modifiers ] [ button>> ] [ event-loc ] tri ;
-
 : on-motion ( win event user-data -- ? )
     drop swap
     [ event-loc ] dip window
@@ -169,23 +170,33 @@ CONSTANT: action-key-codes
 
 :: on-button-press ( win event user-data -- ? )
     win window :> world
-    event mouse-event>gesture :> ( modifiers button loc )
+    event type>> GDK_BUTTON_PRESS = [
-    button {
+        event button>> {
             { 8 [ ] }
             { 9 [ ] }
-        [ modifiers swap <button-down> loc world
+            [
-          send-button-down ]
+                event event-modifiers swap <button-down>
-    } case t ;
+                event event-loc
+                world
+                send-button-down
+            ]
+        } case
+    ] when t ;
 
 :: on-button-release ( win event user-data -- ? )
     win window :> world
-    event mouse-event>gesture :> ( modifiers button loc )
+    event type>> GDK_BUTTON_RELEASE = [
-    button {
+        event button>> {
             { 8 [ world left-action send-action ] }
             { 9 [ world right-action send-action ] }
-        [ modifiers swap <button-up> loc world
+            [
-          send-button-up ]
+                event event-modifiers swap <button-up>
-    } case t ;
+                event event-loc
+                world
+                send-button-up
+            ]
+        } case
+    ] when t ;
 
 : on-scroll ( win event user-data -- ? )
     drop swap [
@@ -213,6 +224,17 @@ CONSTANT: action-key-codes
 : on-focus-out ( win event user-data -- ? )
     2drop window unfocus-world t ;
 
+! This word gets replaced when deploying. See 'Vocabulary icons'
+! in the docs and tools.deploy.shaker.gtk-icon
+: get-icon-data ( -- byte-array )
+    "resource:misc/icons/Factor_48x48.png" binary file-contents ;
+
+: load-icon ( -- )
+    get-icon-data [
+        data>GInputStream &g_object_unref
+        GInputStream>GdkPixbuf gtk_window_set_default_icon
+    ] with-destructors ;
+
 :: connect-user-input-signals ( win -- )
     win events-mask gtk_widget_add_events
     win "motion-notify-event" [ on-motion yield ]
@@ -502,6 +524,7 @@ M: gtk-ui-backend (with-ui)
     [
         0 gint <ref> f void* <ref> gtk_init
         0 gint <ref> f void* <ref> gtk_gl_init
+        load-icon
         init-clipboard
         start-ui
         [

basis/ui/gadgets/glass/glass.factor

@@ -45,7 +45,7 @@ PRIVATE>
 
 : show-glass ( owner child visible-rect -- )
     <glass>
-    dup gadget-child hand-clicked set
+    dup gadget-child hand-clicked set-global
     dup owner>> find-world add-glass ;
 
 \ glass H{

basis/ui/images/images.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces cache images images.loader accessors assocs
+USING: accessors assocs cache combinators images images.loader
-kernel opengl opengl.gl opengl.textures ui.gadgets.worlds
+kernel memoize namespaces opengl opengl.gl opengl.textures system
-memoize images.png images.tiff ;
+ui.gadgets.worlds vocabs.loader ;
 IN: ui.images
 
 TUPLE: image-name path ;
@@ -30,3 +30,11 @@ PRIVATE>
 
 : image-dim ( image-name -- dim )
     cached-image dim>> ;
+
+<<
+{
+    { [ os macosx? ] [ "images.cocoa"   require ] }
+    { [ os winnt?  ] [ "images.gdiplus" require ] }
+    [ "images.gtk" require ]
+} cond
+>>

basis/windows/com/com.factor

@@ -1,6 +1,6 @@
 USING: alien alien.c-types alien.destructors windows.com.syntax
 windows.ole32 windows.types continuations kernel alien.syntax
-libc destructors accessors alien.data ;
+libc destructors accessors alien.data classes.struct windows.kernel32 ;
 IN: windows.com
 
 LIBRARY: ole32
@@ -31,6 +31,55 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
     HRESULT DragLeave ( )
     HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;
 
+COM-INTERFACE: ISequentialStream IUnknown {0C733A30-2A1C-11CE-ADE5-00AA0044773D}
+    HRESULT Read ( void* pv, ULONG cb, ULONG* pcbRead )
+    HRESULT Write ( void* pv, ULONG cb, ULONG* pcbWritten ) ;
+
+STRUCT: STATSTG
+    { pwcsName LPOLESTR }
+    { type DWORD }
+    { cbSize ULARGE_INTEGER }
+    { mtime FILETIME }
+    { ctime FILETIME }
+    { atime FILETIME }
+    { grfMode DWORD }
+    { grfLocksSupported DWORD }
+    { clsid CLSID }
+    { grfStateBits DWORD }
+    { reserved DWORD } ;
+
+CONSTANT: STGM_READ 0
+CONSTANT: STGM_WRITE 1
+CONSTANT: STGM_READWRITE 2
+
+CONSTANT: STG_E_INVALIDFUNCTION HEX: 80030001
+
+CONSTANT: STGTY_STORAGE   1
+CONSTANT: STGTY_STREAM    2
+CONSTANT: STGTY_LOCKBYTES 3
+CONSTANT: STGTY_PROPERTY  4
+
+CONSTANT: STREAM_SEEK_SET 0
+CONSTANT: STREAM_SEEK_CUR 1
+CONSTANT: STREAM_SEEK_END 2
+
+CONSTANT: LOCK_WRITE     1
+CONSTANT: LOCK_EXCLUSIVE 2
+CONSTANT: LOCK_ONLYONCE  4
+
+CONSTANT: GUID_NULL GUID: {00000000-0000-0000-0000-000000000000}
+
+COM-INTERFACE: IStream ISequentialStream {0000000C-0000-0000-C000-000000000046}
+    HRESULT Seek ( LARGE_INTEGER dlibMove, DWORD dwOrigin, ULARGE_INTEGER* plibNewPosition )
+    HRESULT SetSize ( ULARGE_INTEGER* libNewSize )
+    HRESULT CopyTo ( IStream* pstm, ULARGE_INTEGER cb, ULARGE_INTEGER* pcbRead, ULARGE_INTEGER* pcbWritten )
+    HRESULT Commit ( DWORD grfCommitFlags )
+    HRESULT Revert ( )
+    HRESULT LockRegion ( ULARGE_INTEGER libOffset, ULARGE_INTEGER cb, DWORD dwLockType )
+    HRESULT UnlockRegion ( ULARGE_INTEGER libOffset, ULARGE_INTEGER cb, DWORD dwLockType )
+    HRESULT Stat ( STATSTG* pstatstg, DWORD grfStatFlag )
+    HRESULT Clone ( IStream** ppstm ) ;
+
 FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
 FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
 FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
@@ -50,3 +99,5 @@ FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
     over [ com-release ] curry [ ] cleanup ; inline
 
 DESTRUCTOR: com-release
+
+

basis/windows/gdiplus/platforms.txt

@@ -0,0 +1 @@
+windows

basis/windows/ole32/ole32.factor

@@ -13,6 +13,9 @@ TYPEDEF: void* LPUNKNOWN
 TYPEDEF: LPWSTR LPOLESTR
 TYPEDEF: LPWSTR LPCOLESTR
 
+TYPEDEF: GUID IID
+TYPEDEF: GUID CLSID
+
 TYPEDEF: REFGUID LPGUID
 TYPEDEF: REFGUID REFIID
 TYPEDEF: REFGUID REFCLSID

basis/windows/streams/platforms.txt

@@ -0,0 +1 @@
+windows

basis/windows/streams/streams.factor

@@ -0,0 +1,123 @@
+USING: accessors alien.c-types classes.struct combinators
+continuations io kernel libc literals locals sequences
+specialized-arrays windows.com memoize
+windows.com.wrapper windows.kernel32 windows.ole32
+windows.types ;
+IN: windows.streams
+
+SPECIALIZED-ARRAY: uchar
+
+<PRIVATE
+
+: with-hresult ( quot: ( -- result ) -- result )
+    [ drop E_FAIL ] recover ; inline
+
+:: IStream-read ( stream pv cb out-read -- hresult )
+    [
+        cb stream stream-read :> buf
+        buf length :> bytes
+        pv buf bytes memcpy
+        out-read [ bytes out-read 0 ULONG set-alien-value ] when
+
+        cb bytes = [ S_OK ] [ S_FALSE ] if
+    ] with-hresult ; inline
+
+:: IStream-write ( stream pv cb out-written -- hresult )
+    [
+        pv cb <direct-uchar-array> stream stream-write
+        out-written [ cb out-written 0 ULONG set-alien-value ] when
+        S_OK
+    ] with-hresult ; inline
+
+: origin>seek-type ( origin -- seek-type )
+    {
+        { $ STREAM_SEEK_SET [ seek-absolute ] }
+        { $ STREAM_SEEK_CUR [ seek-relative ] }
+        { $ STREAM_SEEK_END [ seek-end ] }
+    } case ;
+
+:: IStream-seek ( stream move origin new-position -- hresult )
+    [
+        move origin origin>seek-type stream stream-seek
+        new-position [
+            stream stream-tell new-position 0 ULARGE_INTEGER set-alien-value
+        ] when
+        S_OK
+    ] with-hresult ; inline
+
+:: IStream-set-size ( stream new-size -- hresult )
+    STG_E_INVALIDFUNCTION ;
+
+:: IStream-copy-to ( stream other-stream cb out-read out-written -- hresult )
+    [
+        cb stream stream-read :> buf
+        buf length :> bytes
+        out-read [ bytes out-read 0 ULONG set-alien-value ] when
+
+        other-stream buf bytes out-written IStream::Write
+    ] with-hresult ; inline
+
+:: IStream-commit ( stream flags -- hresult )
+    stream stream-flush S_OK ;
+
+:: IStream-revert ( stream -- hresult )
+    STG_E_INVALIDFUNCTION ;
+
+:: IStream-lock-region ( stream offset cb lock-type -- hresult )
+    STG_E_INVALIDFUNCTION ;
+
+:: IStream-unlock-region ( stream offset cb lock-type -- hresult )
+    STG_E_INVALIDFUNCTION ;
+
+:: stream-size ( stream -- size )
+    stream stream-tell :> old-pos
+    0 seek-end stream stream-seek
+    stream stream-tell :> size
+    old-pos seek-absolute stream stream-seek
+    size ;
+
+:: IStream-stat ( stream out-stat stat-flag -- hresult )
+    [
+        out-stat
+            f >>pwcsName
+            STGTY_STREAM >>type
+            stream stream-size >>cbSize
+            FILETIME <struct> >>mtime
+            FILETIME <struct> >>ctime
+            FILETIME <struct> >>atime
+            STGM_READWRITE >>grfMode
+            0 >>grfLocksSupported
+            GUID_NULL >>clsid
+            0 >>grfStateBits
+            0 >>reserved
+            drop
+        S_OK
+    ] with-hresult ;
+
+:: IStream-clone ( out-clone-stream -- hresult )
+    f out-clone-stream 0 void* set-alien-value
+    STG_E_INVALIDFUNCTION ;
+
+CONSTANT: stream-wrapper
+    $[
+        {
+            { IStream {
+                [ IStream-read ]
+                [ IStream-write ]
+                [ IStream-seek ]
+                [ IStream-set-size ]
+                [ IStream-copy-to ]
+                [ IStream-commit ]
+                [ IStream-revert ]
+                [ IStream-lock-region ]
+                [ IStream-unlock-region ]
+                [ IStream-stat ]
+                [ IStream-clone ]
+            } }
+        } <com-wrapper>
+    ]
+
+PRIVATE>
+
+: stream>IStream ( stream -- IStream )
+    stream-wrapper com-wrap ;

basis/windows/streams/summary.txt

@@ -0,0 +1 @@
+IStream interface wrapper for Factor stream objects

basis/windows/types/types.factor

@@ -16,6 +16,8 @@ TYPEDEF: wchar_t             WCHAR
 
 TYPEDEF: short               SHORT
 TYPEDEF: ushort              USHORT
+TYPEDEF: short               INT16
+TYPEDEF: ushort              UINT16
 
 TYPEDEF: ushort              WORD
 TYPEDEF: ulong               DWORD
@@ -94,7 +96,7 @@ TYPEDEF: HANDLE              HDDEDATA
 TYPEDEF: HANDLE              HDESK
 TYPEDEF: HANDLE              HDROP
 TYPEDEF: HANDLE              HDWP
-TYPEDEF: HANDLE              HENMETAFILE
+TYPEDEF: HANDLE              HENHMETAFILE
 TYPEDEF: HANDLE              HFONT
 TYPEDEF: HANDLE              HGDIOBJ
 TYPEDEF: HANDLE              HGLOBAL
@@ -398,3 +400,5 @@ STRUCT: TEXTMETRICW
     { tmCharSet BYTE } ;
 
 TYPEDEF: TEXTMETRICW* LPTEXTMETRIC
+
+TYPEDEF: ULONG PROPID

basis/windows/windows.factor

@@ -17,6 +17,7 @@ CONSTANT: MAX_UNICODE_PATH 32768
     { "iphlpapi"    "iphlpapi.dll"       stdcall }
     { "libc"        "msvcrt.dll"         cdecl   }
     { "libm"        "msvcrt.dll"         cdecl   }
+    { "gdiplus"     "gdiplus.dll"        stdcall }
     { "gl"          "opengl32.dll"       stdcall }
     { "glu"         "glu32.dll"          stdcall }
     { "ole32"       "ole32.dll"          stdcall }

core/vocabs/loader/loader-docs.factor

@@ -28,7 +28,12 @@ ARTICLE: "vocabs.roots" "Vocabulary roots"
 { $subsections "add-vocab-roots" } ;
 
 ARTICLE: "vocabs.icons" "Vocabulary icons"
-"An icon file representing the vocabulary can be provided for use by " { $link "tools.deploy" } ". A file named " { $snippet "icon.ico" } " will be used as the application icon when the application is deployed on Windows. A file named " { $snippet "icon.icns" } " will be used when the application is deployed on MacOS X." ;
+"An icon file representing the vocabulary can be provided for use by " { $link "tools.deploy" } ". If any of the following files exist inside the vocabulary directory, they will be used as icons when the application is deployed."
+{ $list
+    { { $snippet "icon.ico" } " on Windows" }
+    { { $snippet "icon.icns" } " on MacOS X" }
+    { { $snippet "icon.png" } " on Linux and *BSD" }
+} ;
 
 ARTICLE: "vocabs.loader" "Vocabulary loader"
 "The " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } " words load vocabularies using the vocabulary loader. The vocabulary loader is implemented in the " { $vocab-link "vocabs.loader" } " vocabulary."

extra/gpu/textures/textures.factor

@@ -309,7 +309,7 @@ TYPED: read-compressed-texture ( tdt: texture-data-target level: integer -- byte
 
 : read-texture-image ( tdt level -- image )
     [ texture-dim ]
-    [ drop texture-object [ component-order>> ] [ component-type>> ] bi f ]
+    [ drop texture-object [ component-order>> ] [ component-type>> ] bi f f ]
     [ read-texture ] 2tri
     image boa ; inline
 

extra/graphviz/ffi/ffi-docs.factor

@@ -13,7 +13,7 @@ HELP: ffi-errors
 
 HELP: supported-engines
 { $values
-    { "value" array }
+    { "seq" array }
 }
 { $description "An " { $link array } " of " { $link string } "s representing all valid " { $emphasis "layout engines" } ". For example, the " { $emphasis "dot" } " engine is typically included in a Graphviz installation, so " { $snippet "\"dot\"" } " will be an element of " { $link supported-engines } ". See " { $url "http://graphviz.org/Documentation.php" } " for more details." }
 { $notes "This constant's definition is determined at parse-time by asking the system's Graphviz installation what engines are supported." }
@@ -21,7 +21,7 @@ HELP: supported-engines
 
 HELP: supported-formats
 { $values
-    { "value" array }
+    { "seq" array }
 }
 { $description "An " { $link array } " of " { $link string } "s representing all valid " { $emphasis "layout formats" } ". For example, Graphviz can typically render using the Postscript format, in which case " { $snippet "\"ps\"" } " will be an element of " { $link supported-formats } ". See " { $url "http://graphviz.org/Documentation.php" } " for more details." }
 { $notes "This constant's definition is determined at parse-time by asking the system's Graphviz installation what formats are supported."

extra/graphviz/ffi/ffi.factor

@@ -3,12 +3,9 @@
 USING: accessors alien alien.c-types alien.destructors
 alien.libraries alien.syntax combinators debugger destructors
 fry io kernel literals math prettyprint sequences splitting
-system words.constant
+system memoize graphviz ;
-graphviz
-;
 IN: graphviz.ffi
 
-<<
 "libgraph" {
     { [ os macosx? ] [ "libgraph.dylib" ] }
     { [ os unix?   ] [ "libgraph.so"    ] }
@@ -21,7 +18,6 @@ IN: graphviz.ffi
     { [ os unix?   ] [ "libgvc.so"    ] }
     { [ os winnt?  ] [ "gvc.dll"      ] }
 } cond cdecl add-library
->>
 
 LIBRARY: libgraph
 
@@ -85,11 +81,7 @@ FUNCTION: int agsafeset ( void* obj,
 LIBRARY: libgvc
 
 ! Graphviz contexts
-! This must be wrapped in << >> so that GVC_t*, gvContext, and
-! &gvFreeContext can be used to compute the supported-engines
-! and supported-formats constants below.
 
-<<
 C-TYPE: GVC_t
 
 FUNCTION: GVC_t* gvContext ( ) ;
@@ -112,7 +104,6 @@ M: ffi-errors error.
     int-gvFreeContext dup zero? [ drop ] [ ffi-errors ] if ;
 
 DESTRUCTOR: gvFreeContext
->>
 
 ! Layout
 
@@ -130,8 +121,6 @@ FUNCTION: int gvRenderFilename ( GVC_t* gvc,
 
 ! Supported layout engines (dot, neato, etc.) and output
 ! formats (png, jpg, etc.)
-
-<<
 <PRIVATE
 
 ENUM: api_t
@@ -152,7 +141,6 @@ FUNCTION: c-string
     ] with-destructors ;
 
 PRIVATE>
->>
 
-CONSTANT: supported-engines $[ API_layout plugin-list ]
+MEMO: supported-engines ( -- seq ) API_layout plugin-list ;
-CONSTANT: supported-formats $[ API_device plugin-list ]
+MEMO: supported-formats ( -- seq ) API_device plugin-list ;

extra/graphviz/render/render.factor

@@ -1,11 +1,9 @@
 ! Copyright (C) 2011 Alex Vondrak.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators continuations destructors
+USING: accessors combinators compiler.units continuations
-images.viewer io.backend io.files.unique kernel locals
+destructors images.viewer io.backend io.files.unique kernel
-namespaces parser sequences summary unicode.case words
+locals namespaces parser sequences summary unicode.case words
-graphviz.ffi
+graphviz.ffi graphviz.builder ;
-graphviz.builder
-;
 IN: graphviz.render
 
 SYMBOL: default-layout
@@ -109,8 +107,6 @@ PRIVATE>
 : preview-window ( graph -- )
     (preview) image-window ; inline
 
-<<
-
 <PRIVATE
 
 : define-graphviz-by-engine ( -K -- )
@@ -130,7 +126,7 @@ PRIVATE>
 
 PRIVATE>
 
-supported-engines [ define-graphviz-by-engine ] each
+[
-supported-formats [ define-graphviz-by-format ] each
+    supported-engines [ define-graphviz-by-engine ] each
-
+    supported-formats [ define-graphviz-by-format ] each
->>
+] with-compilation-unit

extra/model-viewer/model-viewer.factor

@@ -88,12 +88,18 @@ TUPLE: vbo
     index-buffer index-count vertex-format texture bump ka ;
 
 : white-image ( -- image )
-    { 1 1 } BGR ubyte-components f
+    <image>
-    B{ 255 255 255 } image boa ;
+        { 1 1 } >>dim
+        BGR >>component-order
+        ubyte-components >>component-type
+        B{ 255 255 255 } >>bitmap ;
 
 : up-image ( -- image )
-    { 1 1 } BGR ubyte-components f
+    <image>
-    B{ 0 0 0 } image boa ;
+        { 1 1 } >>dim
+        BGR >>component-order
+        ubyte-components >>component-type
+        B{ 0 0 0 } >>bitmap ;
         
 : make-texture ( pathname alt -- texture )
     swap [ nip load-image ] [ ] if*