working on sdl binding, remove some combinators

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index aac17fa87850f705778d8366261ee4b39fbba9e6..f3497743b80a228dc87dce8abbe200ecf1ad2d4d 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -1,5 +1,10 @@
 FFI:\r
 - is signed -vs- unsigned pointers an issue?\r
+- bitfields in C structs\r
+- unsigned types\r
+- SDL_Rect** type\r
+- struct membres that are not *\r
+- float types\r
 \r
 - command line parsing cleanup\r
 - > 1 ( ) inside word def\r

diff --git a/library/combinators.factor b/library/combinators.factor
index a25456a707b66b24dd56d1bd28e2da6b9cbd8f73..a2044ac4f687fd0638aeffbfa3b9d981a19e7155 100644 (file)
--- a/library/combinators.factor
+++ b/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

diff --git a/library/compiler/alien-types.factor b/library/compiler/alien-types.factor
index 854278ad15fbd235b9de2d6f8bcc02797c793ecb..08f4a8bbd0828563268c47c2dba7871aee07ab5e 100644 (file)
--- a/library/compiler/alien-types.factor
+++ b/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

diff --git a/library/platform/jvm/prettyprint.factor b/library/platform/jvm/prettyprint.factor
index 9b19aa3ab8826093d313149bf039d47b6e761994..3a74bcf3adbf3d3e7de0f7d9119ea0e20a984926 100644 (file)
--- a/library/platform/jvm/prettyprint.factor
+++ b/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->>~ ;
 

diff --git a/library/platform/jvm/regexp.factor b/library/platform/jvm/regexp.factor
index 07ff543acc88b989384455c232dfebf31ef696ac..8a6635a2b82c195bcfa066bb6bac10e6e5de91ac 100644 (file)
--- a/library/platform/jvm/regexp.factor
+++ b/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"

diff --git a/library/platform/jvm/stream.factor b/library/platform/jvm/stream.factor
index f9157b542aff2304725466bcda09738950478d85..2afa5adeaa51691f680af6cf2ffc8eb8c5c023b2 100644 (file)
--- a/library/platform/jvm/stream.factor
+++ b/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 ;

diff --git a/library/platform/jvm/threads.factor b/library/platform/jvm/threads.factor
index 215ecbce01a34797f15643ee80614a55d6d1fb90..70a3be6f177c18f3d8f90ac4f32e5a3a261ac117 100644 (file)
--- a/library/platform/jvm/threads.factor
+++ b/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.

diff --git a/library/platform/jvm/words.factor b/library/platform/jvm/words.factor
index 693928598012944db45b719d91dd1e217713c724..a0e5072a58abc1d1e33d692f0f45a8e4d9e58a2b 100644 (file)
--- a/library/platform/jvm/words.factor
+++ b/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 ;

diff --git a/library/sdl/sdl-video.factor b/library/sdl/sdl-video.factor
index ddd882d7cdd7b086ed3fc5f61022e81f85d2730b..6078de03905121af20e1d7e97b7b91ea1dd3ee77 100644 (file)
--- a/library/sdl/sdl-video.factor
+++ b/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: char  BytesPerPixel
-    FIELD: char  Rloss
-    FIELD: char  Gloss
-    FIELD: char  Bloss
-    FIELD: char  Aloss
-    FIELD: char  Rshift
-    FIELD: char  Gshift
-    FIELD: char  Bshift
-    FIELD: char  Ashift
-    FIELD: int   Rmask
-    FIELD: int   Gmask
-    FIELD: int   Bmask
-    FIELD: int   Amask
-    FIELD: int   colorkey
-    FIELD: char  alpha
+    FIELD: uchar  BitsPerPixel
+    FIELD: uchar  BytesPerPixel
+    FIELD: uchar  Rloss
+    FIELD: uchar  Gloss
+    FIELD: uchar  Bloss
+    FIELD: uchar  Aloss
+    FIELD: uchar  Rshift
+    FIELD: uchar  Gshift
+    FIELD: uchar  Bshift
+    FIELD: uchar  Ashift
+    FIELD: uint   Rmask
+    FIELD: uint   Gmask
+    FIELD: uint   Bmask
+    FIELD: uint   Amask
+    FIELD: uint   colorkey
+    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: int     locked
+    FIELD: uint    unused1
+    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 ;

diff --git a/library/test/jvm-compiler/auxiliary.factor b/library/test/jvm-compiler/auxiliary.factor
index 35901fcfb95d8328f5efdeed0fa753e7dbe10ed8..84790b188c2e9ab76b1358bde7062ac68ae679ba 100644 (file)
--- a/library/test/jvm-compiler/auxiliary.factor
+++ b/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
 

diff --git a/library/test/jvm-compiler/compiler.factor b/library/test/jvm-compiler/compiler.factor
index 578a5e3a7c2b8567d76b88209acfdceacfdd06d2..380e9c886abf2960493d59438cda394561fe2ecb 100644 (file)
--- a/library/test/jvm-compiler/compiler.factor
+++ b/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
 

diff --git a/library/test/jvm-compiler/tail.factor b/library/test/jvm-compiler/tail.factor
index 78a643488440a986b2c371d03d007282ef10b23a..6e58ab50543199217fe90c8f6d86a48f8bc11df3 100644 (file)
--- a/library/test/jvm-compiler/tail.factor
+++ b/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

diff --git a/library/test/styles.factor b/library/test/styles.factor
new file mode 100644 (file)
index 0000000..de1c4d5
--- /dev/null
+++ b/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

diff --git a/library/test/test.factor b/library/test/test.factor
index def16ace6e72d80fa296e82596298c5616a3cf11..a71210905a00e7f73f9dcab594f1f02458324b50 100644 (file)
--- a/library/test/test.factor
+++ b/library/test/test.factor
@@ -93,6 +93,7 @@ USE: unparser
         "unparser"
         "random"
         "stream"
+        "styles"
         "math/bignum"
         "math/bitops"
         "math/gcd"