Have `parse-c-struct' and `make-c-struct' support `int', pointers, etc.

Reported by Tristan Colgate <tcolgate@gmail.com>.

* 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.

diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index 2990521..c3601a6 100644 (file)
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -46,8 +46,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"))
 
 \f
 ;;;
@@ -66,6 +67,76 @@
 ;;; 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))
+      (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!))
+      (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-int int #t)
+(define-integer-reader %read-long long #t)
+(define-integer-writer %write-int! int #t)
+(define-integer-writer %write-long! long #t)
+
+(define-integer-reader %read-unsigned-int unsigned-int #f)
+(define-integer-reader %read-unsigned-long unsigned-long #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 +147,17 @@
     (,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!)
+
+    (,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 +169,16 @@
     (,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)
+
+    (,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))))

diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 05846ed..d741b7e 100644 (file)
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -187,6 +187,27 @@
   (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))))