working on sdl binding, remove some combinators

TODO.FACTOR.txt

@@ -1,5 +1,10 @@
 FFI:
 - is signed -vs- unsigned pointers an issue?
+- bitfields in C structs
+- unsigned types
+- SDL_Rect** type
+- struct membres that are not *
+- float types
 
 - command line parsing cleanup
 - > 1 ( ) inside word def

library/combinators.factor

@@ -123,56 +123,3 @@ USE: stack
     #!
     #! This combinator will not compile.
     dup slip forever ; interpret-only
-
-! DEPRECATED
-
-: 2apply ( x y quot -- )
-    #! First applies the code to x, then to y.
-    #!
-    #! If the quotation compiles, this combinator compiles.
-    2dup >r >r nip call r> r> call ; inline interpret-only
-
-: cleave ( x quot quot -- )
-    #! Executes each quotation, with x on top of the stack.
-    #!
-    #! If the quotation compiles, this combinator compiles.
-    >r over >r call r> r> call ; inline interpret-only
-
-: dip ( a [ b ] -- b a )
-    #! Call b as if b was not present on the stack.
-    #!
-    #! If the quotation compiles, this combinator compiles.
-    swap >r call r> ; inline interpret-only
-
-: 2dip ( a b [ c ] -- c a b )
-    #! Call c as if a and b were not present on the stack.
-    #!
-    #! If the quotation compiles, this combinator compiles.
-    -rot >r >r call r> r> ; inline interpret-only
-
-: interleave ( X quot -- )
-    #! Evaluate each element of the list with X on top of the
-    #! stack. When done, X is popped off the stack.
-    #!
-    #! To avoid unexpected results, each element of the list
-    #! must have stack effect ( X -- ).
-    #!
-    #! This combinator will not compile.
-    dup [
-        over [ unswons dip ] dip swap interleave
-    ] [
-        2drop
-    ] ifte ; interpret-only
-
-: while ( cond body -- )
-    #! Evaluate cond. If it leaves t on the stack, evaluate
-    #! body, and recurse.
-    #!
-    #! In order to compile, the stack effect of
-    #! cond * ( X -- ) * body must consume as many values as
-    #! it produces.
-    2dup >r >r >r call [
-        r> call r> r> while
-    ] [
-        r> drop r> drop r> drop
-    ] ifte ; inline interpret-only

library/compiler/alien-types.factor

@@ -133,6 +133,14 @@ global [ <namespace> "c-types" set ] bind
     "unbox_integer" "unboxer" set
 ] "int" define-c-type
 
+[
+    [ alien-4 ] "getter" set
+    [ set-alien-4 ] "setter" set
+    4 "width" set
+    "box_integer" "boxer" set
+    "unbox_integer" "unboxer" set
+] "uint" define-c-type
+
 [
     [ alien-2 ] "getter" set
     [ set-alien-2 ] "setter" set
@@ -141,6 +149,14 @@ global [ <namespace> "c-types" set ] bind
     "unbox_integer" "unboxer" set
 ] "short" define-c-type
 
+[
+    [ alien-2 ] "getter" set
+    [ set-alien-2 ] "setter" set
+    2 "width" set
+    "box_integer" "boxer" set
+    "unbox_integer" "unboxer" set
+] "ushort" define-c-type
+
 [
     [ alien-1 ] "getter" set
     [ set-alien-1 ] "setter" set
@@ -149,6 +165,14 @@ global [ <namespace> "c-types" set ] bind
     "unbox_integer" "unboxer" set
 ] "char" define-c-type
 
