Merge branch 'master' into smarter_error_list

basis/help/handbook/handbook.factor

@@ -49,6 +49,7 @@ $nl
     { "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } }
     { "boolean"               { { $link t } " or " { $link f } } }
     { "class"                 { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } }
+    { "combinator"            { "a word taking a quotation or another word as input; a higher-order function. See " { $link "combinators" } } }
     { "definition specifier"  { "an instance of " { $link definition } " which implements the " { $link "definition-protocol" } } }
     { "generalized boolean"   { "an object interpreted as a boolean; a value of " { $link f } " denotes false and anything else denotes true" } }
     { "generic word"          { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } }
@@ -56,6 +57,7 @@ $nl
     { "object"                { "any datum which can be identified" } }
     { "ordering specifier"    { "see " { $link "order-specifiers" } } }
     { "pathname string"       { "an OS-specific pathname which identifies a file" } }
+    { "quotation"             { "an anonymous function; an instance of the " { $link quotation } " class. More generally, instances of the " { $link callable } " class can be used in many places documented to expect quotations" } }
     { "sequence" { "a sequence; see " { $link "sequence-protocol" } } }
     { "slot"                  { "a component of an object which can store a value" } }
     { "stack effect"          { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } }

basis/images/bitmap/bitmap-tests.factor

@@ -1,6 +1,7 @@
 USING: images.bitmap images.viewer io.encodings.binary
 io.files io.files.unique kernel tools.test images.loader
-literals sequences checksums.md5 checksums ;
+literals sequences checksums.md5 checksums
+images.normalization ;
 IN: images.bitmap.tests
 
 CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
@@ -16,15 +17,6 @@ CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp"
 CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp"
 CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
 
-[ t ]
-[
-    test-bitmap24
-    [ binary file-contents ] [ load-image ] bi
-
-    "test-bitmap24" unique-file
-    [ save-bitmap ] [ binary file-contents ] bi =
-] unit-test
-
 {
     $ test-bitmap8
     $ test-bitmap24
@@ -34,7 +26,7 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
 
 : test-bitmap-save ( path -- ? )
     [ md5 checksum-file ]
-    [ load-image ] bi
+    [ load-image normalize-image ] bi
     "bitmap-save-test" unique-file
     [ save-bitmap ]
     [ md5 checksum-file ] bi = ;
@@ -47,5 +39,6 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
         $ test-41
         $ test-42
         $ test-43
+        $ test-bitmap24
     } [ test-bitmap-save ] all?
 ] unit-test

basis/images/images.factor

@@ -3,7 +3,7 @@
 USING: combinators kernel accessors ;
 IN: images
 
-SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
 R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
 
 UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
@@ -11,6 +11,7 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
 : bytes-per-pixel ( component-order -- n )
     {
         { L [ 1 ] }
+        { LA [ 2 ] }
         { BGR [ 3 ] }
         { RGB [ 3 ] }
         { BGRA [ 4 ] }
@@ -33,4 +34,4 @@ 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 tuple -- image )

basis/images/loader/loader.factor

@@ -1,8 +1,7 @@
 ! 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 images.normalization
-io.pathnames ;
+accessors images.bitmap images.tiff images io.pathnames ;
 IN: images.loader
 
 ERROR: unknown-image-extension extension ;
@@ -16,4 +15,4 @@ ERROR: unknown-image-extension extension ;
     } case ;
 
 : load-image ( path -- image )
-    dup image-class new load-image* normalize-image ;
+    dup image-class new load-image* ;

basis/images/tiff/tiff.factor

@@ -463,6 +463,7 @@ ERROR: unknown-component-order ifd ;
         { { 16 16 16 } [ 2 seq>native-endianness ] }
         { { 8 8 8 8 } [ ] }
         { { 8 8 8 } [ ] }
+        { 8 [ ] }
         [ unknown-component-order ]
     } case >>bitmap ;
 
@@ -474,11 +475,11 @@ ERROR: unknown-component-order ifd ;
         { { 16 16 16 } [ R16G16B16 ] }
         { { 8 8 8 8 } [ RGBA ] }
         { { 8 8 8 } [ RGB ] }
