From 94e6955fd04e57410ad687f550c5a80e17cc6924 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 Oct 2005 04:30:44 +0000 Subject: [PATCH] various fixes and OpenGL UI work --- library/bootstrap/boot-stage2.factor | 8 ++++--- library/generic/tuple.factor | 9 +++++--- library/help/tutorial.factor | 4 ++-- library/inference/inference.factor | 4 +++- library/math/integer.factor | 6 +++++ .../opengl-utils.factor} | 2 +- library/opengl/sdl-gl.factor | 6 ----- library/sdl/sdl-utils.factor | 14 +++++------- library/sdl/sdl-video.factor | 3 +++ library/test/gadgets/gradients.factor | 17 -------------- library/test/generic.factor | 2 ++ library/test/inference.factor | 2 ++ library/test/math/integer.factor | 22 ++++++++++++------- library/test/test.factor | 2 +- 14 files changed, 50 insertions(+), 51 deletions(-) rename library/{ui/opengl.factor => opengl/opengl-utils.factor} (98%) delete mode 100644 library/opengl/sdl-gl.factor delete mode 100644 library/test/gadgets/gradients.factor diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 8931e96ef8..d4adfa7f5f 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -38,11 +38,13 @@ unix? [ os "macosx" = [ ! SDL and OpenGL are linked into the runtime "sdl-ttf" "libSDL_ttf.dylib" "cdecl" add-library + "freetype" "libfreetype.dylib" "cdecl" add-library ] [ - "sdl" "libSDL.so" "cdecl" add-library + "sdl" "libSDL.so" "cdecl" add-library "sdl-ttf" "libSDL_ttf.so" "cdecl" add-library - "gl" "libGL.so" "cdecl" add-library - "glu" "libGLU.so" "cdecl" add-library + "gl" "libGL.so" "cdecl" add-library + "glu" "libGLU.so" "cdecl" add-library + "freetype" "libfreetype.so" "cdecl" add-library ] if ] when diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 426aff998c..7f81575e5d 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -51,8 +51,13 @@ vectors words ; : tuple-constructor ( class -- word ) word-name "in" get constructor-word dup save-location ; +PREDICATE: word tuple-class "tuple-size" word-prop ; + +: check-tuple-class ( class -- ) + tuple-class? [ "Not a tuple class" throw ] unless ; + : define-constructor ( word class def -- ) - >r [ + over check-tuple-class >r [ dup literalize , "tuple-size" word-prop , \ make-tuple , ] [ ] make r> append define-compound ; @@ -87,8 +92,6 @@ M: tuple = ( obj tuple -- ? ) over tuple? [ array= ] [ 2drop f ] if ] if ; -PREDICATE: word tuple-class "tuple-size" word-prop ; - : is? ( obj pred -- ? | pred: obj -- ? ) #! Tests if the object satisfies the predicate, or if #! it delegates to an object satisfying it. diff --git a/library/help/tutorial.factor b/library/help/tutorial.factor index 560ab9412f..ff73e0a5a6 100644 --- a/library/help/tutorial.factor +++ b/library/help/tutorial.factor @@ -9,7 +9,7 @@ namespaces sdl sequences strings styles ; : ( -- gadget ) - dup << gradient f @{ 1 0 0 }@ @{ 64 64 64 }@ @{ 255 255 255 }@ >> + dup << gradient f @{ 1 0 0 }@ @{ @{ 64 64 64 }@ @{ 255 255 255 }@ }@ >> interior set-paint-prop @{ 0 10 0 }@ over set-gadget-dim ; @@ -358,7 +358,7 @@ M: general-list tutorial-line : tutorial-theme dup @{ 204 204 255 }@ background set-paint-prop - dup << gradient f @{ 0 1 0 }@ @{ 204 204 255 }@ @{ 255 204 255 }@ >> + dup << gradient f @{ 0 1 0 }@ @{ @{ 204 204 255 }@ @{ 255 204 255 }@ }@ >> interior set-paint-prop dup "Sans Serif" font set-paint-prop 16 font-size set-paint-prop ; diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 6a7a89a9f4..eac15df788 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -87,7 +87,9 @@ M: wrapper apply-object wrapped apply-literal ; #! Ignore this branch's stack effect. terminated? on #terminate node, ; -: infer-quot ( quot -- ) +GENERIC: infer-quot + +M: general-list infer-quot ( quot -- ) #! Recursive calls to this word are made for nested #! quotations. [ terminated? get [ drop f ] [ apply-object t ] if ] all? drop ; diff --git a/library/math/integer.factor b/library/math/integer.factor index d365e63f0d..bbfd2647cc 100644 --- a/library/math/integer.factor +++ b/library/math/integer.factor @@ -30,6 +30,12 @@ UNION: integer fixnum bignum ; gcd 1 = [ "Non-trivial divisor found" throw ] unless ; foldable +: (next-power-of-2) ( i n -- n ) + 2dup >= [ drop ] [ >r 1 shift r> (next-power-of-2) ] if ; + +: next-power-of-2 ( n -- n ) + 2 swap (next-power-of-2) ; + IN: math-internals : fraction> ( a b -- a/b ) diff --git a/library/ui/opengl.factor b/library/opengl/opengl-utils.factor similarity index 98% rename from library/ui/opengl.factor rename to library/opengl/opengl-utils.factor index 445ced49e2..5f2abe2e7d 100644 --- a/library/ui/opengl.factor +++ b/library/opengl/opengl-utils.factor @@ -122,7 +122,7 @@ USING: alien errors kernel math namespaces opengl sdl sequences ; : make-dlist ( type quot -- id ) #! Make a display list. - gen-dlist swap glNewList call glEndList ; inline + gen-dlist [ rot glNewList call glEndList ] keep ; inline : texture>dlist ( width height id -- id ) #! Given a texture width/height and ID, make a display list diff --git a/library/opengl/sdl-gl.factor b/library/opengl/sdl-gl.factor deleted file mode 100644 index 3f045a21b5..0000000000 --- a/library/opengl/sdl-gl.factor +++ /dev/null @@ -1,6 +0,0 @@ -IN: sdl -USING: alien ; - -LIBRARY: sdl - -FUNCTION: void SDL_GL_SwapBuffers ( ) ; diff --git a/library/sdl/sdl-utils.factor b/library/sdl/sdl-utils.factor index 7c9a33ec40..5c3e75c0a6 100644 --- a/library/sdl/sdl-utils.factor +++ b/library/sdl/sdl-utils.factor @@ -106,21 +106,17 @@ SYMBOL: open-fonts ] if ; : lock-surface ( -- ) - surface get SDL_LockSurface drop ; + must-lock-surface? [ surface get SDL_LockSurface drop ] when ; : unlock-surface ( -- ) - surface get SDL_UnlockSurface ; + must-lock-surface? [ surface get SDL_UnlockSurface ] when ; : with-surface ( quot -- ) #! Execute a quotation, locking the current surface if it #! is required (eg, hardware surface). - [ - must-lock-surface? [ lock-surface ] when - call - ] [ - must-lock-surface? [ unlock-surface ] when - surface get SDL_Flip - ] cleanup ; inline + [ lock-surface call ] + [ unlock-surface surface get SDL_Flip ] + cleanup ; inline : with-unlocked-surface ( quot -- ) must-lock-surface? diff --git a/library/sdl/sdl-video.factor b/library/sdl/sdl-video.factor index 44eecbd361..b8f92fdad8 100644 --- a/library/sdl/sdl-video.factor +++ b/library/sdl/sdl-video.factor @@ -141,3 +141,6 @@ END-STRUCT : SDL_WM_SetCaption ( title icon -- ) "void" "sdl" "SDL_WM_SetCaption" [ "char*" "char*" ] alien-invoke ; + +: SDL_GL_SwapBuffers ( -- ) + "void" "sdl" "SDL_GL_SwapBuffers" [ ] alien-invoke ; diff --git a/library/test/gadgets/gradients.factor b/library/test/gadgets/gradients.factor deleted file mode 100644 index 86ec4f1e22..0000000000 --- a/library/test/gadgets/gradients.factor +++ /dev/null @@ -1,17 +0,0 @@ -IN: temporary -USING: gadgets namespaces styles test ; - -[ @{ 255 0 0 }@ ] [ @{ 1 0 0 }@ red green 0 gradient-color ] unit-test -[ @{ 0 255 0 }@ ] [ @{ 1 0 0 }@ red green 1 gradient-color ] unit-test - -[ 0 100 0 @{ 255 0 0 }@ ] -[ @{ 0 1 0 }@ red green @{ 100 200 0 }@ 0 (gradient-x) ] unit-test - -[ 0 100 100 @{ 255/2 255/2 0 }@ ] -[ @{ 0 1 0 }@ red green @{ 100 200 0 }@ 100 (gradient-x) ] unit-test - -[ 0 0 200 @{ 255 0 0 }@ ] -[ @{ 1 0 0 }@ red green @{ 100 200 0 }@ 0 (gradient-y) ] unit-test - -[ 50 0 200 @{ 255/2 255/2 0 }@ ] -[ @{ 1 0 0 }@ red green @{ 100 200 0 }@ 50 (gradient-y) ] unit-test diff --git a/library/test/generic.factor b/library/test/generic.factor index 98190e5d87..2268a25087 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -194,3 +194,5 @@ TUPLE: delegating ; [ f ] [ \ each simple-generic? ] unit-test [ f ] [ \ object simple-generic? ] unit-test [ t ] [ \ + 2generic? ] unit-test + +[ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails diff --git a/library/test/inference.factor b/library/test/inference.factor index 4421697fcf..5722b1ee8a 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -226,6 +226,8 @@ DEFER: agent [ @{ 0 1 }@ ] [ [ bad-code ] infer ] unit-test +[ 1234 infer ] unit-test-fails + ! This form should not have a stack effect ! : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; ! [ [ bad-bin ] infer ] unit-test-fails diff --git a/library/test/math/integer.factor b/library/test/math/integer.factor index c1e0225578..9897b8d7fe 100644 --- a/library/test/math/integer.factor +++ b/library/test/math/integer.factor @@ -69,14 +69,6 @@ USING: kernel math prettyprint test ; [ 134217728 dup + dup + dup + dup + dup + dup + unparse ] unit-test -[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test -[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test -[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test -[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test -[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test -[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test -[ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test - [ 0 0 ^ ] unit-test-fails [ 1 ] [ 10 0 ^ ] unit-test [ 1/8 ] [ 1/2 3 ^ ] unit-test @@ -92,3 +84,17 @@ unit-test [ 2 ] [ 3/2 ceiling ] unit-test [ 0 ] [ -7/8 ceiling ] unit-test [ -1 ] [ -3/2 ceiling ] unit-test + +[ 2 ] [ 1 next-power-of-2 ] unit-test +[ 2 ] [ 2 next-power-of-2 ] unit-test +[ 4 ] [ 3 next-power-of-2 ] unit-test +[ 16 ] [ 13 next-power-of-2 ] unit-test +[ 16 ] [ 16 next-power-of-2 ] unit-test + +[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test +[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test +[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test +[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test +[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test +[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test +[ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index 4dfdbb3da4..0e2aed67a2 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -93,7 +93,7 @@ SYMBOL: failures "httpd/http-client" "threads" "parsing-word" "inference" "interpreter" "alien" "gadgets/line-editor" "gadgets/rectangles" - "gadgets/gradients" "gadgets/frames" "memory" + "gadgets/frames" "memory" "redefine" "annotate" "binary" "inspector" "kernel" } run-tests ;