+[
+    [ alien-1 ] "getter" set
+    [ set-alien-1 ] "setter" set
+    1 "width" set
+    "box_integer" "boxer" set
+    "unbox_integer" "unboxer" set
+] "uchar" define-c-type
+
 [
     [ alien-4 ] "getter" set
     [ set-alien-4 ] "setter" set

library/platform/jvm/prettyprint.factor

@@ -51,7 +51,7 @@ USE: words
     tab-size - ;
 
 : prettyprint-~<<>>~ ( indent word list -- indent )
-    [ [ prettyprint-~<< ] dip prettyprint-word " " write ] dip
+    >r >r prettyprint-~<< r> prettyprint-word " " write r>
     [ write " " write ] each
     prettyprint->>~ ;
 

library/platform/jvm/regexp.factor

@@ -58,7 +58,7 @@ USE: stack
     #! evaluate the code with the matcher at the top of the
     #! stack. Otherwise, pop the matcher off the stack and
     #! push f.
-    [ dup re-matches* ] dip [ drop f ] ifte ;
+    >r dup re-matches* r> [ drop f ] ifte ;
 
 : re-replace* ( replace matcher -- string )
     [ "java.lang.String" ] "java.util.regex.Matcher"

library/platform/jvm/stream.factor

@@ -54,7 +54,7 @@ USE: strings
 : fcopy ( from to -- )
     #! Copy the contents of the byte-stream 'from' to the
     #! byte-stream 'to'.
-    [ [ "in" get ] bind ] dip
+    >r [ "in" get ] bind r>
     [ "out" get ] bind
     [ "java.io.InputStream" "java.io.OutputStream" ]
     "factor.FactorLib" "copy" jinvoke-static ;

library/platform/jvm/threads.factor

@@ -54,7 +54,7 @@ USE: stack
     [ ] "factor.FactorInterpreter" jnew ;
 
 : fork* ( current new -- thread )
-    dup <thread> [ clone-interpreter ] dip ; interpret-only
+    dup <thread> >r clone-interpreter r> ; interpret-only
 
 : fork ( -- ? )
     #! Spawn a new thread. In the original thread, push f.

library/platform/jvm/words.factor

@@ -81,7 +81,7 @@ USE: stack
 : no-name ( list -- word )
     ! Generates an uninternalized word and gives it a compound
     ! definition created from the given list.
-    [ gensym dup dup ] dip <compound> redefine ;
+    >r gensym dup dup r> <compound> redefine ;
 
 : primitive? ( worddef -- boolean )
     "factor.FactorPrimitiveDefinition" is ;

library/sdl/sdl-video.factor

@@ -56,32 +56,39 @@ USE: stack
 : SDL_SRCALPHA    HEX: 00010000 ; ! Blit uses source alpha blending
 : SDL_PREALLOC    HEX: 01000000 ; ! Surface uses preallocated memory
 
+BEGIN-STRUCT: rect
+    FIELD: short x
+    FIELD: short y
+    FIELD: ushort w
+    FIELD: ushort h
+END-STRUCT
+
 BEGIN-STRUCT: format
     FIELD: void* palette
-    FIELD: char  BitsPerPixel
+    FIELD: uchar  BitsPerPixel
-    FIELD: char  BytesPerPixel
+    FIELD: uchar  BytesPerPixel
-    FIELD: char  Rloss
+    FIELD: uchar  Rloss
-    FIELD: char  Gloss
+    FIELD: uchar  Gloss
-    FIELD: char  Bloss
+    FIELD: uchar  Bloss
-    FIELD: char  Aloss
+    FIELD: uchar  Aloss
-    FIELD: char  Rshift
+    FIELD: uchar  Rshift
-    FIELD: char  Gshift
+    FIELD: uchar  Gshift
-    FIELD: char  Bshift
+    FIELD: uchar  Bshift
-    FIELD: char  Ashift
+    FIELD: uchar  Ashift
-    FIELD: int   Rmask
+    FIELD: uint   Rmask
-    FIELD: int   Gmask
+    FIELD: uint   Gmask
-    FIELD: int   Bmask
+    FIELD: uint   Bmask
-    FIELD: int   Amask
+    FIELD: uint   Amask
-    FIELD: int   colorkey
+    FIELD: uint   colorkey
-    FIELD: char  alpha
+    FIELD: uchar  alpha
 END-STRUCT
 
 BEGIN-STRUCT: surface
-    FIELD: int     flags
+    FIELD: uint    flags
     FIELD: format* format
     FIELD: int     w
     FIELD: int     h
-    FIELD: short   pitch
+    FIELD: ushort  pitch
     FIELD: void*   pixels
     FIELD: int     offset
     FIELD: void*   hwdata
@@ -89,10 +96,10 @@ BEGIN-STRUCT: surface
     FIELD: short   clip-y
     FIELD: short   clip-w
     FIELD: short   clip-h
-    FIELD: int     unused1
+    FIELD: uint    unused1
-    FIELD: int     locked
+    FIELD: uint    locked
     FIELD: int     map
-    FIELD: int     format_version
+    FIELD: uint    format_version
     FIELD: int     refcount
 END-STRUCT
 
@@ -106,19 +113,43 @@ END-STRUCT
         drop t
     ] ifte ;
 
