various fixes and OpenGL UI work

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
 

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.

library/help/tutorial.factor

@@ -9,7 +9,7 @@ namespaces sdl sequences strings styles ;
 
 : <underline> ( -- gadget )
     <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 ;

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 ;

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 )

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

library/opengl/sdl-gl.factor

@@ -1,6 +0,0 @@
-IN: sdl
-USING: alien ;
-
-LIBRARY: sdl
-
-FUNCTION: void SDL_GL_SwapBuffers ( ) ;

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?

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 ;

library/test/gadgets/gradients.factor

@@ -1,17 +0,0 @@
-IN: temporary
-USING: gadgets namespaces styles test ;
-
-[ @{ 255 0 0 }@ ] [ @{ 1 0 0 }@ red green <gradient> 0 gradient-color ] unit-test
-[ @{ 0 255 0 }@ ] [ @{ 1 0 0 }@ red green <gradient> 1 gradient-color ] unit-test
-
-[ 0 100 0 @{ 255 0 0 }@ ]
-[ @{ 0 1 0 }@ red green <gradient> @{ 100 200 0 }@ 0 (gradient-x) ] unit-test
-
-[ 0 100 100 @{ 255/2 255/2 0 }@ ]
-[ @{ 0 1 0 }@ red green <gradient> @{ 100 200 0 }@ 100 (gradient-x) ] unit-test
-
-[ 0 0 200 @{ 255 0 0 }@ ]
-[ @{ 1 0 0 }@ red green <gradient> @{ 100 200 0 }@ 0 (gradient-y) ] unit-test
-
-[ 50 0 200 @{ 255/2 255/2 0 }@ ]
-[ @{ 1 0 0 }@ red green <gradient> @{ 100 200 0 }@ 50 (gradient-y) ] unit-test

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

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

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

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 ;