From 42e15aaedec0ea227d01c55514285b87f2d75b7e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 Oct 2004 03:06:40 +0000 Subject: [PATCH] working on sdl binding, remove some combinators --- TODO.FACTOR.txt | 5 ++ library/combinators.factor | 53 --------------- library/compiler/alien-types.factor | 24 +++++++ library/platform/jvm/prettyprint.factor | 2 +- library/platform/jvm/regexp.factor | 2 +- library/platform/jvm/stream.factor | 2 +- library/platform/jvm/threads.factor | 2 +- library/platform/jvm/words.factor | 2 +- library/sdl/sdl-video.factor | 79 +++++++++++++++------- library/test/jvm-compiler/auxiliary.factor | 9 +-- library/test/jvm-compiler/compiler.factor | 2 +- library/test/jvm-compiler/tail.factor | 2 +- library/test/styles.factor | 18 +++++ library/test/test.factor | 1 + 14 files changed, 111 insertions(+), 92 deletions(-) create mode 100644 library/test/styles.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index aac17fa878..f3497743b8 100644 --- a/TODO.FACTOR.txt +++ b/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 diff --git a/library/combinators.factor b/library/combinators.factor index a25456a707..a2044ac4f6 100644 --- 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 854278ad15..08f4a8bbd0 100644 --- a/library/compiler/alien-types.factor +++ b/library/compiler/alien-types.factor @@ -133,6 +133,14 @@ global [ "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 [ "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 [ "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 9b19aa3ab8..3a74bcf3ad 100644 --- 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 07ff543acc..8a6635a2b8 100644 --- 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 f9157b542a..2afa5adeaa 100644 --- 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 215ecbce01..70a3be6f17 100644 --- 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 [ clone-interpreter ] dip ; interpret-only + dup >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 6939285980..a0e5072a58 100644 --- 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 redefine ; + >r gensym dup dup r> redefine ; : primitive? ( worddef -- boolean ) "factor.FactorPrimitiveDefinition" is ; diff --git a/library/sdl/sdl-video.factor b/library/sdl/sdl-video.factor index ddd882d7cd..6078de0390 100644 --- 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 35901fcfb9..84790b188c 100644 --- 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 578a5e3a7c..380e9c886a 100644 --- 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 78a6434884..6e58ab5054 100644 --- 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 index 0000000000..de1c4d56e8 --- /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 def16ace6e..a71210905a 100644 --- 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"