+: SDL_VideoInit ( driver-name flags -- )
+    "int" "sdl" "SDL_SetVideoMode"
+    [ "char*" "int" ] alien-call ;
+
+: SDL_VideoQuit ( -- )
+    "void" "sdl" "SDL_VideoQuit" [ ] alien-call ;
+
+! SDL_VideoDriverName -- needs strings as out params.
+
+: SDL_GetVideoSurface ( -- surface )
+    "surface*" "sdl" "SDL_GetVideoSurface" [ ] alien-call ;
+
+! SDL_GetVideoInfo needs C struct bitfield support
+
+: SDL_VideoModeOK ( width height bpp flags -- )
+    "int" "sdl" "SDL_VideoModeOK"
+    [ "int" "int" "int" "int" ] alien-call ;
+
+! SDL_ListModes needs array of structs support
+
 : SDL_SetVideoMode ( width height bpp flags -- )
     "int" "sdl" "SDL_SetVideoMode"
     [ "int" "int" "int" "int" ] alien-call ;
 
+! UpdateRects, UpdateRect
+
+: SDL_Flip ( surface -- )
+    "void" "sdl" "SDL_Flip" [ "surface*" ] alien-call ;
+
+! SDL_SetGamma: float types
+
 : SDL_LockSurface ( surface -- )
     "int" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ;
 
 : SDL_UnlockSurface ( surface -- )
     "void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-call ;
 
-: SDL_Flip ( surface -- )
-    "void" "sdl" "SDL_Flip" [ "surface*" ] alien-call ;
-
 : SDL_MapRGB ( surface r g b -- )
     "int" "sdl" "SDL_MapRGB"
     [ "surface*" "char" "char" "char" ] alien-call ;

library/test/jvm-compiler/auxiliary.factor

@@ -37,13 +37,6 @@ USE: words
 
 [ ] [ ] [ while-test ] test-word
 
-: [while]
-    [ over call ] [ dup 2dip ] while 2drop ; inline
-
-: [while-test] [ f ] [ ] [while] ; word must-compile
-
-[ ] [ ] [ [while-test] ] test-word
-
 : times-test-1 [ nop ] times ; word must-compile
 : times-test-2 [ succ ] times ; word must-compile
 : times-test-3 0 10 [ succ ] times ; word must-compile
@@ -59,7 +52,7 @@ USE: words
 [ 3 ] [ t f ] [ nested-ifte ] test-word
 [ 4 ] [ f f ] [ nested-ifte ] test-word
 
-: flow-erasure [ 2 2 + ] [ ] dip call ; inline word must-compile
+: flow-erasure [ 2 2 + ] [ ] swap >r call r> call ; inline word must-compile
 
 [ 4 ] [ ] [ flow-erasure ] test-word
 

library/test/jvm-compiler/compiler.factor

@@ -53,7 +53,7 @@ USE: words
 !: null-rec ( -- )
 !    t [ t null-rec ] unless* drop ; word must-compile test-null-rec
 
-[ f 1 2 3 ] [ [ [ 2 | 1 ] ] 3 ] [ [ unswons unswons ] dip ] test-word
+[ f 1 2 3 ] [ [ [ 2 | 1 ] ] 3 ] [ >r unswons unswons r> ] test-word
 
 [ [ 2 1 0 0 ] ] [ [ >r [ ] [ ] ifte r> ] ] [ balance>list ] test-word
 

library/test/jvm-compiler/tail.factor

@@ -29,7 +29,7 @@ USE: words
 [ f ] [ [ 1 2 3 ] ] [ tail-call-2 ] test-word
 
 : tail-call-3 ( x y -- z )
-    [ dup succ ] dip swap 6 = [
+    >r dup succ r> swap 6 = [
         +
     ] [
         swap tail-call-3

library/test/styles.factor

@@ -0,0 +1,18 @@
+IN: scratchpad
+USE: lists
+USE: kernel
+USE: styles
+USE: test
+
+[ t ] [ default-style assoc? ] unit-test
+[ t ] [
+    f "fooquux" set-style "fooquux" get-style default-style =
+] unit-test
+[ "Sans-Serif" ] [
+    [
+        [ "font" | "Sans-Serif" ]
+    ] "fooquux" set-style
+    "font" "fooquux" get-style assoc
+] unit-test
+
+f "fooquux" set-style

library/test/test.factor

@@ -93,6 +93,7 @@ USE: unparser
         "unparser"
         "random"
         "stream"
+        "styles"
         "math/bignum"
         "math/bitops"
         "math/gcd"