ui.gadgets.canvas ui.render ui splitting combinators tools.time
system combinators.lib float-arrays continuations
opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
-bunny.cel-shaded bunny.outlined bunny.model ;
+bunny.cel-shaded bunny.outlined bunny.model accessors ;
IN: bunny
TUPLE: bunny-gadget model geom draw-seq draw-n ;
} bunny-gadget construct ;
: bunny-gadget-draw ( gadget -- draw )
- { bunny-gadget-draw-n bunny-gadget-draw-seq }
+ { draw-n>> draw-seq>> }
get-slots nth ;
: bunny-gadget-next-draw ( gadget -- )
- dup { bunny-gadget-draw-seq bunny-gadget-draw-n }
+ dup { draw-seq>> draw-n>> }
get-slots
1+ swap length mod
- swap [ set-bunny-gadget-draw-n ] keep relayout-1 ;
+ >>draw-n relayout-1 ;
M: bunny-gadget graft* ( gadget -- )
GL_DEPTH_TEST glEnable
- dup bunny-gadget-model <bunny-geom>
- over {
- [ <bunny-fixed-pipeline> ]
- [ <bunny-cel-shaded> ]
- [ <bunny-outlined> ]
- } map-call-with [ ] subset
- 0
- roll {
- set-bunny-gadget-geom
- set-bunny-gadget-draw-seq
- set-bunny-gadget-draw-n
- } set-slots ;
+ dup model>> <bunny-geom> >>geom
+ dup
+ [ <bunny-fixed-pipeline> ]
+ [ <bunny-cel-shaded> ]
+ [ <bunny-outlined> ] tri 3array
+ [ ] subset >>draw-seq
+ 0 >>draw-n
+ drop ;
M: bunny-gadget ungraft* ( gadget -- )
- { bunny-gadget-geom bunny-gadget-draw-seq } get-slots
- [ [ dispose ] when* ] each
- [ dispose ] when* ;
+ [ geom>> [ dispose ] when* ]
+ [ draw-seq>> [ [ dispose ] when* ] each ] bi ;
M: bunny-gadget draw-gadget* ( gadget -- )
0.15 0.15 0.15 1.0 glClearColor
dup demo-gadget-set-matrices
GL_MODELVIEW glMatrixMode
0.02 -0.105 0.0 glTranslatef
- { bunny-gadget-geom bunny-gadget-draw } get-slots
+ { geom>> bunny-gadget-draw } get-slots
draw-bunny ;
M: bunny-gadget pref-dim* ( gadget -- dim )
dup bunny-outlined-gadget rect-dim
over bunny-outlined-framebuffer-dim
over =
- [ 2drop ]
- [
+ [ 2drop ] [
swap dup dispose-framebuffer >r
dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
} [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ;
M: bunny-outlined draw-bunny
- dup remake-framebuffer-if-needed
- [ (pass1) ] keep (pass2) ;
+ [ remake-framebuffer-if-needed ]
+ [ (pass1) ]
+ [ (pass2) ] tri ;
M: bunny-outlined dispose
- {
- [ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
- [ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
- [ dispose-framebuffer ]
- } cleave ;
+ [ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
+ [ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
+ [ dispose-framebuffer ] tri ;
USING: arrays combinators.lib kernel math math.functions math.vectors namespaces
- opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ;
+ opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render accessors ;
IN: opengl.demo-support
-: NEAR-PLANE 1.0 64.0 / ; inline
-: FAR-PLANE 4.0 ; inline
: FOV 2.0 sqrt 1+ ; inline
: MOUSE-MOTION-SCALE 0.5 ; inline
-: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline
: KEY-ROTATE-STEP 1.0 ; inline
-: KEY-DISTANCE-STEP 1.0 64.0 / ; inline
-: DIMS { 640 480 } ; inline
-
-: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ;
SYMBOL: last-drag-loc
: <demo-gadget> ( yaw pitch distance -- gadget )
demo-gadget construct-gadget
- [ { set-demo-gadget-yaw set-demo-gadget-pitch set-demo-gadget-distance } set-slots ] keep ;
+ [ { (>>yaw) (>>pitch) (>>distance) } set-slots ] keep ;
+
+GENERIC: far-plane ( gadget -- z )
+GENERIC: near-plane ( gadget -- z )
+GENERIC: distance-step ( gadget -- dz )
+
+M: demo-gadget far-plane ( gadget -- z )
+ drop 4.0 ;
+M: demo-gadget near-plane ( gadget -- z )
+ drop 1.0 64.0 / ;
+M: demo-gadget distance-step ( gadget -- dz )
+ drop 1.0 64.0 / ;
+
+: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
: yaw-demo-gadget ( yaw gadget -- )
[ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ;
[ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ;
M: demo-gadget pref-dim* ( gadget -- dim )
- drop DIMS ;
+ drop { 640 480 } ;
: -+ ( x -- -x x )
dup neg swap ;
-: demo-gadget-frustum ( -- -x x -y y near far )
- FOV-RATIO NEAR-PLANE FOV / v*n
- first2 [ -+ ] bi@ NEAR-PLANE FAR-PLANE ;
+: demo-gadget-frustum ( gadget -- -x x -y y near far )
+ [ near-plane ] [ far-plane ] [ fov-ratio ] tri [
+ nip swap FOV / v*n
+ first2 [ -+ ] bi@
+ ] 3keep drop ;
: demo-gadget-set-matrices ( gadget -- )
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- demo-gadget-frustum glFrustum
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- GL_MODELVIEW glMatrixMode
- glLoadIdentity
- [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ]
- [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ]
- [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ]
- tri ;
+ [
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ demo-gadget-frustum glFrustum
+ ] [
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ [ >r 0.0 0.0 r> distance>> neg glTranslatef ]
+ [ pitch>> 1.0 0.0 0.0 glRotatef ]
+ [ yaw>> 0.0 1.0 0.0 glRotatef ]
+ tri
+ ] bi ;
: reset-last-drag-rel ( -- )
{ 0 0 } last-drag-loc set-global ;
{ T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] }
{ T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] }
{ T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] }
- { T{ key-down f f "=" } [ KEY-DISTANCE-STEP neg swap zoom-demo-gadget ] }
- { T{ key-down f f "-" } [ KEY-DISTANCE-STEP swap zoom-demo-gadget ] }
+ { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-gadget ] }
+ { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-gadget ] }
{ T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
{ T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
- { T{ mouse-scroll } [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-demo-gadget ] }
+ { T{ mouse-scroll } [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
} set-gestures
--- /dev/null
+USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
+opengl multiline ui.gadgets accessors sequences ui.render ui math
+arrays arrays.lib combinators ;
+IN: spheres
+
+STRING: plane-vertex-shader
+varying vec3 object_position;
+void
+main()
+{
+ object_position = gl_Vertex.xyz;
+ gl_Position = ftransform();
+}
+;
+
+STRING: plane-fragment-shader
+varying vec3 object_position;
+void
+main()
+{
+ float distance_factor = (gl_FragCoord.z * 0.5 + 0.5);
+ distance_factor = pow(distance_factor, 500.0)*0.5;
+
+ gl_FragColor = fract((floor(0.125*object_position.x)+floor(0.125*object_position.z)) * 0.5) == 0.0
+ ? vec4(1.0, 1.0 - distance_factor, 1.0 - distance_factor, 1.0)
+ : vec4(1.0, distance_factor, distance_factor, 1.0);
+}
+;
+
+STRING: sphere-vertex-shader
+attribute vec3 center;
+attribute float radius;
+attribute vec4 surface_color;
+varying float vradius;
+varying vec3 sphere_position;
+varying vec4 world_position, vcolor;
+
+void
+main()
+{
+ world_position = gl_ModelViewMatrix * vec4(center, 1);
+ sphere_position = gl_Vertex.xyz;
+
+ gl_Position = gl_ProjectionMatrix * (world_position + vec4(sphere_position * radius, 0));
+
+ vcolor = surface_color;
+ vradius = radius;
+}
+;
+
+STRING: sphere-solid-color-fragment-shader
+uniform vec3 light_position;
+varying vec4 vcolor;
+
+const vec4 ambient = vec4(0.25, 0.2, 0.25, 1.0);
+const vec4 diffuse = vec4(0.75, 0.8, 0.75, 1.0);
+
+vec4
+sphere_color(vec3 point, vec3 normal)
+{
+ vec3 transformed_light_position = (gl_ModelViewMatrix * vec4(light_position, 1)).xyz;
+ vec3 direction = normalize(transformed_light_position - point);
+ float d = max(0.0, dot(normal, direction));
+
+ return ambient * vcolor + diffuse * vec4(d * vcolor.rgb, vcolor.a);
+}
+;
+
+STRING: sphere-texture-fragment-shader
+uniform samplerCube surface_texture;
+
+vec4
+sphere_color(vec3 point, vec3 normal)
+{
+ vec3 reflect = reflect(normalize(point), normal);
+ return textureCube(surface_texture, reflect * gl_NormalMatrix);
+}
+;
+
+STRING: sphere-main-fragment-shader
+varying float vradius;
+varying vec3 sphere_position;
+varying vec4 world_position;
+
+vec4 sphere_color(vec3 point, vec3 normal);
+
+void
+main()
+{
+ float radius = length(sphere_position);
+ if(radius > 1.0) discard;
+
+ vec3 surface = sphere_position + vec3(0.0, 0.0, sqrt(1.0 - radius*radius));
+ vec4 world_surface = world_position + vec4(surface * vradius, 0);
+ vec4 transformed_surface = gl_ProjectionMatrix * world_surface;
+
+ gl_FragDepth = (transformed_surface.z/transformed_surface.w + 1.0) * 0.5;
+ gl_FragColor = sphere_color(world_surface.xyz, surface);
+}
+;
+
+TUPLE: spheres-gadget
+ plane-program solid-sphere-program texture-sphere-program
+ reflection-framebuffer reflection-depthbuffer
+ reflection-texture ;
+
+: <spheres-gadget> ( -- gadget )
+ 0.0 0.0 20.0 <demo-gadget>
+ { set-delegate } spheres-gadget construct ;
+
+M: spheres-gadget near-plane ( gadget -- z )
+ drop 1.0 ;
+M: spheres-gadget far-plane ( gadget -- z )
+ drop 512.0 ;
+M: spheres-gadget distance-step ( gadget -- dz )
+ drop 0.5 ;
+
+: (reflection-dim) ( -- w h )
+ 1024 1024 ;
+
+: (make-reflection-texture) ( -- texture )
+ gen-texture [
+ GL_TEXTURE_CUBE_MAP swap glBindTexture
+ GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
+ GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+ GL_TEXTURE_CUBE_MAP_POSITIVE_X
+ GL_TEXTURE_CUBE_MAP_POSITIVE_Y
+ GL_TEXTURE_CUBE_MAP_POSITIVE_Z
+ GL_TEXTURE_CUBE_MAP_NEGATIVE_X
+ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
+ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray
+ [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ]
+ each
+ ] keep ;
+
+: (make-reflection-depthbuffer) ( -- depthbuffer )
+ gen-renderbuffer [
+ GL_RENDERBUFFER_EXT swap glBindRenderbufferEXT
+ GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 (reflection-dim) glRenderbufferStorageEXT
+ ] keep ;
+
+: (make-reflection-framebuffer) ( depthbuffer -- framebuffer )
+ gen-framebuffer dup [
+ swap >r
+ GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT r>
+ glFramebufferRenderbufferEXT
+ ] with-framebuffer ;
+
+: (plane-program) ( -- program )
+ plane-vertex-shader plane-fragment-shader <simple-gl-program> ;
+: (solid-sphere-program) ( -- program )
+ sphere-vertex-shader <vertex-shader> check-gl-shader
+ sphere-solid-color-fragment-shader <fragment-shader> check-gl-shader
+ sphere-main-fragment-shader <fragment-shader> check-gl-shader
+ 3array <gl-program> check-gl-program ;
+: (texture-sphere-program) ( -- program )
+ sphere-vertex-shader <vertex-shader> check-gl-shader
+ sphere-texture-fragment-shader <fragment-shader> check-gl-shader
+ sphere-main-fragment-shader <fragment-shader> check-gl-shader
+ 3array <gl-program> check-gl-program ;
+
+M: spheres-gadget graft* ( gadget -- )
+ (plane-program) >>plane-program
+ (solid-sphere-program) >>solid-sphere-program
+ (texture-sphere-program) >>texture-sphere-program
+ (make-reflection-texture) >>reflection-texture
+ (make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep
+ (make-reflection-framebuffer) >>reflection-framebuffer
+ drop ;
+
+M: spheres-gadget ungraft* ( gadget -- )
+ {
+ [ reflection-framebuffer>> [ delete-framebuffer ] when* ]
+ [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ]
+ [ reflection-texture>> [ delete-texture ] when* ]
+ [ solid-sphere-program>> [ delete-gl-program ] when* ]
+ [ texture-sphere-program>> [ delete-gl-program ] when* ]
+ [ plane-program>> [ delete-gl-program ] when* ]
+ } cleave ;
+
+M: spheres-gadget pref-dim* ( gadget -- dim )
+ drop { 640 480 } ;
+
+: (draw-sphere) ( program center radius surfacecolor -- )
+ roll
+ [ [ "center" glGetAttribLocation swap first3 glVertexAttrib3f ] curry ]
+ [ [ "radius" glGetAttribLocation swap glVertexAttrib1f ] curry ]
+ [ [ "surface_color" glGetAttribLocation swap first4 glVertexAttrib4f ] curry ]
+ tri tri*
+ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ;
+
+: 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 ] }
+ } [
+ {
+ [ { 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) ]
+ [ { 0.0 0.0 -7.0 } 1.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ]
+ [ { 0.0 7.0 0.0 } 1.0 { 1.0 0.0 1.0 1.0 } (draw-sphere) ]
+ [ { 0.0 -7.0 0.0 } 1.0 { 0.0 1.0 1.0 1.0 } (draw-sphere) ]
+ } cleave
+ ] with-gl-program
+ ] [
+ plane-program>> { } [
+ GL_QUADS [
+ -1000.0 -30.0 1000.0 glVertex3f
+ -1000.0 -30.0 -1000.0 glVertex3f
+ 1000.0 -30.0 -1000.0 glVertex3f
+ 1000.0 -30.0 1000.0 glVertex3f
+ ] do-state
+ ] with-gl-program
+ ] bi ;
+
+: reflection-frustum ( gadget -- -x x -y y near far )
+ [ near-plane ] [ far-plane ] bi [
+ drop dup [ -+ ] bi@
+ ] 2keep ;
+
+: (reflection-face) ( gadget face -- )
+ swap reflection-texture>> >r >r
+ GL_FRAMEBUFFER_EXT
+ GL_COLOR_ATTACHMENT0_EXT
+ r> r> 0 glFramebufferTexture2DEXT
+ check-framebuffer ;
+
+: (draw-reflection-texture) ( gadget -- )
+ dup reflection-framebuffer>> [ {
+ [ drop 0 0 (reflection-dim) glViewport ]
+ [
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ reflection-frustum glFrustum
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ 180.0 0.0 0.0 1.0 glRotatef
+ ]
+ [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z (reflection-face) ]
+ [ sphere-scene ]
+ [ GL_TEXTURE_CUBE_MAP_POSITIVE_X (reflection-face)
+ 90.0 0.0 1.0 0.0 glRotatef ]
+ [ sphere-scene ]
+ [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z (reflection-face)
+ 90.0 0.0 1.0 0.0 glRotatef glPushMatrix ]
+ [ sphere-scene ]
+ [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X (reflection-face)
+ 90.0 0.0 1.0 0.0 glRotatef ]
+ [ sphere-scene ]
+ [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y (reflection-face)
+ glPopMatrix glPushMatrix -90.0 1.0 0.0 0.0 glRotatef ]
+ [ sphere-scene ]
+ [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face)
+ glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ]
+ [ sphere-scene ]
+ [ dim>> 0 0 rot first2 glViewport ]
+ } cleave ] with-framebuffer ;
+
+M: spheres-gadget draw-gadget* ( gadget -- )
+ GL_DEPTH_TEST glEnable
+ GL_SCISSOR_TEST glDisable
+ 0.15 0.15 1.0 1.0 glClearColor {
+ [ (draw-reflection-texture) ]
+ [ demo-gadget-set-matrices ]
+ [ sphere-scene ]
+ [
+ { texture-sphere-program>> reflection-texture>> } get-slots
+ GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit
+ dup {
+ { "surface_texture" [ 0 glUniform1i ] }
+ } [
+ { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere)
+ ] with-gl-program
+ ]
+ } cleave ;
+
+: spheres-window ( -- )
+ [ <spheres-gadget> "Spheres" open-window ] with-ui ;
+
+MAIN: spheres-window
--- /dev/null
+Draw pixel-perfect spheres using GLSL shaders
\ No newline at end of file
--- /dev/null
+opengl
+glsl
\r
HELP: com-query-interface\r
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } }\r
-{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be immediately retained using " { $link com-add-ref } ". The pointer must then be released using " { $link com-release } " when it is no longer needed." } ;\r
+{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be released using " { $link com-release } " when it is no longer needed." } ;\r
\r
HELP: com-add-ref\r
{ $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } }\r
-USING: kernel windows.com windows.com.syntax windows.ole32\r
-alien alien.syntax tools.test libc alien.c-types arrays.lib \r
-namespaces arrays continuations ;\r
-IN: windows.com.tests\r
-\r
-! Create some test COM interfaces\r
-\r
-COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}\r
- HRESULT returnOK ( )\r
- HRESULT returnError ( ) ;\r
-\r
-COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}\r
- int getX ( )\r
- void setX ( int newX ) ;\r
-\r
-! Implement the IInherited interface in factor using alien-callbacks\r
-\r
-C-STRUCT: test-implementation\r
- { "void*" "vtbl" }\r
- { "int" "x" } ;\r
-\r
-: QueryInterface-callback\r
- "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 swap set-void*-nth S_OK ]\r
- alien-callback ;\r
-: AddRef-callback\r
- "ULONG" { "void*" } "stdcall" [ drop 2 ]\r
- alien-callback ;\r
-: Release-callback\r
- "ULONG" { "void*" } "stdcall" [ drop 1 ]\r
- alien-callback ;\r
-: returnOK-callback\r
- "HRESULT" { "void*" } "stdcall" [ drop S_OK ]\r
- alien-callback ;\r
-: returnError-callback\r
- "HRESULT" { "void*" } "stdcall" [ drop E_FAIL ]\r
- alien-callback ;\r
-: getX-callback\r
- "int" { "void*" } "stdcall" [ test-implementation-x ]\r
- alien-callback ;\r
-: setX-callback\r
- "void" { "void*" "int" } "stdcall" [ swap set-test-implementation-x ]\r
- alien-callback ;\r
-\r
-SYMBOL: +test-implementation-vtbl+\r
-SYMBOL: +guinea-pig-implementation+\r
-\r
-: (make-test-implementation) ( x imp -- imp )\r
- [ set-test-implementation-x ] keep\r
- +test-implementation-vtbl+ get over set-test-implementation-vtbl ;\r
-\r
-: <test-implementation> ( x -- imp )\r
- "test-implementation" <c-object> (make-test-implementation) ;\r
-\r
-: <malloced-test-implementation> ( x -- imp )\r
- "test-implementation" heap-size malloc (make-test-implementation) ;\r
-\r
-QueryInterface-callback\r
-AddRef-callback\r
-Release-callback\r
-returnOK-callback\r
-returnError-callback\r
-getX-callback\r
-setX-callback\r
-7 narray >c-void*-array\r
-dup byte-length [\r
- [ byte-array>memory ] keep\r
- +test-implementation-vtbl+ set\r
-\r
- ! Test that the words defined by COM-INTERFACE: do their magic\r
-\r
- "{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test\r
- "{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test\r
- "{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test\r
- S_OK 1array [ 0 <test-implementation> ISimple::returnOK ] unit-test\r
- E_FAIL <long> *long 1array [ 0 <test-implementation> ISimple::returnError ] unit-test\r
- 1984 1array [ 0 <test-implementation> dup 1984 IInherited::setX IInherited::getX ] unit-test\r
-\r
- ! Test that the helper functions for QueryInterface, AddRef, Release work\r
-\r
- 0 <malloced-test-implementation> +guinea-pig-implementation+ set\r
- [\r
- +guinea-pig-implementation+ get 1array [\r
- +guinea-pig-implementation+ get com-add-ref\r
- ] unit-test\r
-\r
- { } [ +guinea-pig-implementation+ get com-release ] unit-test\r
-\r
- +guinea-pig-implementation+ get 1array [\r
- +guinea-pig-implementation+ get IUnknown-iid com-query-interface\r
- ] unit-test\r
-\r
- ] [ +guinea-pig-implementation+ get free ] [ ] cleanup\r
-] with-malloc\r
+USING: kernel windows.com windows.com.syntax windows.ole32
+alien alien.syntax tools.test libc alien.c-types arrays.lib
+namespaces arrays continuations accessors math windows.com.wrapper
+windows.com.wrapper.private ;
+IN: windows.com.tests
+
+COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}
+ HRESULT returnOK ( )
+ HRESULT returnError ( ) ;
+
+COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}
+ int getX ( )
+ void setX ( int newX ) ;
+
+COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}
+ int xPlus ( int y )
+ int xMulAdd ( int mul, int add ) ;
+
+"{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test
+"{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test
+"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test
+"{b06ac3f4-30e4-406b-a7cd-c29cead4552c}" string>guid 1array [ IUnrelated-iid ] unit-test
+
+SYMBOL: +test-wrapper+
+SYMBOL: +guinea-pig-implementation+
+SYMBOL: +orig-wrapped-objects+
+
++wrapped-objects+ get-global clone +orig-wrapped-objects+ set-global
+
+TUPLE: test-implementation x ;
+C: <test-implementation> test-implementation
+
+{
+ { "IInherited" {
+ [ drop S_OK ] ! ISimple::returnOK
+ [ drop E_FAIL ] ! ISimple::returnError
+ [ x>> ] ! IInherited::getX
+ [ >>x drop ] ! IInherited::setX
+ } }
+ { "IUnrelated" {
+ [ swap x>> + ] ! IUnrelated::xPlus
+ [ spin x>> * + ] ! IUnrealted::xMulAdd
+ } }
+} <com-wrapper>
+dup +test-wrapper+ set [
+
+ 0 <test-implementation> swap com-wrap
+ dup +guinea-pig-implementation+ set [ drop
+
+ S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test
+ E_FAIL <long> *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test
+ 20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test
+ 420 1array [
+ +guinea-pig-implementation+ get
+ IUnrelated-iid com-query-interface
+ [ 20 20 IUnrelated::xMulAdd ] with-com-interface
+ ] unit-test
+ 40 1array [
+ +guinea-pig-implementation+ get
+ IUnrelated-iid com-query-interface
+ [ 20 IUnrelated::xPlus ] with-com-interface
+ ] unit-test
+
+ +guinea-pig-implementation+ get 1array [
+ +guinea-pig-implementation+ get com-add-ref
+ ] unit-test
+
+ { } [ +guinea-pig-implementation+ get com-release ] unit-test
+
+ +guinea-pig-implementation+ get 1array [
+ +guinea-pig-implementation+ get IUnknown-iid com-query-interface
+ dup com-release
+ ] unit-test
+ +guinea-pig-implementation+ get 1array [
+ +guinea-pig-implementation+ get ISimple-iid com-query-interface
+ dup com-release
+ ] unit-test
+ "void*" heap-size +guinea-pig-implementation+ get <displaced-alien>
+ +guinea-pig-implementation+ get
+ 2array [
+ +guinea-pig-implementation+ get IUnrelated-iid com-query-interface
+ dup ISimple-iid com-query-interface
+ over com-release dup com-release
+ ] unit-test
+
+ ] with-com-interface
+
+] with-disposal
+
+! Ensure that we freed +guinea-pig-implementation
++orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test
USING: alien alien.c-types windows.com.syntax windows.ole32\r
-windows.types continuations kernel ;\r
+windows.types continuations kernel alien.syntax ;\r
IN: windows.com\r
\r
+LIBRARY: ole32\r
+\r
COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046}\r
HRESULT QueryInterface ( REFGUID iid, void** ppvObject )\r
ULONG AddRef ( )\r
ULONG Release ( ) ;\r
\r
+COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046}\r
+ HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )\r
+ HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium )\r
+ HRESULT QueryGetData ( FORMATETC* pFormatetc )\r
+ HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut )\r
+ HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease )\r
+ HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc )\r
+ HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection )\r
+ HRESULT DUnadvise ( DWORD pdwConnection )\r
+ HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ;\r
+\r
+COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}\r
+ HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )\r
+ HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect )\r
+ HRESULT DragLeave ( )\r
+ HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ;\r
+\r
: com-query-interface ( interface iid -- interface' )\r
f <void*>\r
[ IUnknown::QueryInterface ole32-error ] keep\r
IUnknown::Release drop ; inline\r
\r
: with-com-interface ( interface quot -- )\r
- [ keep ] [ com-release ] [ ] cleanup ; inline\r
+ over [ slip ] [ com-release ] [ ] cleanup ; inline\r
: (function-word) ( function interface -- word )\r
name>> "::" rot name>> 3append create-in ;\r
\r
-: all-functions ( definition -- functions )\r
- dup parent>> [ all-functions ] [ { } ] if*\r
+: family-tree ( definition -- definitions )\r
+ dup parent>> [ family-tree ] [ { } ] if*\r
+ swap add ;\r
+\r
+: family-tree-functions ( definition -- functions )\r
+ dup parent>> [ family-tree-functions ] [ { } ] if*\r
swap functions>> append ;\r
\r
: (define-word-for-function) ( function interface n -- )\r
[ [ (iid-word) ] [ iid>> 1quotation ] bi define ]\r
[ name>> "com-interface" swap typedef ]\r
[\r
- dup all-functions\r
+ dup family-tree-functions\r
[ (define-word-for-function) ] with each-index\r
]\r
tri ;\r
--- /dev/null
+Wrap Factor objects with implementations of COM interfaces
--- /dev/null
+windows
+com
+bindings
--- /dev/null
+USING: help.markup help.syntax io kernel math quotations\r
+multiline alien windows.com windows.com.syntax continuations ;\r
+IN: windows.com.wrapper\r
+\r
+HELP: <com-wrapper>\r
+{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } }\r
+{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "<com-wrapper>" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper objects and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" }\r
+{ $code <"\r
+COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc}\r
+ HRESULT returnOK ( )\r
+ HRESULT returnError ( ) ;\r
+\r
+COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd}\r
+ int getX ( )\r
+ void setX ( int newX ) ;\r
+\r
+COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c}\r
+ int xPlus ( int y )\r
+ int xMulAdd ( int mul, int add ) ;\r
+\r
+{\r
+ { "IInherited" {\r
+ [ drop S_OK ] ! ISimple::returnOK\r
+ [ drop E_FAIL ] ! ISimple::returnError\r
+ [ x>> ] ! IInherited::getX\r
+ [ >>x drop ] ! IInherited::setX\r
+ } }\r
+ { "IUnrelated" {\r
+ [ swap x>> + ] ! IUnrelated::xPlus\r
+ [ spin x>> * + ] ! IUnrealted::xMulAdd\r
+ } }\r
+} <com-wrapper>\r
+"> } ;\r
+\r
+HELP: com-wrap\r
+{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } }\r
+{ $description "Allocates a COM object using the implementations in the " { $snippet "wrapper" } " object for the vtables and " { $snippet "object" } " for the \"this\" parameter. The COM object is allocated on the heap with an initial reference count of 1. The object will automatically deallocate itself when its reference count reaches 0 as a result of calling " { $link IUnknown::Release } " or " { $link com-release } " on it.\n\nNote that if " { $snippet "wrapper" } " implements multiple interfaces, you cannot count on the returned COM object pointer implementing any particular interface beyond " { $snippet "IUnknown" } ". You will need to use " { $link com-query-interface } " or " { $link IUnknown::QueryInterface } " to ask the object for the particular interface you need." } ;\r
+\r
+HELP: com-wrapper\r
+{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link <com-wrapper> } " constructor and applied to a Factor object using " { $link com-wrap } "." } ;\r
--- /dev/null
+USING: alien alien.c-types windows.com.syntax
+windows.com.syntax.private windows.com continuations kernel
+sequences.lib namespaces windows.ole32 libc
+assocs accessors arrays sequences quotations combinators
+math combinators.lib words compiler.units ;
+IN: windows.com.wrapper
+
+TUPLE: com-wrapper vtbls freed? ;
+
+<PRIVATE
+
+SYMBOL: +wrapped-objects+
++wrapped-objects+ get-global
+[ H{ } +wrapped-objects+ set-global ]
+unless
+
+: com-unwrap ( wrapped -- object )
+ +wrapped-objects+ get-global at*
+ [ "invalid COM wrapping pointer" throw ] unless ;
+
+: (free-wrapped-object) ( wrapped -- )
+ [ +wrapped-objects+ get-global delete-at ] keep
+ free ;
+
+: (make-query-interface) ( interfaces -- quot )
+ [
+ [ swap 16 memory>byte-array ] %
+ [
+ >r find-com-interface-definition family-tree
+ r> 1quotation [ >r iid>> r> 2array ] curry map
+ ] map-index concat
+ [ f ] add ,
+ \ case ,
+ "void*" heap-size
+ [ * rot <displaced-alien> com-add-ref 0 rot set-void*-nth S_OK ]
+ curry ,
+ [ nip f 0 rot set-void*-nth E_NOINTERFACE ] ,
+ \ if* ,
+ ] [ ] make ;
+
+: (make-add-ref) ( interfaces -- quot )
+ length "void*" heap-size * [ swap <displaced-alien>
+ 0 over ulong-nth
+ 1+ [ 0 rot set-ulong-nth ] keep
+ ] curry ;
+
+: (make-release) ( interfaces -- quot )
+ length "void*" heap-size * [ over <displaced-alien>
+ 0 over ulong-nth
+ 1- [ 0 rot set-ulong-nth ] keep
+ dup zero? [ swap (free-wrapped-object) ] [ nip ] if
+ ] curry ;
+
+: (make-iunknown-methods) ( interfaces -- quots )
+ [ (make-query-interface) ]
+ [ (make-add-ref) ]
+ [ (make-release) ] tri
+ 3array ;
+
+: (thunk) ( n -- quot )
+ dup 0 =
+ [ drop [ ] ]
+ [ "void*" heap-size neg * [ swap <displaced-alien> ] curry ]
+ if ;
+
+: (thunked-quots) ( quots iunknown-methods thunk -- quots' )
+ [ [ swap 2array ] curry map swap ] keep
+ [ com-unwrap ] compose [ swap 2array ] curry map append ;
+
+: compile-alien-callback ( return parameters abi quot -- alien )
+ [ alien-callback ] 4 ncurry
+ [ gensym [ swap define ] keep ] with-compilation-unit
+ execute ;
+
+: (make-vtbl) ( interface-name quots iunknown-methods n -- )
+ (thunk) (thunked-quots)
+ swap find-com-interface-definition family-tree-functions [
+ { return>> parameters>> } get-slots
+ dup length 1- roll [
+ first dup empty?
+ [ 2drop [ ] ]
+ [ swap [ ndip ] 2curry ]
+ if
+ ] [ second ] bi compose
+ "stdcall" swap compile-alien-callback
+ ] 2map >c-void*-array [ byte-length malloc ] keep
+ over byte-array>memory ;
+
+: (make-vtbls) ( implementations -- vtbls )
+ dup [ first ] map (make-iunknown-methods)
+ [ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ;
+
+: (malloc-wrapped-object) ( wrapper -- wrapped-object )
+ vtbls>> length "void*" heap-size *
+ [ "ulong" heap-size + malloc ] keep
+ over <displaced-alien>
+ 1 0 rot set-ulong-nth ;
+
+PRIVATE>
+
+: <com-wrapper> ( implementations -- wrapper )
+ (make-vtbls) f com-wrapper construct-boa ;
+
+M: com-wrapper dispose
+ t >>freed?
+ vtbls>> [ free ] each ;
+
+: com-wrap ( object wrapper -- wrapped-object )
+ dup (malloc-wrapped-object) >r vtbls>> r>
+ [ [ set-void*-nth ] curry each-index ] keep
+ [ +wrapped-objects+ get-global set-at ] keep ;
--- /dev/null
+USING: windows.com windows.com.wrapper combinators\r
+windows.kernel32 windows.ole32 windows.shell32 kernel accessors\r
+prettyprint namespaces ui.tools.listener ui.tools.workspace\r
+alien.c-types alien sequences math ;\r
+IN: windows.dragdrop-listener\r
+\r
+: filenames-from-hdrop ( hdrop -- filenames )\r
+ dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
+ [\r
+ 2dup f 0 DragQueryFile 1+ ! get size of filename buffer\r
+ dup "WCHAR" <c-array>\r
+ [ swap DragQueryFile drop ] keep\r
+ alien>u16-string\r
+ ] with map ;\r
+\r
+: filenames-from-data-object ( data-object -- filenames )\r
+ "FORMATETC" <c-object>\r
+ CF_HDROP over set-FORMATETC-cfFormat\r
+ f over set-FORMATETC-ptd\r
+ DVASPECT_CONTENT over set-FORMATETC-dwAspect\r
+ -1 over set-FORMATETC-lindex\r
+ TYMED_HGLOBAL over set-FORMATETC-tymed\r
+ "STGMEDIUM" <c-object>\r
+ [ IDataObject::GetData ] keep swap succeeded? [\r
+ dup STGMEDIUM-data\r
+ [ filenames-from-hdrop ] with-global-lock\r
+ swap ReleaseStgMedium\r
+ ] [ drop f ] if ;\r
+\r
+TUPLE: listener-dragdrop hWnd last-drop-effect ;\r
+\r
+: <listener-dragdrop> ( hWnd -- object )\r
+ DROPEFFECT_NONE listener-dragdrop construct-boa ;\r
+\r
+SYMBOL: +listener-dragdrop-wrapper+\r
+{\r
+ { "IDropTarget" {\r
+ [ ! DragEnter\r
+ >r 2drop\r
+ filenames-from-data-object\r
+ length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if\r
+ dup 0 r> set-ulong-nth\r
+ >>last-drop-effect drop\r
+ S_OK\r
+ ] [ ! DragOver\r
+ >r 2drop last-drop-effect>> 0 r> set-ulong-nth\r
+ S_OK\r
+ ] [ ! DragLeave\r
+ drop S_OK\r
+ ] [ ! Drop\r
+ >r 2drop nip\r
+ filenames-from-data-object\r
+ dup length 1 = [\r
+ first unparse [ "USE: parser " % % " run-file" % ] "" make\r
+ eval-listener\r
+ DROPEFFECT_COPY\r
+ ] [ 2drop DROPEFFECT_NONE ] if\r
+ 0 r> set-ulong-nth\r
+ S_OK\r
+ ]\r
+ } }\r
+} <com-wrapper> +listener-dragdrop-wrapper+ set-global\r
+\r
+: dragdrop-listener-window ( -- )\r
+ get-workspace parent>> handle>> hWnd>>\r
+ dup <listener-dragdrop>\r
+ +listener-dragdrop-wrapper+ get-global com-wrap\r
+ [ RegisterDragDrop ole32-error ] with-com-interface ;\r
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax windows.types ;
+USING: alien alien.syntax kernel windows.types ;
IN: windows.kernel32
: MAX_PATH 260 ; inline
! FUNCTION: WriteTapemark
! FUNCTION: WTSGetActiveConsoleSessionId
! FUNCTION: ZombifyActCtx
+
+: with-global-lock ( HGLOBAL quot -- )
+ swap [ GlobalLock swap call ] keep GlobalUnlock drop ; inline
\r
LIBRARY: ole32\r
\r
-C-STRUCT: GUID\r
- { "DWORD" "part1" }\r
- { "DWORD" "part2" }\r
- { "DWORD" "part3" }\r
- { "DWORD" "part4" } ;\r
-\r
-TYPEDEF: void* REFGUID\r
+TYPEDEF: GUID* REFGUID\r
TYPEDEF: void* LPUNKNOWN\r
TYPEDEF: wchar_t* LPOLESTR\r
TYPEDEF: wchar_t* LPCOLESTR\r
\r
: S_OK 0 ; inline\r
: S_FALSE 1 ; inline\r
+: E_NOINTERFACE HEX: 80004002 ; inline\r
: E_FAIL HEX: 80004005 ; inline\r
: E_INVALIDARG HEX: 80070057 ; inline\r
\r
: DD_DEFDRAGDELAY 200 ; inline\r
: DD_DEFDRAGMINDIST 2 ; inline\r
\r
-: ole32-error ( n -- )\r
- dup S_OK = [\r
+: CF_TEXT 1 ; inline\r
+: CF_BITMAP 2 ; inline\r
+: CF_METAFILEPICT 3 ; inline\r
+: CF_SYLK 4 ; inline\r
+: CF_DIF 5 ; inline\r
+: CF_TIFF 6 ; inline\r
+: CF_OEMTEXT 7 ; inline\r
+: CF_DIB 8 ; inline\r
+: CF_PALETTE 9 ; inline\r
+: CF_PENDATA 10 ; inline\r
+: CF_RIFF 11 ; inline\r
+: CF_WAVE 12 ; inline\r
+: CF_UNICODETEXT 13 ; inline\r
+: CF_ENHMETAFILE 14 ; inline\r
+: CF_HDROP 15 ; inline\r
+: CF_LOCALE 16 ; inline\r
+: CF_MAX 17 ; inline\r
+\r
+: CF_OWNERDISPLAY HEX: 0080 ; inline\r
+: CF_DSPTEXT HEX: 0081 ; inline\r
+: CF_DSPBITMAP HEX: 0082 ; inline\r
+: CF_DSPMETAFILEPICT HEX: 0083 ; inline\r
+: CF_DSPENHMETAFILE HEX: 008E ; inline\r
+\r
+: DVASPECT_CONTENT 1 ; inline\r
+: DVASPECT_THUMBNAIL 2 ; inline\r
+: DVASPECT_ICON 4 ; inline\r
+: DVASPECT_DOCPRINT 8 ; inline\r
+\r
+: TYMED_HGLOBAL 1 ; inline\r
+: TYMED_FILE 2 ; inline\r
+: TYMED_ISTREAM 4 ; inline\r
+: TYMED_ISTORAGE 8 ; inline\r
+: TYMED_GDI 16 ; inline\r
+: TYMED_MFPICT 32 ; inline\r
+: TYMED_ENHMF 64 ; inline\r
+: TYMED_NULL 0 ; inline\r
+\r
+C-STRUCT: DVTARGETDEVICE\r
+ { "DWORD" "tdSize" }\r
+ { "WORD" "tdDriverNameOffset" }\r
+ { "WORD" "tdDeviceNameOffset" }\r
+ { "WORD" "tdPortNameOffset" }\r
+ { "WORD" "tdExtDevmodeOffset" }\r
+ { "BYTE[1]" "tdData" } ;\r
+\r
+TYPEDEF: WORD CLIPFORMAT\r
+TYPEDEF: POINT POINTL\r
+\r
+C-STRUCT: FORMATETC\r
+ { "CLIPFORMAT" "cfFormat" }\r
+ { "DVTARGETDEVICE*" "ptd" }\r
+ { "DWORD" "dwAspect" }\r
+ { "LONG" "lindex" }\r
+ { "DWORD" "tymed" } ;\r
+TYPEDEF: FORMATETC* LPFORMATETC\r
+\r
+C-STRUCT: STGMEDIUM\r
+ { "DWORD" "tymed" }\r
+ { "void*" "data" }\r
+ { "LPUNKNOWN" "punkForRelease" } ;\r
+TYPEDEF: STGMEDIUM* LPSTGMEDIUM\r
+\r
+: COINIT_MULTITHREADED 0 ; inline\r
+: COINIT_APARTMENTTHREADED 2 ; inline\r
+: COINIT_DISABLE_OLE1DDE 4 ; inline\r
+: COINIT_SPEED_OVER_MEMORY 8 ; inline\r
+\r
+FUNCTION: HRESULT OleInitialize ( void* reserved ) ;\r
+FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;\r
+\r
+FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;\r
+FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;\r
+FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;\r
+\r
+: succeeded? ( hresult -- ? )\r
+ 0 HEX: 7FFFFFFF between? ;\r
+\r
+: ole32-error ( hresult -- )\r
+ dup succeeded? [\r
drop\r
] [ (win32-error-string) throw ] if ;\r
\r
+: ole-initialize ( -- )\r
+ f OleInitialize ole32-error ;\r
+\r
: guid= ( a b -- ? )\r
IsEqualGUID c-bool> ;\r
\r
TYPEDEF: ULONG SFGAOF
+C-STRUCT: DROPFILES
+ { "DWORD" "pFiles" }
+ { "POINT" "pt" }
+ { "BOOL" "fNC" }
+ { "BOOL" "fWide" } ;
+TYPEDEF: DROPFILES* LPDROPFILES
+TYPEDEF: DROPFILES* LPCDROPFILES
+TYPEDEF: HANDLE HDROP
+
C-STRUCT: SHITEMID
{ "USHORT" "cb" }
{ "BYTE[1]" "abID" } ;
FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ;
-FUNCTION: HRESULT StrRetToBufW ( STRRET *pstr, PCUITEMID_CHILD pidl, LPWSTR pszBuf, UINT cchBuf ) ;
-: StrRetToBuf StrRetToBufW ; inline
+FUNCTION: UINT DragQueryFileW ( HDROP hDrop, UINT iFile, LPWSTR lpszFile, UINT cch ) ;
+: DragQueryFile DragQueryFileW ; inline
+
projects / factor.git / commitdiff