alien fixes, sdl fixes, lotsa other stuff

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!

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 <alien> ;
+
 global [ <namespace> "c-types" set ] bind
 
 [
@@ -141,40 +145,40 @@ global [ <namespace> "c-types" set ] bind
     [ alien-4 ] "getter" set
     [ set-alien-4 ] "setter" set
     4 "width" set
-    "box_integer" "boxer" set
+    "box_cell" "boxer" set
-    "unbox_integer" "unboxer" 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
+    "box_signed_2" "boxer" set
-    "unbox_integer" "unboxer" 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
+    "box_cell" "boxer" set
-    "unbox_integer" "unboxer" 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
+    "box_signed_1" "boxer" set
-    "unbox_integer" "unboxer" 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
+    "box_cell" "boxer" set
-    "unbox_integer" "unboxer" set
+    "unbox_cell" "unboxer" set
 ] "uchar" define-c-type
 
 [

library/math/arithmetic.factor

@@ -53,8 +53,9 @@ USE: stack
     2dup < [ drop ] [ nip ] ifte ;
 
 : between? ( x min max -- ? )
-    #! Push if min <= x <= max.
+    #! Push if min <= x <= max. Handles case where min > max
-    >r dupd max r> min = ;
+    #! by swapping them.
+    2dup > [ swap ] when  >r dupd max r> min = ;
 
 : sq dup * ; inline
 

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 ] )

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 -- )

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"
+    "uint" "sdl" "SDL_MapRGB"
-    [ "surface*" "char" "char" "char" ] alien-call ;
+    [ "surface*" "uchar" "uchar" "uchar" ] alien-call ;

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
 

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

library/test/test.factor

@@ -113,6 +113,7 @@ USE: unparser
         "crashes" test
         "sbuf" test
         "threads" test
+        "parsing-word" test
 
         cpu "x86" = [
             [

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;

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);

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);

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());
+}

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);