+        { 8 [ LA ] }
         [ unknown-component-order ]
     } case ;
 
 : normalize-alpha-data ( seq -- byte-array )
-    ! [ normalize-alpha-data ] change-bitmap
     B{ } like dup
     byte-array>float-array
     4 <sliced-groups>

basis/opengl/capabilities/capabilities.factor

@@ -32,6 +32,8 @@ IN: opengl.capabilities
     (gl-version) drop ;
 : gl-vendor-version ( -- version )
     (gl-version) nip ;
+: gl-vendor ( -- name )
+    GL_VENDOR glGetString ;
 : has-gl-version? ( version -- ? )
     gl-version version-before? ;
 : (make-gl-version-error) ( required-version -- )

basis/opengl/textures/textures.factor

@@ -1,13 +1,23 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs cache colors.constants destructors fry kernel
-opengl opengl.gl combinators images images.tesselation grouping
-specialized-arrays.float sequences math math.vectors
-math.matrices generalizations fry arrays namespaces ;
+opengl opengl.gl opengl.capabilities combinators images
+images.tesselation grouping specialized-arrays.float sequences math
+math.vectors math.matrices generalizations fry arrays namespaces
+system ;
 IN: opengl.textures
 
 SYMBOL: non-power-of-2-textures?
 
+: check-extensions ( -- )
+    #! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly.
+    #! See thread 'Linux font display problem' April 2009 on Factor-talk
+    gl-vendor "ATI Technologies Inc." = not os macosx? or [
+        "2.0" { "GL_ARB_texture_non_power_of_two" }
+        has-gl-version-or-extensions?
+        non-power-of-2-textures? set
+    ] when ;
+
 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
 
 : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
@@ -20,6 +30,8 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
 M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
 M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
 M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
+M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ;
+M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ;
 
 SLOT: display-list
 
@@ -163,4 +175,4 @@ PRIVATE>
 : <texture> ( image loc -- texture )
     over dim>> max-texture-size [ <= ] 2all?
     [ <single-texture> ]
