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

basis/windows/com/com-tests.factor

@@ -45,7 +45,7 @@ C: <test-implementation> test-implementation
     } }
     { "IUnrelated" {
         [ swap x>> + ] ! IUnrelated::xPlus
-        [ spin x>> * + ] ! IUnrealted::xMulAdd
+        [ spin x>> * + ] ! IUnrelated::xMulAdd
     } }
 } <com-wrapper>
 dup +test-wrapper+ set [

basis/windows/com/wrapper/wrapper.factor

@@ -1,11 +1,11 @@
-USING: alien alien.c-types windows.com.syntax
+USING: alien alien.c-types windows.com.syntax init
 windows.com.syntax.private windows.com continuations kernel
 namespaces windows.ole32 libc vocabs assocs accessors arrays
 sequences quotations combinators math words compiler.units
-destructors fry math.parser generalizations ;
+destructors fry math.parser generalizations sets ;
 IN: windows.com.wrapper
 
-TUPLE: com-wrapper vtbls disposed ;
+TUPLE: com-wrapper callbacks vtbls disposed ;
 
 <PRIVATE
 
@@ -14,6 +14,11 @@ SYMBOL: +wrapped-objects+
 [ H{ } +wrapped-objects+ set-global ]
 unless
 
+SYMBOL: +live-wrappers+
++live-wrappers+ get-global
+[ V{ } +live-wrappers+ set-global ]
+unless
+
 SYMBOL: +vtbl-counter+
 +vtbl-counter+ get-global
 [ 0 +vtbl-counter+ set-global ]
@@ -82,13 +87,12 @@ unless
     [ '[ ,                   [ swap 2array ] curry map ] ] bi bi*
     swap append ;
 
-: compile-alien-callback ( word return parameters abi quot -- alien )
+: compile-alien-callback ( word return parameters abi quot -- word )
     '[ , , , , alien-callback ]
     [ [ (( -- alien )) define-declared ] pick slip ]
-    with-compilation-unit
-    execute ;
+    with-compilation-unit ;
 
-: (byte-array-to-malloced-buffer) ( byte-array -- alien )
+: byte-array>malloc ( byte-array -- alien )
     [ byte-length malloc ] [ over byte-array>memory ] bi ;
 
 : (callback-word) ( function-name interface-name counter -- word )
@@ -99,7 +103,7 @@ unless
     [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
     dip compose ;
 
-: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl )
+: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
     (thunk) (thunked-quots)
     swap [ find-com-interface-definition family-tree-functions ]
     keep (next-vtbl-counter) '[
@@ -114,12 +118,12 @@ unless
             first2 (finish-thunk)
         ] bi*
         "stdcall" swap compile-alien-callback
-    ] 2map >c-void*-array
-    (byte-array-to-malloced-buffer) ;
+    ] 2map ;
 
-: (make-vtbls) ( implementations -- vtbls )
+: (make-callbacks) ( implementations -- sequence )
     dup [ first ] map (make-iunknown-methods)
-    [ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ;
+    [ >r >r first2 r> r> swap (make-interface-callbacks) ]
+    curry map-index ;
 
 : (malloc-wrapped-object) ( wrapper -- wrapped-object )
     vtbls>> length "void*" heap-size *
@@ -127,13 +131,34 @@ unless
     over <displaced-alien>
     1 0 rot set-ulong-nth ;
 
+: (callbacks>vtbl) ( callbacks -- vtbl )
+    [ execute ] map >c-void*-array byte-array>malloc ;
+: (callbacks>vtbls) ( callbacks -- vtbls )
+    [ (callbacks>vtbl) ] map ;
+
+: (allocate-wrapper) ( wrapper -- )
+    dup callbacks>> (callbacks>vtbls) >>vtbls
+    f >>disposed drop ;
+
+: (init-hook) ( -- )
+    +live-wrappers+ get-global [ (allocate-wrapper) ] each
+    H{ } +wrapped-objects+ set-global ;
+
+[ (init-hook) ] "windows.com.wrapper" add-init-hook
+
 PRIVATE>
 
+: allocate-wrapper ( wrapper -- )
+    [ (allocate-wrapper) ]
+    [ +live-wrappers+ get adjoin ] bi ;
+
 : <com-wrapper> ( implementations -- wrapper )
-    (make-vtbls) f com-wrapper boa ;
+    (make-callbacks) f f com-wrapper boa
+    dup allocate-wrapper ;
 
 M: com-wrapper dispose*
-    vtbls>> [ free ] each ;
+    [ [ free ] each f ] change-vtbls
+    +live-wrappers+ get-global delete ;
 
 : com-wrap ( object wrapper -- wrapped-object )
     [ vtbls>> ] [ (malloc-wrapped-object) ] bi

extra/bunny/cel-shaded/cel-shaded.factor

@@ -1,6 +1,6 @@
 USING: arrays bunny.model continuations destructors kernel
 multiline opengl opengl.shaders opengl.capabilities opengl.gl
-sequences sequences.lib accessors ;
+sequences sequences.lib accessors combinators ;
 IN: bunny.cel-shaded
 
 STRING: vertex-shader-source
@@ -78,13 +78,15 @@ TUPLE: bunny-cel-shaded program ;
     ] [ f ] if ;
 
 : (draw-cel-shaded-bunny) ( geom program -- )
