From a461059ef7d6bfbebbefe1a6c03c5c3f8dbcc40b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 Oct 2004 05:15:06 +0000 Subject: [PATCH] alien fixes, sdl fixes, lotsa other stuff --- TODO.FACTOR.txt | 3 ++- library/compiler/alien-types.factor | 24 ++++++++++++--------- library/math/arithmetic.factor | 5 +++-- library/platform/native/parse-syntax.factor | 2 +- library/platform/native/words.factor | 1 + library/sdl/sdl-event.factor | 2 +- library/sdl/sdl-video.factor | 7 +++--- library/test/combinators.factor | 10 +++++++++ library/test/parsing-word.factor | 14 ++++++++++++ library/test/test.factor | 1 + native/bignum.c | 12 +++++++++++ native/bignum.h | 2 ++ native/ffi.c | 8 +++---- native/fixnum.c | 24 +++++++++++++++++++++ native/fixnum.h | 4 ++++ 15 files changed, 97 insertions(+), 22 deletions(-) create mode 100644 library/test/parsing-word.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 8f1c7ccada..ebc7af5d93 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,13 +1,14 @@ FFI: - is signed -vs- unsigned pointers an issue? - bitfields in C structs -- unsigned types - SDL_Rect** type - struct membres that are not * - float types +- SDL_MapRGB broken - command line parsing cleanup - > 1 ( ) inside word def +- parsing-word test fails - when* compilation in jvm - compile word twice; no more 'cannot compile' error! diff --git a/library/compiler/alien-types.factor b/library/compiler/alien-types.factor index 2bbd84b965..2ea4c0948d 100644 --- a/library/compiler/alien-types.factor +++ b/library/compiler/alien-types.factor @@ -119,6 +119,10 @@ USE: words : END-UNION ( max -- ) dup define-constructor define-struct-type ; parsing +: NULL ( -- null ) + #! C null value. + 0 ; + global [ "c-types" set ] bind [ @@ -141,40 +145,40 @@ global [ "c-types" set ] bind [ alien-4 ] "getter" set [ set-alien-4 ] "setter" set 4 "width" set - "box_integer" "boxer" set - "unbox_integer" "unboxer" set + "box_cell" "boxer" set + "unbox_cell" "unboxer" set ] "uint" define-c-type [ [ alien-2 ] "getter" set [ set-alien-2 ] "setter" set 2 "width" set - "box_integer" "boxer" set - "unbox_integer" "unboxer" set + "box_signed_2" "boxer" set + "unbox_signed_2" "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 + "box_cell" "boxer" set + "unbox_cell" "unboxer" set ] "ushort" define-c-type [ [ alien-1 ] "getter" set [ set-alien-1 ] "setter" set 1 "width" set - "box_integer" "boxer" set - "unbox_integer" "unboxer" set + "box_signed_1" "boxer" set + "unbox_signed_1" "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 + "box_cell" "boxer" set + "unbox_cell" "unboxer" set ] "uchar" define-c-type [ diff --git a/library/math/arithmetic.factor b/library/math/arithmetic.factor index 389e6e6716..9011f28277 100644 --- a/library/math/arithmetic.factor +++ b/library/math/arithmetic.factor @@ -53,8 +53,9 @@ USE: stack 2dup < [ drop ] [ nip ] ifte ; : between? ( x min max -- ? ) - #! Push if min <= x <= max. - >r dupd max r> min = ; + #! Push if min <= x <= max. Handles case where min > max + #! by swapping them. + 2dup > [ swap ] when >r dupd max r> min = ; : sq dup * ; inline diff --git a/library/platform/native/parse-syntax.factor b/library/platform/native/parse-syntax.factor index 12f0b82111..279b90f521 100644 --- a/library/platform/native/parse-syntax.factor +++ b/library/platform/native/parse-syntax.factor @@ -120,7 +120,7 @@ IN: syntax : f f parsed ; parsing ! Lists -: [ [ ] ; parsing +: [ f ; parsing : ] reverse parsed ; parsing : | ( syntax: | cdr ] ) diff --git a/library/platform/native/words.factor b/library/platform/native/words.factor index e0e160995b..097d4dd4c0 100644 --- a/library/platform/native/words.factor +++ b/library/platform/native/words.factor @@ -59,6 +59,7 @@ USE: stack : define-compound ( word def -- ) over set-word-parameter + ( dup f "parsing" set-word-property ) 1 swap set-word-primitive ; : define-symbol ( word -- ) diff --git a/library/sdl/sdl-event.factor b/library/sdl/sdl-event.factor index 9bbb7359c1..72d992a317 100644 --- a/library/sdl/sdl-event.factor +++ b/library/sdl/sdl-event.factor @@ -143,7 +143,7 @@ BEGIN-STRUCT: joy-hat-event ! SDL_HAT_LEFT SDL_HAT_CENTERED SDL_HAT_RIGHT ! SDL_HAT_LEFTDOWN SDL_HAT_DOWN SDL_HAT_RIGHTDOWN ! Note that zero means the POV is centered. -END-STRUCT +END-STRUCT BEGIN-STRUCT: joy-button-event FIELD: uchar type ! SDL_JOYBUTTONDOWN or SDL_JOYBUTTONUP diff --git a/library/sdl/sdl-video.factor b/library/sdl/sdl-video.factor index 21de4e2b76..98f619b566 100644 --- a/library/sdl/sdl-video.factor +++ b/library/sdl/sdl-video.factor @@ -152,8 +152,9 @@ END-STRUCT ! SDL_SetGamma: float types : SDL_FillRect ( surface rect color -- n ) + #! If rect is null, fills entire surface. "int" "sdl" "SDL_FillRect" - [ "surface*" "rect*" "unint" ] alien-call ; + [ "surface*" "rect*" "uint" ] alien-call ; : SDL_LockSurface ( surface -- ) "int" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ; @@ -162,5 +163,5 @@ END-STRUCT "void" "sdl" "SDL_UnlockSurface" [ "surface*" ] alien-call ; : SDL_MapRGB ( surface r g b -- ) - "int" "sdl" "SDL_MapRGB" - [ "surface*" "char" "char" "char" ] alien-call ; + "uint" "sdl" "SDL_MapRGB" + [ "surface*" "uchar" "uchar" "uchar" ] alien-call ; diff --git a/library/test/combinators.factor b/library/test/combinators.factor index 5d977e495b..edae9aa96d 100644 --- a/library/test/combinators.factor +++ b/library/test/combinators.factor @@ -5,12 +5,22 @@ USE: math USE: stack USE: test +[ slip ] unit-test-fails +[ 1 slip ] unit-test-fails +[ 1 2 slip ] unit-test-fails +[ 1 2 3 slip ] unit-test-fails + [ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test [ 6 ] [ [ 2 2 + ] 1 1 2slip + + ] unit-test [ 6 ] [ [ 2 1 + ] 1 1 1 3slip + + + ] unit-test +[ [ ] keep ] unit-test-fails + [ 6 ] [ 2 [ sq ] keep + ] unit-test +[ cond ] unit-test-fails +[ [ [ 1 = ] [ ] ] cond ] unit-test-fails + [ ] [ 3 [ ] cond ] unit-test [ t ] [ 4 [ [ 1 = ] [ ] [ 4 = ] [ drop t ] [ 2 = ] [ ] ] cond ] unit-test diff --git a/library/test/parsing-word.factor b/library/test/parsing-word.factor new file mode 100644 index 0000000000..3f68d7960f --- /dev/null +++ b/library/test/parsing-word.factor @@ -0,0 +1,14 @@ +IN: scratchpad + +USE: parser +USE: test + +DEFER: foo + +": foo 2 2 + . ; parsing" eval + +[ [ ] ] [ "foo" parse ] unit-test + +": foo 2 2 + . ;" eval + +[ [ foo ] ] [ "foo" parse ] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index 86f704a921..374ac0f978 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -113,6 +113,7 @@ USE: unparser "crashes" test "sbuf" test "threads" test + "parsing-word" test cpu "x86" = [ [ diff --git a/native/bignum.c b/native/bignum.c index dde761395d..3f01c8e494 100644 --- a/native/bignum.c +++ b/native/bignum.c @@ -20,12 +20,24 @@ void box_integer(FIXNUM integer) dpush(tag_integer(integer)); } +/* FFI calls this */ +void box_cell(CELL cell) +{ + dpush(tag_cell(cell)); +} + /* FFI calls this */ FIXNUM unbox_integer(void) { return to_integer(dpop()); } +/* FFI calls this */ +CELL unbox_cell(void) +{ + return to_integer(dpop()); +} + ARRAY* to_bignum(CELL tagged) { RATIO* r; diff --git a/native/bignum.h b/native/bignum.h index 143d6fc6d7..d779e962b7 100644 --- a/native/bignum.h +++ b/native/bignum.h @@ -10,7 +10,9 @@ INLINE ARRAY* untag_bignum(CELL tagged) FIXNUM to_integer(CELL x); void box_integer(FIXNUM integer); +void box_cell(CELL cell); FIXNUM unbox_integer(void); +CELL unbox_cell(void); ARRAY* to_bignum(CELL tagged); void primitive_to_bignum(void); void primitive_bignum_eq(void); diff --git a/native/ffi.c b/native/ffi.c index 8ae3daabad..e7eb2ecbd5 100644 --- a/native/ffi.c +++ b/native/ffi.c @@ -181,7 +181,7 @@ void primitive_alien_2(void) { #ifdef FFI CELL ptr = alien_pointer(); - box_integer(*(CHAR*)ptr); + box_signed_2(*(CHAR*)ptr); #else general_error(ERROR_FFI_DISABLED,F); #endif @@ -191,7 +191,7 @@ void primitive_set_alien_2(void) { #ifdef FFI CELL ptr = alien_pointer(); - CELL value = unbox_integer(); + CELL value = unbox_signed_2(); *(CHAR*)ptr = value; #else general_error(ERROR_FFI_DISABLED,F); @@ -201,7 +201,7 @@ void primitive_set_alien_2(void) void primitive_alien_1(void) { #ifdef FFI - box_integer(bget(alien_pointer())); + box_signed_1(bget(alien_pointer())); #else general_error(ERROR_FFI_DISABLED,F); #endif @@ -211,7 +211,7 @@ void primitive_set_alien_1(void) { #ifdef FFI CELL ptr = alien_pointer(); - BYTE value = value = unbox_integer(); + BYTE value = value = unbox_signed_1(); bput(ptr,value); #else general_error(ERROR_FFI_DISABLED,F); diff --git a/native/fixnum.c b/native/fixnum.c index f8c4a14e47..95449da51a 100644 --- a/native/fixnum.c +++ b/native/fixnum.c @@ -202,3 +202,27 @@ void primitive_fixnum_not(void) { drepl(tag_fixnum(~to_fixnum(dpeek()))); } + +/* FFI calls this */ +void box_signed_1(signed char integer) +{ + dpush(tag_integer(integer)); +} + +/* FFI calls this */ +void box_signed_2(signed short integer) +{ + dpush(tag_integer(integer)); +} + +/* FFI calls this */ +signed char unbox_signed_1(void) +{ + return to_integer(dpop()); +} + +/* FFI calls this */ +signed short unbox_signed_2(void) +{ + return to_integer(dpop()); +} diff --git a/native/fixnum.h b/native/fixnum.h index 933f3936b1..08e84998f6 100644 --- a/native/fixnum.h +++ b/native/fixnum.h @@ -28,3 +28,7 @@ void primitive_fixnum_lesseq(void); void primitive_fixnum_greater(void); void primitive_fixnum_greatereq(void); void primitive_fixnum_not(void); +void box_signed_1(signed char integer); +void box_signed_2(signed short integer); +signed char unbox_signed_1(void); +signed short unbox_signed_2(void);