better C type support in FFI

Makefile

@@ -1,7 +1,7 @@
 CC = gcc
 
 # On FreeBSD, to use SDL and other libc_r libs:
-CFLAGS = -Os -g -Wall -pthread -export-dynamic
+CFLAGS = -g -Wall -pthread -export-dynamic
 # On PowerPC G5:
 # CFLAGS = -mcpu=970 -mtune=970 -mpowerpc64 -ffast-math -O3
 # On Pentium 4:

TODO.FACTOR.txt

@@ -4,6 +4,7 @@ FFI:
 [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)
 [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)
 
+- profiler is inaccurate: wrong word on cs
 - buffer change handler in sidekick is screwed
 - dec> bin> oct> hex> throw errors
 - parse-number doesn't

library/compiler/alien-macros.factor

@@ -0,0 +1,51 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: alien
+USE: compiler
+USE: lists
+USE: namespaces
+USE: stack
+
+: UNBOX ( name -- )
+    #! Move top of datastack to C stack.
+    dlsym-self CALL drop
+    EAX PUSH-R ;
+
+: BOX ( name -- )
+    #! Move EAX to datastack.
+    24 ESP R-I
+    EAX PUSH-R
+    dlsym-self CALL drop
+    28 ESP R+I ;
+
+: PARAMETERS ( list -- )
+    #! Generate code for boxing a list of C types.
+    [ c-type [ "unboxer" get ] bind UNBOX ] each ;
+
+: RETURNS ( type -- )
+    c-type [ "boxer" get ] bind BOX ;

library/compiler/alien-types.factor

@@ -0,0 +1,149 @@
+! :folding=indent:collapseFolds=0:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: alien
+USE: combinators
+USE: compiler
+USE: errors
+USE: lists
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: words
+
+! Some code for interfacing with C structures.
+
+: <c-type> ( -- type )
+    <namespace> [
+        [ "No setter" throw ] "setter" set
+        [ "No getter" throw ] "getter" set
+        "no boxer" "boxer" set
+        "no unboxer" "unboxer" set
+        0 "width" set
+    ] extend ;
+
+: c-types ( -- ns )
+    global [ "c-types" get ] bind ;
+
+: c-type ( name -- type )
+    global [
+        dup "c-types" get get* dup [
+            nip
+        ] [
+            drop "No such C type: " swap cat2 throw
+        ] ifte
+    ] bind ;
+
+: define-c-type ( quot name -- )
+    c-types [ >r <c-type> swap extend r> set ] bind ;
+
+: define-getter ( offset type name -- )
+    #! Define a word with stack effect ( alien -- obj ) in the
+    #! current 'in' vocabulary.
+    "in" get create >r
+    [ "getter" get ] bind cons r> swap define-compound ;
+
+: define-setter ( offset type name -- )
+    #! Define a word with stack effect ( obj alien -- ) in the
+    #! current 'in' vocabulary.
+    "set-" swap cat2 "in" get create >r
+    [ "setter" get ] bind cons r> swap define-compound ;
+
+: define-field ( offset spec -- offset )
+    unswons >r c-type dup >r [ "width" get ] bind align r> r>
+    "struct-name" get swap "-" swap cat3
+    ( offset type name -- )
+    3dup define-getter 3dup define-setter
+    drop [ "width" get ] bind + ;
+
+: define-constructor ( len -- )
+    [ <alien> ] cons
+    <% "<" % "struct-name" get % ">" % %> "in" get create swap
+    define-compound ;
+
+: define-struct-type ( len -- )
+    #! For example, if len is 32, make a C type with getter:
+    #! [ 32 >r alien-cell r> <alien> ] cons
+    #! The setter just throws an error for now.
+    [
+        [ >r alien-cell r> <alien> ] cons "getter" set
+        "unbox_alien" "unboxer" set
+        cell "width" set
+    ] "struct-name" get "*" cat2 define-c-type ;
+
+: define-struct ( spec name -- )
+    #! Define a set of words for working with a C structure
+    #! alien.
+    [
+        "struct-name" set
+        0 swap [ define-field ] each
+        dup define-constructor
+        define-struct-type
+    ] with-scope ;
+
+global [ <namespace> "c-types" set ] bind
+
+[
+    [ alien-cell ] "getter" set
+    [ set-alien-cell ] "setter" set
+    cell "width" set
+    "does_not_exist" "boxer" set
+    "unbox_alien" "unboxer" set
+] "void*" define-c-type
+
+[
+    [ alien-4 ] "getter" set
+    [ set-alien-4 ] "setter" set
+    4 "width" set
+    "box_integer" "boxer" set
+    "unbox_integer" "unboxer" set
+] "int" define-c-type
+
+[
+    [ alien-2 ] "getter" set
+    [ set-alien-2 ] "setter" set
+    2 "width" set
+    "box_integer" "boxer" set
+    "unbox_integer" "unboxer" set
+] "short" define-c-type
+
+[
+    [ alien-1 ] "getter" set
+    [ set-alien-1 ] "setter" set
+    1 "width" set
+    "box_integer" "boxer" set
+    "unbox_integer" "unboxer" set
+] "char" define-c-type
+
+[
+    [ alien-4 ] "getter" set
+    [ set-alien-4 ] "setter" set
+    cell "width" set
+    "box_c_string" "boxer" set
+    "unbox_c_string" "unboxer" set
+] "char*" define-c-type