-    {
-        { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
-        { "color"           [ 0.6 0.5 0.5 1.0 glUniform4f ] }
-        { "ambient"         [ 0.2 0.2 0.2 0.2 glUniform4f ] }
-        { "diffuse"         [ 0.8 0.8 0.8 0.8 glUniform4f ] }
-        { "shininess"       [ 100.0 glUniform1f ] }
-    } [ bunny-geom ] with-gl-program ;
+    [
+        {
+            [ "light_direction" glGetUniformLocation 1.0 -1.0 1.0 glUniform3f ]
+            [ "color"           glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ]
+            [ "ambient"         glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ]
+            [ "diffuse"         glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ]
+            [ "shininess"       glGetUniformLocation 100.0 glUniform1f ]
+        } cleave bunny-geom
+    ] with-gl-program ;
 
 M: bunny-cel-shaded draw-bunny
     program>> (draw-cel-shaded-bunny) ;

extra/bunny/outlined/outlined.factor

@@ -220,13 +220,14 @@ TUPLE: bunny-outlined
         [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
         [ depth-texture>>  GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
         [
-            pass2-program>> {
-                { "colormap"   [ 0 glUniform1i ] }
-                { "normalmap"  [ 1 glUniform1i ] }
-                { "depthmap"   [ 2 glUniform1i ] }
-                { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
-            } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ]
-            with-gl-program
+            pass2-program>> [
+                {
+                    [ "colormap"   glGetUniformLocation 0 glUniform1i ]
+                    [ "normalmap"  glGetUniformLocation 1 glUniform1i ]
+                    [ "depthmap"   glGetUniformLocation 2 glUniform1i ]
+                    [ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ]
+                } cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
+            ] with-gl-program
         ]
     } cleave ;
 

extra/game-input/backend/backend.factor

@@ -1,8 +1,19 @@
-USING: kernel system combinators parser ;
+USING: multiline system parser combinators ;
 IN: game-input.backend
 
-<< {
-    { [ os macosx? ] [ "game-input.backend.iokit" use+ ] }
-    { [ os windows? ] [ "game-input.backend.dinput" use+ ] }
+STRING: set-backend-for-macosx
+USING: namespaces game-input.backend.iokit game-input ;
+iokit-game-input-backend game-input-backend set-global
+;
+
+STRING: set-backend-for-windows
+USING: namespaces game-input.backend.dinput game-input ;
+dinput-game-input-backend game-input-backend set-global
+;
+
+{
+    { [ os macosx? ] [ set-backend-for-macosx eval ] }
+    { [ os windows? ] [ set-backend-for-windows eval ] }
     { [ t ] [ ] }
-} cond >>
+} cond
+

extra/game-input/backend/dinput/dinput.factor

@@ -206,6 +206,13 @@ M: dinput-game-input-backend (close-game-input)
     close-device-change-window
     delete-dinput ;
 
+M: dinput-game-input-backend (reset-game-input)
+    {
+        +dinput+ +keyboard-device+ +keyboard-state+
+        +controller-devices+ +controller-guids+
+        +device-change-window+ +device-change-handle+
+    } [ f swap set-global ] each ;
+
 M: dinput-game-input-backend get-controllers
     +controller-devices+ get
     [ drop controller boa ] { } assoc>map ;
@@ -278,5 +285,3 @@ M: dinput-game-input-backend read-keyboard
     +keyboard-device+ get
     [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
     [ ] [ f ] with-acquisition ;
-
-dinput-game-input-backend game-input-backend set-global

extra/game-input/backend/iokit/iokit.factor

@@ -231,6 +231,10 @@ M: iokit-game-input-backend (open-game-input)
         ]
     } cleave ;
 
+M: iokit-game-input-backend (reset-game-input)
+    { +hid-manager+ +keyboard-state+ +controller-states+ }
+    [ f swap set-global ] each ;
+
 M: iokit-game-input-backend (close-game-input)
     +hid-manager+ get-global [
         +hid-manager+ global [ 
@@ -271,5 +275,3 @@ M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
 
 M: iokit-game-input-backend calibrate-controller ( controller -- )
     drop ;
-
-iokit-game-input-backend game-input-backend set-global

extra/game-input/game-input.factor

@@ -1,26 +1,34 @@
 USING: arrays accessors continuations kernel symbols
-combinators.lib sequences namespaces init ;
+combinators.lib sequences namespaces init vocabs ;
 IN: game-input
 
 SYMBOLS: game-input-backend game-input-opened ;
 
 HOOK: (open-game-input)  game-input-backend ( -- )
 HOOK: (close-game-input) game-input-backend ( -- )
+HOOK: (reset-game-input) game-input-backend ( -- )
 
 : game-input-opened? ( -- ? )
     game-input-opened get ;
 
 <PRIVATE
 
+M: f (reset-game-input) ;
+
 : reset-game-input ( -- )
-    game-input-opened off ;
+    game-input-opened off
+    (reset-game-input) ;
+
+: load-game-input-backend ( -- )
+    game-input-backend get
+    [ "game-input.backend" load-vocab drop ] unless ;
 
 [ reset-game-input ] "game-input" add-init-hook
 
 PRIVATE>
 
-
 : open-game-input ( -- )
+    load-game-input-backend
     game-input-opened? [
         (open-game-input) 
         game-input-opened on

extra/html/streams/streams.factor

@@ -50,8 +50,8 @@ TUPLE: html-sub-stream < html-stream style parent ;
     ] [ call ] if* ; inline
 
 : hex-color, ( color -- )
-  { [ red>> ] [ green>> ] [ blue>> ] } cleave 3array
-  [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
+    [ red>> ] [ green>> ] [ blue>> ] tri
+    [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
 
 : fg-css, ( color -- )
     "color: #" % hex-color, "; " % ;

extra/irc/ui/ui.factor

@@ -3,7 +3,7 @@
 
 USING: accessors kernel threads combinators concurrency.mailboxes
        sequences strings hashtables splitting fry assocs hashtables colors
-       sorting qualified unicode.case math.order
+       sorting qualified unicode.collation math.order
        ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
        ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
        ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
@@ -76,6 +76,14 @@ M: quit write-irc
     " has left IRC" dark-red write-color
     trailing>> dot-or-parens dark-red write-color ;
 
+M: kick write-irc
+    "* " dark-red write-color
+    [ prefix>> parse-name write ] keep
+    " has kicked " dark-red write-color
+    [ who>> write ] keep
+    " from the channel" dark-red write-color
+    trailing>> dot-or-parens dark-red write-color ;
+
 : full-mode ( message -- mode )
     parameters>> rest " " sjoin ;
 
@@ -126,7 +134,7 @@ M: irc-message write-irc
 GENERIC: handle-inbox ( tab message -- )
 
 : value-labels ( assoc val -- seq )
-    '[ nip , = ] assoc-filter keys [ >lower <=> ] sort [ <label> ] map ;
+    '[ nip , = ] assoc-filter keys sort-strings [ <label> ] map ;
 
 : add-gadget-color ( pack seq color -- pack )
     '[ , >>color add-gadget ] each ;

extra/joystick-demo/joystick-demo.factor

@@ -1,6 +1,6 @@
 USING: ui ui.gadgets sequences kernel arrays math colors
 ui.render math.vectors accessors fry ui.gadgets.packs game-input
-game-input.backend ui.gadgets.labels ui.gadgets.borders alarms
+ui.gadgets.labels ui.gadgets.borders alarms
 calendar locals combinators.lib strings ui.gadgets.buttons
 combinators math.parser assocs threads ;
 IN: joystick-demo

extra/key-caps/key-caps.factor

@@ -1,4 +1,4 @@
-USING: game-input game-input.backend game-input.scancodes
+USING: game-input game-input.scancodes
 kernel ui.gadgets ui.gadgets.buttons sequences accessors
 words arrays assocs math calendar fry alarms ui
 ui.gadgets.borders ui.gestures ;

extra/opengl/shaders/shaders-docs.factor

@@ -95,18 +95,7 @@ HELP: delete-gl-program
 { $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
 
 HELP: with-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } }
-{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack as the associated quotation is called.\n\nExample:" }
-{ $code <"
-! From bunny.cel-shaded
-: (draw-cel-shaded-bunny) ( geom program -- )
-    {
-        { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
-        { "color"           [ 0.6 0.5 0.5 1.0 glUniform4f ] }
-        { "ambient"         [ 0.2 0.2 0.2 0.2 glUniform4f ] }
-        { "diffuse"         [ 0.8 0.8 0.8 0.8 glUniform4f ] }
-        { "shininess"       [ 100.0 glUniform1f ] }
-    } [ bunny-geom ] with-gl-program ;
-"> } ;
+{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation with stack effect " { $snippet "( program -- )" } } }
+{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". " { $snippet "program" } " is left on the top of the stack when " { $snippet "quot" } " is called. The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
 
 ABOUT: "gl-utilities"

extra/opengl/shaders/shaders.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel opengl.gl alien.c-types continuations namespaces
 assocs alien alien.strings libc opengl math sequences combinators
-combinators.lib macros arrays io.encodings.ascii ;
+combinators.lib macros arrays io.encodings.ascii fry ;
 IN: opengl.shaders
 
 : with-gl-shader-source-ptr ( string quot -- )
@@ -107,22 +107,8 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
         2dup detach-gl-program-shader delete-gl-shader
     ] each delete-gl-program-only ;
 
-: (with-gl-program) ( program quot -- )
-    swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
-
-: (with-gl-program-uniforms) ( uniforms -- quot )
-    [ [ swap , \ glGetUniformLocation , % ] [ ] make ]
-    { } assoc>map ;
-: (make-with-gl-program) ( uniforms quot -- q )
-    [
-        \ dup ,
-        [ swap (with-gl-program-uniforms) , \ cleave , % ]
-        [ ] make ,
-        \ (with-gl-program) ,
-    ] [ ] make ;
-
-MACRO: with-gl-program ( uniforms quot -- )
-    (make-with-gl-program) ;
+: with-gl-program ( program quot -- )
+    over glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
 
 PREDICATE: gl-program < integer (gl-program?) ;
 

extra/spheres/spheres.factor

@@ -194,10 +194,9 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
 : sphere-scene ( gadget -- )
     GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
     [
-        solid-sphere-program>> dup {
-            { "light_position" [ 0.0 0.0 100.0 glUniform3f ] }
-        } [
+        solid-sphere-program>> [
             {
+                [ "light_position" glGetUniformLocation 0.0 0.0 100.0 glUniform3f ]
                 [ {  7.0  0.0  0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
                 [ { -7.0  0.0  0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ]
                 [ {  0.0  0.0  7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-sphere) ]
@@ -207,7 +206,8 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
             } cleave
         ] with-gl-program
     ] [
-        plane-program>> { } [
+        plane-program>> [
+            drop
             GL_QUADS [
                 -1000.0 -30.0  1000.0 glVertex3f
                 -1000.0 -30.0 -1000.0 glVertex3f
@@ -269,10 +269,10 @@ M: spheres-gadget draw-gadget* ( gadget -- )
         [ sphere-scene ]
         [ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ]
         [
-            texture-sphere-program>> dup {
-                { "surface_texture" [ 0 glUniform1i ] }
-            } [
-                { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere)
+            texture-sphere-program>> [
+                [ "surface_texture" glGetUniformLocation 0 glUniform1i ]
+                [ { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
+                bi
             ] with-gl-program
         ]
     } cleave ;