[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-39-g16f0612

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=16f0612864abae907ddc8b9f9eb982c9ebf22943

The branch, master has been updated
       via  16f0612864abae907ddc8b9f9eb982c9ebf22943 (commit)
       via  42f7c01e0a1d1c139ec8b835429a80ab15ac4007 (commit)
       via  fb636a1cce4444928ab313574fa150a06baae54b (commit)
       via  1f864a1685eac0fd62b4d573ca0ae98c90679e9e (commit)
      from  8a6b693817d396cb3e421f47edba7221f84e3759 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 16f0612864abae907ddc8b9f9eb982c9ebf22943
Author: Ludovic Courtès <address@hidden>
Date:   Thu Nov 11 16:36:29 2010 +0100

    Add FFI tests for `sizeof' and structs.
    
    * test-suite/tests/foreign.test ("structs")["sizeof { int8, double }",
      "sizeof { short, int, long, pointer }"]: New tests.

commit 42f7c01e0a1d1c139ec8b835429a80ab15ac4007
Author: Ludovic Courtès <address@hidden>
Date:   Thu Nov 11 16:26:50 2010 +0100

    Add FFI support for `short' and `unsigned short'.
    
    * libguile/foreign.c (sym_short, sym_unsigned_short): New variables.
      (scm_init_foreign): Define Scheme variables SYM_SHORT and
      SYM_UNSIGNED_SHORT.
    
    * module/system/foreign.scm (short, unsigned-short): New exports.
      (integer-ref, integer-set): Support (= (sizeof TYPE) 2).
      (%read-short, %write-short!, %read-unsigned-short,
      %write-unsigned-short!): New variables.
      (*writers*): Add support for `short' and `unsigned-short'.
      (*readers*): Likewise.
    
    * test-suite/tests/foreign.test ("structs")["int8, pointer, short,
      double"]: New test.

commit fb636a1cce4444928ab313574fa150a06baae54b
Author: Ludovic Courtès <address@hidden>
Date:   Thu Nov 11 16:09:22 2010 +0100

    Have `parse-c-struct' and `make-c-struct' support `int', pointers, etc.
    
    Reported by Tristan Colgate <address@hidden>.
    
    * module/system/foreign.scm: Call `load-extension' at compile-time too.
      (compile-time-value): New macro.
      (integer-ref, integer-set): New procedures.
      (define-integer-reader, define-integer-writer): New macros.
      (%read-int, %read-long, %write-int!, %write-long!, %read-unsigned-int,
      %read-unsigned-long, %write-unsigned-int!, %write-unsigned-long!,
      %read-size_t, %write-size_t!, %read-pointer, %write-pointer!): New
      procedures.
      (*writers*): Add writers for `int', `unsigned-int', `long',
      `unsigned-long', `size_t', and `*'.
      (*readers*): Likewise.
    
    * test-suite/tests/foreign.test ("structs")["int8, pointer",
      "unsigned-long, int8, size_t", "long, int, pointer"]: New tests.

commit 1f864a1685eac0fd62b4d573ca0ae98c90679e9e
Author: Ludovic Courtès <address@hidden>
Date:   Mon Nov 8 23:08:48 2010 +0100

    FFI: Honor alignment constraints in `parse-c-struct'.
    
    * module/system/foreign.scm (parse-c-struct): Honor alignment
      constraints for TYPE.
    
    * test-suite/tests/foreign.test ("structs")["alignment constraints
      honored"]: New test.

-----------------------------------------------------------------------

Summary of changes:
 libguile/foreign.c            |   26 +++++++++
 module/system/foreign.scm     |  117 +++++++++++++++++++++++++++++++++++++++--
 test-suite/tests/foreign.test |   44 +++++++++++++++
 3 files changed, 182 insertions(+), 5 deletions(-)

diff --git a/libguile/foreign.c b/libguile/foreign.c
index 1e91661..6d1bdbf 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -44,8 +44,10 @@ SCM_SYMBOL (sym_uint32, "uint32");
 SCM_SYMBOL (sym_int32, "int32");
 SCM_SYMBOL (sym_uint64, "uint64");
 SCM_SYMBOL (sym_int64, "int64");
+SCM_SYMBOL (sym_short, "short");
 SCM_SYMBOL (sym_int, "int");
 SCM_SYMBOL (sym_long, "long");
+SCM_SYMBOL (sym_unsigned_short, "unsigned-short");
 SCM_SYMBOL (sym_unsigned_int, "unsigned-int");
 SCM_SYMBOL (sym_unsigned_long, "unsigned-long");
 SCM_SYMBOL (sym_size_t, "size_t");
@@ -1039,6 +1041,30 @@ scm_init_foreign (void)
   scm_define (sym_uint64, scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64));
   scm_define (sym_int64, scm_from_uint8 (SCM_FOREIGN_TYPE_INT64));
 
+  scm_define (sym_short,
+#if SIZEOF_SHORT == 8
+             scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
+#elif SIZEOF_SHORT == 4
+             scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
+#elif SIZEOF_SHORT == 2
+             scm_from_uint8 (SCM_FOREIGN_TYPE_INT16)
+#else
+# error unsupported sizeof (short)
+#endif
+             );
+
+  scm_define (sym_unsigned_short,
+#if SIZEOF_SHORT == 8
+             scm_from_uint8 (SCM_FOREIGN_TYPE_UINT64)
+#elif SIZEOF_SHORT == 4
+             scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
+#elif SIZEOF_SHORT == 2
+             scm_from_uint8 (SCM_FOREIGN_TYPE_UINT16)
+#else
+# error unsupported sizeof (short)
+#endif
+             );
+
   scm_define (sym_int,
 #if SIZEOF_INT == 8
              scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index 84d1a03..7f60317 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -21,6 +21,8 @@
   #:use-module (srfi srfi-1)
   #:export (void
             float double
+            short
+            unsigned-short
             int unsigned-int long unsigned-long size_t
             int8 uint8
             uint16 int16
@@ -46,8 +48,9 @@
             ;; procedure->pointer (see below)
             make-c-struct parse-c-struct))
 
-(load-extension (string-append "libguile-" (effective-version))
-                "scm_init_foreign")
+(eval-when (load eval compile)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_foreign"))
 
 
 ;;;
@@ -66,6 +69,86 @@
 ;;; Structures.
 ;;;
 
+(define-syntax compile-time-value
+  (syntax-rules ()
+    "Evaluate the given expression at compile time.  The expression must
+evaluate to a simple datum."
+    ((_ exp)
+     (let-syntax ((v (lambda (s)
+                       (let ((val exp))
+                         (syntax-case s ()
+                           (_ (datum->syntax s val)))))))
+       v))))
+
+(eval-when (eval compile load)
+  ;; The procedures below are used at compile time by the macros below.
+
+  (define (integer-ref type signed?)
+    (case (sizeof type)
+      ((8) (if signed?
+               'bytevector-s64-native-ref
+               'bytevector-u64-native-ref))
+      ((4) (if signed?
+               'bytevector-s32-native-ref
+               'bytevector-u32-native-ref))
+      ((2) (if signed?
+               'bytevector-s16-native-ref
+               'bytevector-u16-native-ref))
+      (else
+       (error "what machine is this?" type (sizeof type)))))
+
+  (define (integer-set type signed?)
+    (case (sizeof type)
+      ((8) (if signed?
+               'bytevector-s64-native-set!
+               'bytevector-u64-native-set!))
+      ((4) (if signed?
+               'bytevector-s32-native-set!
+               'bytevector-u32-native-set!))
+      ((2) (if signed?
+               'bytevector-s16-native-set!
+               'bytevector-u16-native-set!))
+      (else
+       (error "what machine is this?" type (sizeof type))))))
+
+(define-syntax define-integer-reader
+  (syntax-rules ()
+    ((_ name type signed?)
+     (letrec-syntax ((ref (identifier-syntax
+                           (compile-time-value
+                            (integer-ref type signed?)))))
+       (define name ref)))))
+
+(define-syntax define-integer-writer
+  (syntax-rules ()
+    ((_ name type signed?)
+     (letrec-syntax ((set (identifier-syntax
+                           (compile-time-value
+                            (integer-set type signed?)))))
+       (define name set)))))
+
+
+(define-integer-reader %read-short short #t)
+(define-integer-reader %read-int int #t)
+(define-integer-reader %read-long long #t)
+(define-integer-writer %write-short! short #t)
+(define-integer-writer %write-int! int #t)
+(define-integer-writer %write-long! long #t)
+
+(define-integer-reader %read-unsigned-short unsigned-short #f)
+(define-integer-reader %read-unsigned-int unsigned-int #f)
+(define-integer-reader %read-unsigned-long unsigned-long #f)
+(define-integer-writer %write-unsigned-short! unsigned-short #f)
+(define-integer-writer %write-unsigned-int! unsigned-int #f)
+(define-integer-writer %write-unsigned-long! unsigned-long #f)
+
+(define-integer-reader %read-size_t size_t #f)
+(define-integer-writer %write-size_t! size_t #f)
+
+(define-integer-reader %read-pointer '* #f)
+(define-integer-writer %write-pointer! '* #f)
+
+
 (define *writers*
   `((,float . ,bytevector-ieee-single-native-set!)
     (,double . ,bytevector-ieee-double-native-set!)
@@ -76,7 +159,19 @@
     (,int32 . ,bytevector-s32-native-set!)
     (,uint32 . ,bytevector-u32-native-set!)
     (,int64 . ,bytevector-s64-native-set!)
-    (,uint64 . ,bytevector-u64-native-set!)))
+    (,uint64 . ,bytevector-u64-native-set!)
+
+    (,short         . ,%write-short!)
+    (,unsigned-short . ,%write-unsigned-short!)
+    (,int           . ,%write-int!)
+    (,unsigned-int  . ,%write-unsigned-int!)
+    (,long          . ,%write-long!)
+    (,unsigned-long . ,%write-unsigned-long!)
+    (,size_t        . ,%write-size_t!)
+
+    (*              . ,(lambda (bv offset ptr)
+                         (%write-pointer! bv offset
+                                          (pointer-address ptr))))))
 
 (define *readers*
   `((,float . ,bytevector-ieee-single-native-ref)
@@ -88,7 +183,18 @@
     (,int32 . ,bytevector-s32-native-ref)
     (,uint32 . ,bytevector-u32-native-ref)
     (,int64 . ,bytevector-s64-native-ref)
-    (,uint64 . ,bytevector-u64-native-ref)))
+    (,uint64 . ,bytevector-u64-native-ref)
+
+    (,short         . ,%read-short)
+    (,unsigned-short . ,%read-unsigned-short)
+    (,int           . ,%read-int)
+    (,unsigned-int  . ,%read-unsigned-int)
+    (,long          . ,%read-long)
+    (,unsigned-long . ,%read-unsigned-long)
+    (,size_t        . ,%read-size_t)
+
+    (*              . ,(lambda (bv offset)
+                         (make-pointer (%read-pointer bv offset))))))
 
 (define (align off alignment)
   (1+ (logior (1- off) (1- alignment))))
@@ -132,7 +238,8 @@
 
 (define (parse-c-struct foreign types)
   (let ((size (fold (lambda (type total)
-                      (+ (sizeof type) total))
+                      (+ (sizeof type)
+                         (align total (alignof type))))
                     0
                     types)))
     (read-c-struct (pointer->bytevector foreign size) 0 types)))
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index db92eca..59ea6b9 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -177,9 +177,53 @@
 
 (with-test-prefix "structs"
 
+  (pass-if "sizeof { int8, double }"
+    (= (sizeof (list int8 double))
+       (+ (alignof double) (sizeof double))))
+
+  (pass-if "sizeof { short, int, long, pointer }"
+    (let ((layout (list short int long '*)))
+      (>= (sizeof layout)
+          (reduce + 0.0 (map sizeof layout)))))
+
   (pass-if "parse-c-struct"
     (let ((layout (list int64 uint8))
           (data   (list -300 43)))
       (equal? (parse-c-struct (make-c-struct layout data)
                               layout)
+              data)))
+
+  (pass-if "alignment constraints honored"
+    (let ((layout (list int8 double))
+          (data   (list -7 3.14)))
+      (equal? (parse-c-struct (make-c-struct layout data)
+                              layout)
+              data)))
+
+  (pass-if "int8, pointer"
+    (let ((layout (list uint8 '*))
+          (data   (list 222 (make-pointer 7777))))
+      (equal? (parse-c-struct (make-c-struct layout data)
+                              layout)
+              data)))
+
+  (pass-if "unsigned-long, int8, size_t"
+    (let ((layout (list unsigned-long int8 size_t))
+          (data   (list (expt 2 17) -128 (expt 2 18))))
+      (equal? (parse-c-struct (make-c-struct layout data)
+                              layout)
+              data)))
+
+  (pass-if "long, int, pointer"
+    (let ((layout (list long int '*))
+          (data   (list (- (expt 2 17)) -222 (make-pointer 777))))
+      (equal? (parse-c-struct (make-c-struct layout data)
+                              layout)
+              data)))
+
+  (pass-if "int8, pointer, short, double"
+    (let ((layout (list int8 '* short double))
+          (data   (list 77 %null-pointer -42 3.14)))
+      (equal? (parse-c-struct (make-c-struct layout data)
+                              layout)
               data))))


hooks/post-receive
-- 
GNU Guile