From a8231893ec73151cedfc56e5b298b0a51e649842 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:46:42 -0500 Subject: [PATCH 01/15] un-private some useful words --- basis/opengl/textures/textures.factor | 26 ++++++++++++++------------ extra/noise/noise.factor | 6 +++--- 2 files changed, 17 insertions(+), 15 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index d103e90bee..49725d2242 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -39,6 +39,8 @@ SLOT: display-list GENERIC: draw-scaled-texture ( dim texture -- ) +DEFER: make-texture + > first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri glTexSubImage2D ; -: make-texture ( image -- id ) - #! We use glTexSubImage2D to work around the power of 2 texture size - #! limitation - gen-texture [ - GL_TEXTURE_BIT [ - GL_TEXTURE_2D swap glBindTexture - non-power-of-2-textures? get - [ dup bitmap>> (tex-image) ] - [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if - ] do-attribs - ] keep ; - : init-texture ( -- ) GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri @@ -176,6 +166,18 @@ CONSTANT: max-texture-size { 512 512 } PRIVATE> +: make-texture ( image -- id ) + #! We use glTexSubImage2D to work around the power of 2 texture size + #! limitation + gen-texture [ + GL_TEXTURE_BIT [ + GL_TEXTURE_2D swap glBindTexture + non-power-of-2-textures? get + [ dup bitmap>> (tex-image) ] + [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if + ] do-attribs + ] keep ; + : ( image loc -- texture ) over dim>> max-texture-size [ <= ] 2all? [ ] diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index f2ca8ad59b..c28768283c 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -7,6 +7,9 @@ IN: noise : ( -- table ) 256 iota >byte-array randomize dup append ; +: with-seed ( seed quot -- ) + [ ] dip with-random ; inline + ] dip with-random ; inline - : >byte-map ( floats -- bytes ) [ 255.0 * >fixnum ] B{ } map-as ; From 2ba187210eef72382a91f4eadc684dc14810ffa5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:47:05 -0500 Subject: [PATCH 02/15] fix some faux pas in bunny --- extra/bunny/model/model.factor | 2 +- extra/bunny/outlined/outlined.factor | 2 +- extra/opengl/demo-support/demo-support.factor | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 0009e39fa7..3871936902 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -89,7 +89,7 @@ M: bunny-buffers bunny-geom GL_FLOAT 0 0 buffer-offset glNormalPointer [ nv>> "float" heap-size * buffer-offset - 3 GL_FLOAT 0 roll glVertexPointer + [ 3 GL_FLOAT 0 ] dip glVertexPointer ] [ ni>> GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 0ad2a72100..7d614ff947 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -120,7 +120,7 @@ TUPLE: bunny-outlined : outlining-supported? ( -- ? ) "2.0" { - "GL_ARB_shading_objects" + "GL_ARB_shader_objects" "GL_ARB_draw_buffers" "GL_ARB_multitexture" } has-gl-version-or-extensions? { diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 35c64d4ad1..8afbd52647 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,9 +1,9 @@ USING: arrays kernel math math.functions math.order math.vectors namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures -ui.gadgets.worlds ui.render accessors combinators ; +ui.gadgets.worlds ui.render accessors combinators literals ; IN: opengl.demo-support -: FOV ( -- x ) 2.0 sqrt 1+ ; inline +CONSTANT: FOV $[ 2.0 sqrt 1+ ] CONSTANT: MOUSE-MOTION-SCALE 0.5 CONSTANT: KEY-ROTATE-STEP 10.0 From 01546acb1c81de595de2535e6ab25ca309aea34e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:47:26 -0500 Subject: [PATCH 03/15] typo in cocoa pixel format stuff --- basis/ui/backend/cocoa/cocoa.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 5b1b4b0c2a..ef5c80dcdb 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -29,7 +29,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{ { fullscreen { $ NSOpenGLPFAFullScreen } } { windowed { $ NSOpenGLPFAWindow } } { accelerated { $ NSOpenGLPFAAccelerated } } - { software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } } + { software-rendered { $ NSOpenGLPFARendererID $ kCGLRendererGenericFloatID } } { backing-store { $ NSOpenGLPFABackingStore } } { multisampled { $ NSOpenGLPFAMultisample } } { supersampled { $ NSOpenGLPFASupersample } } From e833349ff8f2fdbf8221f020137953522e1fb8b4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:53:56 -0500 Subject: [PATCH 04/15] slow, ugly, unoptimized terrain generation demo --- extra/game-loop/game-loop.factor | 4 +- extra/terrain/generation/generation.factor | 60 +++++++ extra/terrain/shaders/shaders.factor | 46 +++++ extra/terrain/terrain.factor | 190 +++++++++++++++++++++ 4 files changed, 298 insertions(+), 2 deletions(-) create mode 100644 extra/terrain/generation/generation.factor create mode 100644 extra/terrain/shaders/shaders.factor create mode 100644 extra/terrain/terrain.factor diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor index 8e7c7017d4..8abbe6ba25 100644 --- a/extra/game-loop/game-loop.factor +++ b/extra/game-loop/game-loop.factor @@ -1,4 +1,4 @@ -USING: accessors destructors kernel math math.order namespaces +USING: accessors calendar destructors kernel math math.order namespaces system threads ; IN: game-loop @@ -50,7 +50,7 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5 : (run-loop) ( loop -- ) dup running?>> - [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ] + [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ] [ drop ] if ; : run-loop ( loop -- ) diff --git a/extra/terrain/generation/generation.factor b/extra/terrain/generation/generation.factor new file mode 100644 index 0000000000..18f73e8e8b --- /dev/null +++ b/extra/terrain/generation/generation.factor @@ -0,0 +1,60 @@ +USING: accessors arrays byte-arrays combinators fry grouping +images kernel math math.affine-transforms math.order +math.vectors noise random sequences ; +IN: terrain.generation + +CONSTANT: terrain-segment-size { 512 512 } +CONSTANT: terrain-big-noise-scale { 0.002 0.002 } +CONSTANT: terrain-small-noise-scale { 0.05 0.05 } + +TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ; + +: ( -- terrain ) + + 32 random-bits terrain boa ; + +: seed-at ( seed at -- seed' ) + first2 [ + ] dip [ 32 random-bits + ] curry with-seed ; + +: big-noise-segment ( terrain at -- map ) + [ big-noise-table>> terrain-big-noise-scale first2 ] dip + terrain-segment-size [ v* a. ] keep perlin-noise-byte-map ; +: small-noise-segment ( terrain at -- map ) + [ small-noise-table>> terrain-small-noise-scale first2 ] dip + terrain-segment-size [ v* a. ] keep perlin-noise-byte-map ; +: tiny-noise-segment ( terrain at -- map ) + [ tiny-noise-seed>> ] dip seed-at 0.1 + terrain-segment-size normal-noise-byte-map ; + +: padding ( terrain at -- padding ) + 2drop terrain-segment-size product 255 ; + +TUPLE: segment image ; + +: terrain-segment ( terrain at -- image ) + { + [ big-noise-segment ] + [ small-noise-segment ] + [ tiny-noise-segment ] + [ padding ] + } 2cleave + 4array flip concat >byte-array + [ terrain-segment-size RGBA f ] dip image boa ; + +: 4max ( a b c d -- max ) + max max max ; inline + +: mipmap ( {{pixels}} quot: ( aa ab ba bb -- c ) -- pixels' ) + [ [ 2 ] map 2 ] dip + '[ first2 [ [ first2 ] bi@ @ ] 2map ] map ; inline + +: group-pixels ( bitmap dim -- scanlines ) + [ 4 ] [ first ] bi* ; + +: concat-pixels ( scanlines -- bitmap ) + [ concat ] map concat ; + +: segment-mipmap ( image -- image' ) + [ clone ] [ bitmap>> ] [ dim>> ] tri + group-pixels [ 4max ] mipmap concat-pixels >>bitmap + [ 2 v/n ] change-dim ; diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor new file mode 100644 index 0000000000..2dc793f078 --- /dev/null +++ b/extra/terrain/shaders/shaders.factor @@ -0,0 +1,46 @@ +USING: multiline ; +IN: terrain.shaders + +STRING: terrain-vertex-shader + +uniform sampler2D heightmap; + +varying vec2 heightcoords; + +const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0); + +float height(sampler2D map, vec2 coords) +{ + vec4 v = texture2D(map, coords); + return dot(v, COMPONENT_SCALE); +} + +void main() +{ + gl_Position = gl_ModelViewProjectionMatrix + * (gl_Vertex + vec4(0, height(heightmap, gl_Vertex.xz), 0, 0)); + heightcoords = gl_Vertex.xz; +} + +; + +STRING: terrain-pixel-shader + +uniform sampler2D heightmap; + +varying vec2 heightcoords; + +const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0); + +float height(sampler2D map, vec2 coords) +{ + vec4 v = texture2D(map, coords); + return dot(v, COMPONENT_SCALE); +} + +void main() +{ + gl_FragColor = texture2D(heightmap, heightcoords); +} + +; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor new file mode 100644 index 0000000000..725848abb7 --- /dev/null +++ b/extra/terrain/terrain.factor @@ -0,0 +1,190 @@ +USING: accessors arrays combinators game-input +game-input.scancodes game-loop kernel literals locals math +math.constants math.functions math.matrices math.order +math.vectors opengl opengl.capabilities opengl.gl +opengl.shaders opengl.textures opengl.textures.private +sequences sequences.product specialized-arrays.float +terrain.generation terrain.shaders ui ui.gadgets +ui.gadgets.worlds ui.pixel-formats ; +IN: terrain + +CONSTANT: FOV $[ 2.0 sqrt 1+ ] +CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] +CONSTANT: FAR-PLANE 1.0 +CONSTANT: EYE-START { 0.5 0.5 1.2 } +CONSTANT: TICK-LENGTH $[ 1000 30 /i ] +CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] +CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ] + +CONSTANT: terrain-vertex-size { 512 512 } +CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } +CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] + +TUPLE: terrain-world < world + eye yaw pitch + terrain terrain-segment terrain-texture terrain-program + terrain-vertex-buffer + game-loop ; + +: frustum ( dim -- -x x -y y near far ) + dup first2 min v/n + NEAR-PLANE FOV / v*n first2 [ [ neg ] keep ] bi@ + NEAR-PLANE FAR-PLANE ; + +: set-modelview-matrix ( gadget -- ) + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_MODELVIEW glMatrixMode + glLoadIdentity + [ pitch>> 1.0 0.0 0.0 glRotatef ] + [ yaw>> 0.0 1.0 0.0 glRotatef ] + [ eye>> vneg first3 glTranslatef ] tri ; + +: vertex-array-vertex ( x z -- vertex ) + [ terrain-vertex-distance first * ] + [ terrain-vertex-distance second * ] bi* + [ 0 ] dip float-array{ } 3sequence ; + +: vertex-array-row ( z -- vertices ) + dup 1 + 2array + terrain-vertex-size first 1 + iota + 2array [ first2 swap vertex-array-vertex ] product-map + concat ; + +: vertex-array ( -- vertices ) + terrain-vertex-size second iota + [ vertex-array-row ] map concat ; + +: >vertex-buffer ( bytes -- buffer ) + [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW ; + +: draw-vertex-buffer-row ( i -- ) + [ GL_TRIANGLE_STRIP ] dip + terrain-vertex-row-length * terrain-vertex-row-length + glDrawArrays ; + +: draw-vertex-buffer ( buffer -- ) + [ GL_ARRAY_BUFFER ] dip [ + 3 GL_FLOAT 0 f glVertexPointer + terrain-vertex-size second iota [ draw-vertex-buffer-row ] each + ] with-gl-buffer ; + +: degrees ( deg -- rad ) + pi 180.0 / * ; + +:: eye-rotate ( yaw pitch v -- v' ) + yaw degrees neg :> y + pitch degrees neg :> p + y cos :> cosy + y sin :> siny + p cos :> cosp + p sin :> sinp + + cosy 0.0 siny neg 3array + siny sinp * cosp cosy sinp * 3array + siny cosp * sinp neg cosy cosp * 3array 3array + v swap v.m ; + +: forward-vector ( world -- v ) + [ yaw>> ] [ pitch>> ] bi + { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ; +: rightward-vector ( world -- v ) + [ yaw>> ] [ pitch>> ] bi + { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; + +: move-forward ( world -- ) + dup forward-vector [ v+ ] curry change-eye drop ; +: move-backward ( world -- ) + dup forward-vector [ v- ] curry change-eye drop ; +: move-leftward ( world -- ) + dup rightward-vector [ v- ] curry change-eye drop ; +: move-rightward ( world -- ) + dup rightward-vector [ v+ ] curry change-eye drop ; + +: rotate-with-mouse ( world mouse -- ) + [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ] + [ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi + drop ; + +:: handle-input ( world -- ) + read-keyboard keys>> :> keys + key-w keys nth [ world move-forward ] when + key-s keys nth [ world move-backward ] when + key-a keys nth [ world move-leftward ] when + key-d keys nth [ world move-rightward ] when + world read-mouse rotate-with-mouse + reset-mouse ; + +M: terrain-world tick* + [ handle-input ] keep + ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug + drop ; + +M: terrain-world draw* + nip draw-world ; + +: set-heightmap-texture-parameters ( texture -- ) + GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit + GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ; + +M: terrain-world begin-world + "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } + require-gl-version-or-extensions + GL_DEPTH_TEST glEnable + GL_TEXTURE_2D glEnable + GL_VERTEX_ARRAY glEnableClientState + 0.5 0.5 0.5 1.0 glClearColor + EYE-START >>eye + 0.0 >>yaw + 0.0 >>pitch + [ >>terrain ] keep + { 0 0 } terrain-segment [ >>terrain-segment ] keep + make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture + terrain-vertex-shader terrain-pixel-shader + >>terrain-program + vertex-array >vertex-buffer >>terrain-vertex-buffer + TICK-LENGTH over [ >>game-loop ] keep start-loop + reset-mouse + drop ; + +M: terrain-world end-world + { + [ game-loop>> stop-loop ] + [ terrain-vertex-buffer>> delete-gl-buffer ] + [ terrain-program>> delete-gl-program ] + [ terrain-texture>> delete-texture ] + } cleave ; + +M: terrain-world resize-world + GL_PROJECTION glMatrixMode + glLoadIdentity + dim>> [ [ 0 0 ] dip first2 glViewport ] + [ frustum glFrustum ] bi ; + +M: terrain-world draw-world* + [ set-modelview-matrix ] + [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] + [ dup terrain-program>> [ + "heightmap" glGetUniformLocation 0 glUniform1i + terrain-vertex-buffer>> draw-vertex-buffer + ] with-gl-program ] + tri gl-error ; + +M: terrain-world focusable-child* drop t ; +M: terrain-world pref-dim* drop { 640 480 } ; + +: terrain-window ( -- ) + [ + open-game-input + f T{ world-attributes + { world-class terrain-world } + { title "Terrain" } + { pixel-format-attributes { + windowed + double-buffered + T{ depth-bits { value 24 } } + } } + } open-window + ] with-ui ; From 5099046f9fdcc85649d92b4866de7617b4708ef9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 20:52:16 -0500 Subject: [PATCH 05/15] math.miller-rabin: make some utilities not private since math.primes uses them --- basis/math/miller-rabin/miller-rabin.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 9fd604a003..88c01d5271 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -5,8 +5,6 @@ random sequences sets combinators.short-circuit math.bitwise math math.order ; IN: math.miller-rabin -odd ( n -- int ) 0 set-bit ; foldable : >even ( n -- int ) 0 clear-bit ; foldable @@ -15,7 +13,7 @@ IN: math.miller-rabin : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; -TUPLE: positive-even-expected n ; + n-1 From cf9a09b933dcc999335377763631c19eba914248 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 20:52:39 -0500 Subject: [PATCH 06/15] images.viewer: you can now pass a pathname object to image-window and image. words --- extra/images/viewer/viewer.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index b891142d5b..b41dae9b38 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -25,7 +25,7 @@ M: image M: string load-image ; -M: pathname load-image ; +M: pathname string>> load-image ; : image-window ( object -- ) "Image" open-window ; From 3f871d3bae8933197857a7afa891456e3a5fc0ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 21:25:55 -0500 Subject: [PATCH 07/15] io.launcher.windows.nt: update unit tests for recent changes to lines and contents words --- basis/io/launcher/windows/nt/nt-tests.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 53b3d3ce7e..4587556e0c 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests console-vm "-run=listener" 2array >>command +closed+ >>stdin +stdout+ >>stderr - ascii [ input-stream get contents ] with-process-reader + ascii [ contents ] with-process-reader ] unit-test : launcher-test-path ( -- str ) @@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "stderr.factor" 3array >>command "err2.txt" temp-file >>stderr - ascii lines first + ascii stream-lines first ] with-directory ] unit-test @@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests launcher-test-path [ console-vm "-script" "env.factor" 3array >>command - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) os-envs = @@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command +replace-environment+ >>environment-mode os-envs >>environment - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) os-envs = @@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) "A" swap at @@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "USERPROFILE" "XXX" } } >>environment +prepend-environment+ >>environment-mode - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) "USERPROFILE" swap at "XXX" = From 9d2fb3378b30ce1e33c4143e1297bd42cda706a5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 21:26:29 -0500 Subject: [PATCH 08/15] io.backend.windows.privileges: clean up code and fix inference problem --- .../backend/windows/privileges/privileges-tests.factor | 4 ++++ basis/io/backend/windows/privileges/privileges.factor | 9 +++++---- 2 files changed, 9 insertions(+), 4 deletions(-) create mode 100755 basis/io/backend/windows/privileges/privileges-tests.factor mode change 100644 => 100755 basis/io/backend/windows/privileges/privileges.factor diff --git a/basis/io/backend/windows/privileges/privileges-tests.factor b/basis/io/backend/windows/privileges/privileges-tests.factor new file mode 100755 index 0000000000..7237651b80 --- /dev/null +++ b/basis/io/backend/windows/privileges/privileges-tests.factor @@ -0,0 +1,4 @@ +IN: io.backend.windows.privileges.tests +USING: io.backend.windows.privileges tools.test ; + +[ [ ] with-privileges ] must-infer diff --git a/basis/io/backend/windows/privileges/privileges.factor b/basis/io/backend/windows/privileges/privileges.factor old mode 100644 new mode 100755 index 8661ba99d9..58806cc4df --- a/basis/io/backend/windows/privileges/privileges.factor +++ b/basis/io/backend/windows/privileges/privileges.factor @@ -1,12 +1,13 @@ USING: io.backend kernel continuations sequences -system vocabs.loader combinators ; +system vocabs.loader combinators fry ; IN: io.backend.windows.privileges -HOOK: set-privilege io-backend ( name ? -- ) inline +HOOK: set-privilege io-backend ( name ? -- ) : with-privileges ( seq quot -- ) - over [ [ t set-privilege ] each ] curry compose - swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline + [ '[ _ [ t set-privilege ] each @ ] ] + [ drop '[ _ [ f set-privilege ] each ] ] + 2bi [ ] cleanup ; inline { { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] } From ff674dac22c0ce383738f9d1a156fbbf85b36bf4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 23:18:41 -0500 Subject: [PATCH 09/15] cpu.ppc: bools are 4 bytes on OS X/PowerPC --- basis/cpu/ppc/ppc.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index beee48e5ea..5a528ddd5a 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -713,3 +713,4 @@ USE: vocabs.loader } cond "complex-double" c-type t >>return-in-registers? drop +"bool" c-type 4 >>size 4 >>align drop \ No newline at end of file From e52476f108c0119d088c69c592b818e711f8a3e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 23:26:33 -0500 Subject: [PATCH 10/15] cpu.ppc: fix alien-indirect --- basis/cpu/ppc/ppc.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index beee48e5ea..13e19d4f0e 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -652,10 +652,10 @@ M: ppc %alien-callback ( quot -- ) M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - 13 3 MR ; + 15 3 MR ; M: ppc %alien-indirect ( -- ) - 13 MTLR BLRL ; + 15 MTLR BLRL ; M: ppc %callback-value ( ctype -- ) ! Save top of data stack From 2b23d1dd9e15a96f7becfeafed3a49d7793c46c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 00:20:54 -0500 Subject: [PATCH 11/15] Remove silly retry word from continuations vocab --- basis/io/files/unique/unique.factor | 3 +++ core/continuations/continuations-docs.factor | 16 ---------------- core/continuations/continuations.factor | 2 -- extra/webapps/wee-url/wee-url.factor | 3 +++ 4 files changed, 6 insertions(+), 18 deletions(-) diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 0e4338e3e0..a7ae317668 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -35,6 +35,9 @@ SYMBOL: unique-retries : random-name ( -- string ) unique-length get [ random-ch ] "" replicate-as ; +: retry ( quot: ( -- ? ) n -- ) + swap [ drop ] prepose attempt-all ; inline + : (make-unique-file) ( path prefix suffix -- path ) '[ _ _ _ random-name glue append-path diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 2c91981f13..fa8ecbe385 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -79,7 +79,6 @@ $nl { $subsection continue-with } "Continuations as control-flow:" { $subsection attempt-all } -{ $subsection retry } { $subsection with-return } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; @@ -232,21 +231,6 @@ HELP: attempt-all } } ; -HELP: retry -{ $values - { "quot" quotation } { "n" integer } -} -{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." } -{ $examples - "Try to get a 0 as a random number:" - { $unchecked-example "USING: continuations math prettyprint random ;" - "[ 5 random 0 = ] 5 retry" - "t" - } -} ; - -{ attempt-all retry } related-words - HELP: return { $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 56ac4a71e9..7681c2b089 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -155,8 +155,6 @@ ERROR: attempt-all-error ; ] { } make peek swap [ rethrow ] when ] if ; inline -: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline - TUPLE: condition error restarts continuation ; C: condition ( error restarts cc -- condition ) diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index bc429a0af6..8e200a4452 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -26,6 +26,9 @@ short-url "SHORT_URLS" { : random-url ( -- string ) 1 6 [a,b] random [ letter-bank random ] "" replicate-as ; +: retry ( quot: ( -- ? ) n -- ) + swap [ drop ] prepose attempt-all ; inline + : insert-short-url ( short-url -- short-url ) '[ _ dup random-url >>short insert-tuple ] 10 retry ; From f4a134892c4184491df245c048fbd923680959dd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 00:41:42 -0500 Subject: [PATCH 12/15] Retry uploads etc up to 5 times so that we don't lose a good binary if network is flaky; put git id in subject --- extra/mason/build/build.factor | 11 +++++++---- extra/mason/common/common.factor | 13 ++++++++++--- extra/mason/email/email.factor | 8 ++++---- extra/mason/release/branch/branch.factor | 10 +++++----- extra/mason/report/report.factor | 2 +- 5 files changed, 27 insertions(+), 17 deletions(-) diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index 199d48dec0..5031b5d930 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel calendar io.directories io.encodings.utf8 -io.files io.launcher mason.child mason.cleanup mason.common -mason.help mason.release mason.report mason.email mason.notify -namespaces prettyprint ; +io.files io.launcher namespaces prettyprint mason.child mason.cleanup +mason.common mason.help mason.release mason.report mason.email +mason.notify ; IN: mason.build QUALIFIED: continuations @@ -19,7 +19,10 @@ QUALIFIED: continuations : begin-build ( -- ) "factor" [ git-id ] with-directory - [ "git-id" to-file ] [ notify-begin-build ] bi ; + [ "git-id" to-file ] + [ current-git-id set ] + [ notify-begin-build ] + tri ; : build ( -- ) create-build-dir diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index e4a9d9da13..d020c68fc4 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -4,9 +4,12 @@ USING: kernel namespaces sequences splitting system accessors math.functions make io io.files io.pathnames io.directories io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar -calendar.format arrays mason.config locals system debugger ; +calendar.format arrays mason.config locals system debugger fry +continuations ; IN: mason.common +SYMBOL: current-git-id + ERROR: output-process-error output process ; M: output-process-error error. @@ -35,15 +38,19 @@ M: unix really-delete-tree delete-tree ; swap >>command 15 minutes >>timeout + +closed+ >>stdin try-output-process ; +: retry ( n quot -- ) + '[ drop @ f ] attempt-all drop ; inline + :: upload-safely ( local username host remote -- ) [let* | temp [ remote ".incomplete" append ] scp-remote [ { username "@" host ":" temp } concat ] scp [ scp-command get ] ssh [ ssh-command get ] | - { scp local scp-remote } short-running-process - { ssh host "-l" username "mv" temp remote } short-running-process + 5 [ { scp local scp-remote } short-running-process ] retry + 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry ] ; : eval-file ( file -- obj ) diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor index 23203e5222..302df599b4 100644 --- a/extra/mason/email/email.factor +++ b/extra/mason/email/email.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces accessors combinators make smtp debugger -prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets -mason.common mason.platform mason.config ; +prettyprint sequences io io.streams.string io.encodings.utf8 io.files +io.sockets mason.common mason.platform mason.config ; IN: mason.email : prefix-subject ( str -- str' ) @@ -18,11 +18,11 @@ IN: mason.email send-email ; : subject ( status -- str ) - { + [ current-git-id get 7 short head " -- " ] dip { { status-clean [ "clean" ] } { status-dirty [ "dirty" ] } { status-error [ "error" ] } - } case ; + } case 3append ; : email-report ( report status -- ) [ "text/html" ] dip subject email-status ; diff --git a/extra/mason/release/branch/branch.factor b/extra/mason/release/branch/branch.factor index 75ce828c28..07ec5a8bcd 100644 --- a/extra/mason/release/branch/branch.factor +++ b/extra/mason/release/branch/branch.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.directories io.files io.launcher kernel make -mason.common mason.config mason.platform namespaces prettyprint -sequences ; +namespaces prettyprint sequences mason.common mason.config +mason.platform ; IN: mason.release.branch : branch-name ( -- string ) "clean-" platform append ; @@ -21,7 +21,7 @@ IN: mason.release.branch ] { } make ; : push-to-clean-branch ( -- ) - push-to-clean-branch-cmd short-running-process ; + 5 [ push-to-clean-branch-cmd short-running-process ] retry ; : upload-clean-image-cmd ( -- args ) [ @@ -36,7 +36,7 @@ IN: mason.release.branch ] { } make ; : upload-clean-image ( -- ) - upload-clean-image-cmd short-running-process ; + 5 [ upload-clean-image-cmd short-running-process ] retry ; : (update-clean-branch) ( -- ) "factor" [ diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 7707d16299..0340941449 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -12,7 +12,7 @@ IN: mason.report target-cpu get host-name build-dir - "git-id" eval-file + current-git-id get [XML