library/compiler/assembler.factor

@@ -38,11 +38,7 @@ USE: stack
     compiled-offset literal-table + set-compiled-offset ;
 
 : compile-aligned ( n -- )
-    dup compiled-offset mod dup 0 = [
+    compiled-offset swap align set-compiled-offset ;
-        2drop
-    ] [
-        - compiled-offset + set-compiled-offset
-    ] ifte ;
 
 : intern-literal ( obj -- lit# )
     address-of

library/compiler/assembly-x86.factor

@@ -147,37 +147,6 @@ USE: combinators
         compile-cell
     ] ifte ;
 
-: LITERAL ( cell -- )
-    #! Push literal on data stack.
-    #! Assume that it is ok to clobber EAX without saving.
-    DATASTACK EAX [I]>R
-    EAX I>[R]
-    4 DATASTACK I+[I] ;
-
-: [LITERAL] ( cell -- )
-    #! Push complex literal on data stack by following an
-    #! indirect pointer.
-    ECX PUSH-R
-    ( cell -- ) ECX [I]>R
-    DATASTACK EAX [I]>R
-    ECX EAX R>[R]
-    4 DATASTACK I+[I]
-    ECX POP-R ;
-
-: PUSH-DS ( -- )
-    #! Push contents of EAX onto datastack.
-    ECX PUSH-R
-    DATASTACK ECX [I]>R
-    EAX ECX R>[R]
-    4 DATASTACK I+[I]
-    ECX POP-R ;
-
-: POP-DS ( -- )
-    #! Pop datastack, store pointer to datastack top in EAX.
-    DATASTACK EAX [I]>R
-    4 EAX R-I
-    EAX DATASTACK R>[I] ;
-
 : fixup ( addr where -- )
     #! Encode a relative offset to addr from where at where.
     #! Add 4 because addr is relative to *after* insn.

library/compiler/compiler-macros.factor

@@ -0,0 +1,59 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: compiler
+
+: LITERAL ( cell -- )
+    #! Push literal on data stack.
+    #! Assume that it is ok to clobber EAX without saving.
+    DATASTACK EAX [I]>R
+    EAX I>[R]
+    4 DATASTACK I+[I] ;
+
+: [LITERAL] ( cell -- )
+    #! Push complex literal on data stack by following an
+    #! indirect pointer.
+    ECX PUSH-R
+    ( cell -- ) ECX [I]>R
+    DATASTACK EAX [I]>R
+    ECX EAX R>[R]
+    4 DATASTACK I+[I]
+    ECX POP-R ;
+
+: PUSH-DS ( -- )
+    #! Push contents of EAX onto datastack.
+    ECX PUSH-R
+    DATASTACK ECX [I]>R
+    EAX ECX R>[R]
+    4 DATASTACK I+[I]
+    ECX POP-R ;
+
+: POP-DS ( -- )
+    #! Pop datastack, store pointer to datastack top in EAX.
+    DATASTACK EAX [I]>R
+    4 EAX R-I
+    EAX DATASTACK R>[I] ;

library/cross-compiler.factor

@@ -50,6 +50,8 @@ DEFER: alien-cell
 DEFER: set-alien-cell
 DEFER: alien-4
 DEFER: set-alien-4
+DEFER: alien-2
+DEFER: set-alien-2
 DEFER: alien-1
 DEFER: set-alien-1
 
@@ -370,6 +372,8 @@ IN: image
         set-alien-cell
         alien-4
         set-alien-4