-    [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
+    [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;

basis/ui/backend/cocoa/cocoa.factor

@@ -70,8 +70,8 @@ M:: cocoa-ui-backend (open-window) ( world -- )
     world dim>> <FactorView> :> view
     view world world>NSRect <ViewWindow> :> window
     view -> release
-    window world window-loc>> auto-position
     world view register-window
+    window world window-loc>> auto-position
     world window save-position
     window install-window-delegate
     view window <window-handle> world (>>handle)

basis/ui/backend/cocoa/views/views.factor

@@ -336,7 +336,7 @@ CLASS: {
 
 ! Initialization
 { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
-    [ 2drop dup view-dim swap window (>>dim) yield ]
+    [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
 }
 
 { "doCommandBySelector:" "void" { "id" "SEL" "SEL" }

basis/ui/gadgets/worlds/worlds.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs continuations kernel math models
-namespaces opengl opengl.capabilities opengl.textures sequences io
-combinators combinators.short-circuit fry math.vectors math.rectangles
-cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
+namespaces opengl opengl.textures sequences io combinators
+combinators.short-circuit fry math.vectors math.rectangles cache
+ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
 ui.commands ;
 IN: ui.gadgets.worlds
 
@@ -77,10 +77,6 @@ SYMBOL: flush-layout-cache-hook
 
 flush-layout-cache-hook [ [ ] ] initialize
 
-: check-extensions ( -- )
-    "2.0" { "GL_ARB_texture_non_power_of_two" } has-gl-version-or-extensions?
-    non-power-of-2-textures? set ;
-
 : (draw-world) ( world -- )
     dup handle>> [
         check-extensions

basis/ui/ui.factor

@@ -12,7 +12,10 @@ IN: ui
 ! Assoc mapping aliens to gadgets
 SYMBOL: windows
 
-: window ( handle -- world ) windows get-global at ;
+ERROR: no-window handle ;
+
+: window ( handle -- world )
+    windows get-global ?at [ no-window ] unless ;
 
 : window-focus ( handle -- gadget ) window world-focus ;
 

basis/urls/encoding/encoding-tests.factor

@@ -26,3 +26,7 @@ USING: urls.encoding tools.test arrays kernel assocs present accessors ;
 [ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
 
 [ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
+
+[ "a" ] [ { { "a" f } } assoc>query ] unit-test
+
+[ H{ { "a" f } } ] [ "a" query>assoc ] unit-test

basis/urls/encoding/encoding.factor

@@ -72,6 +72,15 @@ PRIVATE>
         ] when*
     ] 2keep set-at ;
 
+: assoc-strings ( assoc -- assoc' )
+    [
+        {
+            { [ dup not ] [ ] }
+            { [ dup array? ] [ [ present ] map ] }
+            [ present 1array ]
+        } cond
+    ] assoc-map ;
+
 PRIVATE>
 
 : query>assoc ( query -- assoc )
@@ -86,11 +95,8 @@ PRIVATE>
 
 : assoc>query ( assoc -- str )
     [
-        dup array? [ [ present ] map ] [ present 1array ] if
-    ] assoc-map
-    [
-        [
+        assoc-strings [
             [ url-encode ] dip
-            [ url-encode "=" glue , ] with each
+            [ [ url-encode "=" glue , ] with each ] [ , ] if*
         ] assoc-each
     ] { } make "&" join ;

basis/urls/urls-tests.factor

@@ -80,6 +80,15 @@ CONSTANT: urls
             }
             "ftp://slava:secret@ftp.kernel.org/"
         }
+        {
+            T{ url
+               { protocol "http" }
+               { host "foo.com" }
+               { path "/" }
+               { query H{ { "a" f } } }
+            }
+            "http://foo.com/?a"
+        }
     }
 
 urls [

basis/windows/uniscribe/uniscribe.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs math sequences fry io.encodings.string
-io.encodings.utf16n accessors arrays combinators destructors locals
-cache namespaces init images.normalization fonts alien.c-types
-windows windows.usp10 windows.offscreen windows.gdi32
-windows.ole32 windows.types windows.fonts opengl.textures ;
+io.encodings.utf16n accessors arrays combinators destructors
+cache namespaces init fonts alien.c-types windows windows.usp10
+windows.offscreen windows.gdi32 windows.ole32 windows.types
+windows.fonts opengl.textures locals ;
 IN: windows.uniscribe
 
 TUPLE: script-string font string metrics ssa size image disposed ;
@@ -112,4 +112,4 @@ SYMBOL: cached-script-strings
     cached-script-strings get-global [ <script-string> ] 2cache ;
 
 [ <cache-assoc> cached-script-strings set-global ]
-"windows.uniscribe" add-init-hook
+"windows.uniscribe" add-init-hook

core/classes/tuple/tuple-docs.factor

@@ -92,7 +92,7 @@ ARTICLE: "tuple-constructors" "Tuple constructors"
 $nl
 "Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple with initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "."
 $nl
-"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
+"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construct a different class, without breaking callers."
 $nl
 "Examples of constructors:"
 { $code
@@ -220,13 +220,13 @@ ARTICLE: "tuple-examples" "Tuple examples"
     "    <employee> \"project manager\" >>position ;" }
 "An alternative strategy is to define the most general BOA constructor first:"
 { $code
-    ": <employee> ( name position -- person )"
+    ": <employee> ( name position -- employee )"
     "    40000 employee boa ;"
 }
 "Now we can define more specific constructors:"
 { $code
-    ": <manager> ( name -- person )"
-    "    \"manager\" <person> ;" }
+    ": <manager> ( name -- employee )"
+    "    \"manager\" <employee> ;" }
 "An example using reader words:"
 { $code
     "TUPLE: check to amount number ;"
@@ -256,7 +256,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
     ": next-position ( role -- newrole )"
     "    positions [ index 1+ ] keep nth ;"
     ""
-    ": promote ( person -- person )"
+    ": promote ( employee -- employee )"
     "    [ 1.2 * ] change-salary"
     "    [ next-position ] change-position ;"
 }