Build report for <->/<->

From e0168580befd9dbe233aaaf5447f123da5214b00 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 02:26:05 -0500 Subject: [PATCH 13/15] mason.email: fix unit test --- extra/mason/email/email-tests.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/mason/email/email-tests.factor b/extra/mason/email/email-tests.factor index e2afe01a56..5f48ff0d4f 100644 --- a/extra/mason/email/email-tests.factor +++ b/extra/mason/email/email-tests.factor @@ -1,10 +1,11 @@ IN: mason.email.tests USING: mason.email mason.common mason.config namespaces tools.test ; -[ "mason on linux-x86-64: error" ] [ +[ "mason on linux-x86-64: 12345 -- error" ] [ [ "linux" target-os set "x86.64" target-cpu set + "12345" current-git-id set status-error subject prefix-subject ] with-scope ] unit-test From 7a0760a0f9389e048fe5a24644ffc6f199aa6e98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 02:35:46 -0500 Subject: [PATCH 14/15] tools.deploy.shaker: strip out a few more things --- basis/tools/deploy/shaker/shaker.factor | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index e8f4238ed6..816dbb7979 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -23,7 +23,13 @@ IN: tools.deploy.shaker : strip-init-hooks ( -- ) "Stripping startup hooks" show - { "cpu.x86" "command-line" "libc" "system" "environment" } + { + "command-line" + "cpu.x86" + "environment" + "libc" + "alien.strings" + } [ init-hooks get delete-at ] each deploy-threads? get [ "threads" init-hooks get delete-at @@ -36,8 +42,12 @@ IN: tools.deploy.shaker "io.backend" init-hooks get delete-at ] when strip-dictionary? [ - "compiler.units" init-hooks get delete-at - "vocabs.cache" init-hooks get delete-at + { + "compiler.units" + "vocabs" + "vocabs.cache" + "source-files.errors" + } [ init-hooks get delete-at ] each ] when ; : strip-debugger ( -- ) @@ -260,21 +270,20 @@ IN: tools.deploy.shaker compiler.errors:compiler-errors definition-observers interactive-vocabs - layouts:num-tags - layouts:num-types - layouts:tag-mask - layouts:tag-numbers - layouts:type-numbers lexer-factory print-use-hook root-cache source-files.errors:error-types + source-files.errors:error-observers vocabs:dictionary vocabs:load-vocab-hook + vocabs:vocab-observers word parser-notes } % + { } { "layouts" } strip-vocab-globals % + { } { "math.partial-dispatch" } strip-vocab-globals % { } { "peg" } strip-vocab-globals % From f2f834a234713f1847cdd489e8d7116b1d1f9644 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 02:36:09 -0500 Subject: [PATCH 15/15] Deploy hello-world with optimizing compiler since the image is smaller as a result, and this makes it pass the size test again --- extra/hello-world/deploy.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 48c14f7cba..aadffb6ae8 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-name "Hello world (console)" } - { deploy-c-types? f } - { deploy-word-props? f } - { deploy-ui? f } - { deploy-reflection 1 } - { deploy-compiler? f } { deploy-unicode? f } + { deploy-ui? f } + { deploy-compiler? t } + { deploy-name "Hello world (console)" } { deploy-io 2 } - { deploy-word-defs? f } { deploy-threads? f } - { "stop-after-last-window?" t } + { deploy-reflection 1 } { deploy-math? f } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } }