Simplify the (system foreign) API.

Suggested by Neil Jerram.

* libguile/foreign.h (SCM_FOREIGN_TYPE, SCM_FOREIGN_VALUE_REF,
  SCM_FOREIGN_VALUE_SET, SCM_FOREIGN_LEN, SCM_FOREIGN_TYPED_P,
  SCM_FOREIGN_VALUE_P, SCM_VALIDATE_FOREIGN_VALUE, scm_foreign_set_x,
  scm_foreign_type): Remove.
  (scm_foreign_ref): Rename to...
  (scm_foreign_address): ... this.
  (scm_take_foreign_pointer): Update.
  (SCM_FOREIGN_POINTER): Remove CTYPE argument.  Update callers.
  (scm_make_pointer): New declaration.

* libguile/foreign.c (scm_to_uintptr, scm_from_uintptr): New macros.
  (scm_make_pointer): New function.
  (scm_take_foreign_pointer): Remove TYPE and LEN arguments.  Update
  callers.
  (scm_foreign_ref): Remove to...
  (scm_foreign_address): ... this.  Remove type-related code.
  (scm_foreign_set_x): Remove.
  (scm_foreign_to_bytevector): Change argument order; make LEN argument
  compulsory.
  (scm_i_foreign_print): Remove type printing.
  (unpack): Remove foreign-type checking.

* libguile/deprecated.c (scm_dynamic_args_call): Update accordingly.

* libguile/dynl.c (scm_dynamic_pointer): Remove the TYPE and LEN
  arguments; update callers.  Update to the new foreign API.

* libguile/dynl.h (scm_dynamic_pointer): Update.

* libguile/gsubr.c (create_gsubr): Update to the new foreign API.

* libguile/gsubr.h (SCM_SUBRF, SCM_SUBR_GENERIC): Ditto.

* libguile/snarf.h (SCM_IMMUTABLE_FOREIGN): Ditto.

* libguile/vm-i-system.c (subr_call): Ditto.

* module/system/foreign.scm (null-pointer?): New procedure.

* test-suite/standalone/test-ffi: Update to the new
  `bytevector->foreign' signature.

* test-suite/tests/foreign.test ("null pointer")["null pointer
  identity", "null-pointer? %null-pointer"]: New tests.
  ["foreign-set! other-null-pointer", "foreign->bytevector
  other-null-pointer"]: Remove.
  ("make-pointer", "foreign<->bytevector"): New test prefixes.

test-suite/standalone/test-ffi

@@ -165,12 +165,13 @@ exec guile -q -s "$0" "$@"
 (define f-memcpy
   (make-foreign-function '* (dynamic-func "test_ffi_memcpy" lib)
                          (list '* '* int32)))
-(let* ((src (bytevector->foreign (u8-list->bytevector '(0 1 2 3 4 5 6 7))))
+(let* ((src* '(0 1 2 3 4 5 6 7))
+       (src  (bytevector->foreign (u8-list->bytevector src*)))
        (dest (bytevector->foreign (make-bytevector 16 0)))
-       (res (f-memcpy dest src (bytevector-length (foreign->bytevector src)))))
-  (or (= (foreign-ref dest) (foreign-ref res))
+       (res  (f-memcpy dest src (length src*))))
+  (or (= (foreign-address dest) (foreign-address res))
       (error "memcpy res not equal to dest"))
-  (or (equal? (bytevector->u8-list (foreign->bytevector dest))
+  (or (equal? (bytevector->u8-list (foreign->bytevector dest 16))
               '(0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0))
       (error "unexpected dest")))
 
@@ -196,7 +197,7 @@ exec guile -q -s "$0" "$@"
 
 (let* ((ptr (strerror ENOENT))
        (len (strlen ptr))
-       (bv  (foreign->bytevector ptr 'u8 0 len))
+       (bv  (foreign->bytevector ptr len 0 'u8))
        (str (utf8->string bv)))
   (test #t (not (not (string-contains str "file")))))
 

test-suite/tests/foreign.test

@@ -23,35 +23,47 @@
 (define-module (test-foreign)
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
   #:use-module (test-suite lib))
 
 
 (with-test-prefix "null pointer"
 
   (pass-if "zero"
-    (= 0 (foreign-ref %null-pointer)))
+    (= 0 (foreign-address %null-pointer)))
 
-  (pass-if-exception "foreign-set! %null-pointer"
-    exception:null-pointer-error
-    (foreign-set! %null-pointer 2))
+  (pass-if "null pointer identity"
+    (eq? %null-pointer (make-pointer 0)))
 
-  (pass-if "foreign-set! other-null-pointer"
-    (let ((f (bytevector->foreign (make-bytevector 2))))
-      (and (not (= 0 (foreign-ref f)))
-           (begin
-             (foreign-set! f 0)
-             (= 0 (foreign-ref f)))
-           (begin
-             ;; Here changing the pointer value of F is perfectly valid.
-             (foreign-set! f 777)
-             (= 777 (foreign-ref f))))))
+  (pass-if "null-pointer? %null-pointer"
+    (null-pointer? %null-pointer))
 
   (pass-if-exception "foreign->bytevector %null-pointer"
     exception:null-pointer-error
-    (foreign->bytevector %null-pointer))
+    (foreign->bytevector %null-pointer 7)))
 
-  (pass-if-exception "foreign->bytevector other-null-pointer"
-    exception:null-pointer-error
-    (let ((f (bytevector->foreign (make-bytevector 2))))
-      (foreign-set! f 0)
-      (foreign->bytevector f))))
+
+(with-test-prefix "make-pointer"
+
+  (pass-if "address preserved"
+    (= 123 (foreign-address (make-pointer 123)))))
+
+
+(with-test-prefix "foreign<->bytevector"
+
+  (pass-if "bijection"
+    (let ((bv #vu8(0 1 2 3 4 5 6 7)))
+      (equal? (foreign->bytevector (bytevector->foreign bv)
+                                   (bytevector-length bv))
+              bv)))
+
+  (pass-if "pointer from bits"
+    (let* ((bytes (iota (sizeof '*)))
+           (bv    (u8-list->bytevector bytes)))
+      (= (foreign-address
+          (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
+                                             (sizeof '*))))
+         (fold-right (lambda (byte address)
+                       (+ byte (* 256 address)))
+                     0
+                     bytes)))))