+        alien-2
+        set-alien-2
         alien-1
         set-alien-1
     ] [

library/math/math.factor

@@ -78,3 +78,6 @@ USE: stack
 
 : polar> ( abs arg -- z )
     cis * ; inline
+
+: align ( offset width -- offset )
+    2dup mod dup 0 = [ 2drop ] [ - + ] ifte ;

library/platform/native/boot-stage2.factor

@@ -133,8 +133,11 @@ USE: stdio
 
     "/library/compiler/assembler.factor"
     "/library/compiler/assembly-x86.factor"
+    "/library/compiler/compiler-macros.factor"
     "/library/compiler/compiler.factor"
     "/library/compiler/words.factor"
+    "/library/compiler/alien-types.factor"
+    "/library/compiler/alien-macros.factor"
 
     "/library/platform/native/primitives.factor"
 

library/platform/native/primitives.factor

@@ -228,6 +228,8 @@ USE: words
     [ set-alien-cell         | " n alien off -- " ]
     [ alien-4                | " alien off -- n " ]
     [ set-alien-4            | " n alien off -- " ]
+    [ alien-2                | " alien off -- n " ]
+    [ set-alien-2            | " n alien off -- " ]
     [ alien-1                | " alien off -- n " ]
     [ set-alien-1            | " n alien off -- " ]
 ] [

library/test/crashes.factor

@@ -8,6 +8,7 @@ USE: stack
 USE: strings
 USE: test
 USE: vectors
+USE: lists
 
 ! Various things that broke CFactor at various times.
 ! This should run without issue (and tests nothing useful)
@@ -32,3 +33,25 @@ USE: vectors
 10 [ [ -1000000 <vector> ] [ drop ] catch ] times
 
 10 [ [ -1000000 <sbuf> ] [ drop ] catch ] times
+
+! Make sure various type checks don't run into header untagging
+! problems etc.
+
+! Lotype -vs- lotype
+[ ] [ [ 4 car ] [ drop ] catch ] unit-test
+
+! Lotype -vs- hitype
+[ ] [ [ 4 vector-length ] [ drop ] catch ] unit-test
+[ ] [ [ [ 4 3 ] vector-length ] [ drop ] catch ] unit-test
+
+! Hitype -vs- lotype
+[ ] [ [ "hello" car ] [ drop ] catch ] unit-test
+
+! Hitype -vs- hitype
+[ ] [ [ "hello" vector-length ] [ drop ] catch ] unit-test
+
+! f -vs- lotype
+[ ] [ [ f car ] [ drop ] catch ] unit-test
+
+! f -vs- hitype
+[ ] [ [ f vector-length ] [ drop ] catch ] unit-test

library/test/math/bitops.factor

@@ -48,3 +48,9 @@ USE: lists
         -1 over shift swap -1 >bignum swap shift = and
     ] each
 ] unit-test
+
+[ 12 ] [ 11 4 align ] unit-test
+[ 12 ] [ 12 4 align ] unit-test
+[ 12 ] [ 10 2 align ] unit-test
+[ 14 ] [ 13 2 align ] unit-test
+[ 11 ] [ 11 1 align ] unit-test

native/ffi.c

@@ -81,6 +81,11 @@ void primitive_alien(void)
 #endif
 }
 
+ALIEN* unbox_alien(void)
+{
+	return untag_alien(dpop())->ptr;
+}
+
 INLINE CELL alien_pointer(void)
 {
 	FIXNUM offset = unbox_integer();
@@ -135,6 +140,27 @@ void primitive_set_alien_4(void)
 #endif
 }
 
+void primitive_alien_2(void)
+{
+#ifdef FFI
+	CELL ptr = alien_pointer();
+	box_integer(*(CHAR*)ptr);
+#else
+	general_error(ERROR_FFI_DISABLED,F);
+#endif
+}
+
+void primitive_set_alien_2(void)
+{
+#ifdef FFI
+	CELL ptr = alien_pointer();
+	CELL value = unbox_integer();
+	*(CHAR*)ptr = value;
+#else
+	general_error(ERROR_FFI_DISABLED,F);
+#endif
+}
+
 void primitive_alien_1(void)
 {
 #ifdef FFI

native/ffi.h

@@ -26,9 +26,12 @@ void primitive_dlsym(void);
 void primitive_dlsym_self(void);
 void primitive_dlclose(void);
 void primitive_alien(void);
+ALIEN* unbox_alien(void);
 void primitive_alien_cell(void);
 void primitive_set_alien_cell(void);
 void primitive_alien_4(void);
 void primitive_set_alien_4(void);
+void primitive_alien_2(void);
+void primitive_set_alien_2(void);
 void primitive_alien_1(void);
 void primitive_set_alien_1(void);

native/primitives.c

@@ -187,6 +187,8 @@ XT primitives[] = {
 	primitive_set_alien_cell,
 	primitive_alien_4,
 	primitive_set_alien_4,
+	primitive_alien_2,
+	primitive_set_alien_2,
 	primitive_alien_1,
 	primitive_set_alien_1
 };

native/primitives.h

@@ -1,4 +1,4 @@
 extern XT primitives[];
-#define PRIMITIVE_COUNT 188
+#define PRIMITIVE_COUNT 190
 
 CELL primitive_to_xt(CELL primitive);

native/types.h

@@ -83,11 +83,21 @@ INLINE void type_check(CELL type, CELL tagged)
 {
 	if(type < HEADER_TYPE)
 	{
-		if(TAG(tagged) != type)
+		if(TAG(tagged) == type)
-			type_error(type,tagged);
+			return;
 	}
-	else if(object_type(tagged) != type)
+	else if(tagged == F)
-		type_error(type,tagged);
+	{
+		if(type == F_TYPE)
+			return;
+	}
+	else if(TAG(tagged) == OBJECT_TYPE
+		&& object_type(tagged) == type)
+	{
+		return;
+	}
+
+	type_error(type,tagged);
 }
 
 void* allot_object(CELL type, CELL length);