foreign: c-struct parsing simplification

* module/system/foreign.scm: Revert much of fb636a1cce. Short et al are
  not distinct types -- they are all aliases to e.g. int16. The only
  case that was not covered before was the pointer case.
  (bytevector-pointer-ref, bytevector-pointer-set!): Implement these,
  and use them for pointers.

diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index 7f60317..b15577b 100644 (file)
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -69,85 +69,21 @@
 ;;; 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 bytevector-pointer-ref
+  (case (sizeof '*)
+    ((8) (lambda (bv offset)
+           (make-pointer (bytevector-u64-native-ref bv offset))))
+    ((4) (lambda (bv offset)
+           (make-pointer (bytevector-u32-native-ref bv offset))))
+    (else (error "what machine is this?"))))
+
+(define bytevector-pointer-set!
+  (case (sizeof '*)
+    ((8) (lambda (bv offset ptr)
+           (bytevector-u64-native-set! bv offset (pointer-address ptr))))
+    ((4) (lambda (bv offset ptr)
+           (bytevector-u32-native-set! bv offset (pointer-address ptr))))
+    (else (error "what machine is this?"))))
 
 (define *writers*
   `((,float . ,bytevector-ieee-single-native-set!)
@@ -160,18 +96,7 @@ evaluate to a simple datum."
     (,uint32 . ,bytevector-u32-native-set!)
     (,int64 . ,bytevector-s64-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))))))
+    (* . ,bytevector-pointer-set!)))
 
 (define *readers*
   `((,float . ,bytevector-ieee-single-native-ref)
@@ -184,17 +109,8 @@ evaluate to a simple datum."
     (,uint32 . ,bytevector-u32-native-ref)
     (,int64 . ,bytevector-s64-native-ref)
     (,uint64 . ,bytevector-u64-native-ref)
+    (* . ,bytevector-pointer-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))))