Added c-peek-bytes, c-poke-bytes. Recycle callback ids.

Made all such like procedures integrable.  Added
registered-callback-count, to test for proper callback cleanup.

diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index fe3bf1c1a952d0dd64ce709d6ae5d0277fe7d91e..26fc706f2c1a26855c0338cbf2cd701c5533e915 100644 (file)
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -190,6 +190,23 @@ DEFINE_PRIMITIVE ("C-PEEK-CSTRINGP!", Prim_peek_cstringp_bang, 2, 2, 0)
     PRIMITIVE_RETURN (string);
   }
 }
+
+DEFINE_PRIMITIVE ("C-PEEK-BYTES", Prim_peek_bytes, 5, 5, 0)
+{
+  /* Copy, from ALIEN+OFFSET, COUNT bytes to STRING[START..]. */
+
+  PRIMITIVE_HEADER (5);
+  CHECK_ARG (4, STRING_P);
+  {
+    const void * src = (ALIEN_ADDRESS_LOC (void *));
+    int count = (UNSIGNED_FIXNUM_ARG (3));
+    SCM string = (ARG_REF (4));
+    int index = arg_index_integer (5, (STRING_LENGTH (string)));
+    void * dest = STRING_LOC (string, index);
+    memcpy (dest, src, count);
+  }
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}
 \f
 #define C_POKER(type, value_arg_ref)                                   \
 {                                                                      \
@@ -281,6 +298,23 @@ DEFINE_PRIMITIVE ("C-POKE-STRING!", Prim_poke_string_bang, 3, 3, 0)
   }
   PRIMITIVE_RETURN (UNSPECIFIC);
 }
+
+DEFINE_PRIMITIVE ("C-POKE-BYTES", Prim_poke_bytes, 5, 5, 0)
+{
+  /* Copy to ALIEN+OFFSET COUNT bytes from STRING[START]. */
+
+  PRIMITIVE_HEADER (5);
+  CHECK_ARG (4, STRING_P);
+  {
+    void * dest = (ALIEN_ADDRESS_LOC (void *));
+    int count = (UNSIGNED_FIXNUM_ARG (3));
+    SCM string = (ARG_REF (4));
+    int index = arg_index_integer (5, (STRING_LENGTH (string)));
+    const void * src = STRING_LOC (string, index);
+    memcpy (dest, src, count);
+  }
+  PRIMITIVE_RETURN (UNSPECIFIC);
+}
 \f
 /* Malloc/Free. */
 

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 55db9b89bc02ef8980a0dabc857cd3461ac24c45..a0714a3711ecc795e7b3869e9d033c5aebb8d759 100644 (file)
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -272,19 +272,22 @@ USA.
            (error:bad-range-argument afunc 'alien-function-cache!))
        (set-%alien-function/band-id! afunc band-id))))
 
-(define (c-peek-cstring alien)
+(define-integrable (c-peek-cstring alien)
   ((ucode-primitive c-peek-cstring 2) alien 0))
 
-(define (c-peek-cstring! alien)
+(define-integrable (c-peek-cstring! alien)
   ((ucode-primitive c-peek-cstring! 2) alien 0))
 
-(define (c-peek-cstringp alien)
+(define-integrable (c-peek-cstringp alien)
   ((ucode-primitive c-peek-cstringp 2) alien 0))
 
-(define (c-peek-cstringp! alien)
+(define-integrable (c-peek-cstringp! alien)
   ((ucode-primitive c-peek-cstringp! 2) alien 0))
 
-(define (c-poke-pointer dest alien)
+(define-integrable (c-peek-bytes alien offset count buffer start)
+  ((ucode-primitive c-peek-bytes 5) alien offset count buffer start))
+
+(define-integrable (c-poke-pointer dest alien)
   ;; Sets the pointer at the alien DEST to point to the ALIEN.
   ((ucode-primitive c-poke-pointer 3) dest 0 alien))
 
@@ -303,6 +306,9 @@ USA.
   (guarantee-string string 'C-POKE-STRING)
   ((ucode-primitive c-poke-string! 3) alien 0 string))
 
+(define-integrable (c-poke-bytes alien offset count buffer start)
+  ((ucode-primitive c-poke-bytes 5) alien offset count buffer start))
+
 (define (c-enum-name value enum-name constants)
   enum-name
   (let loop ((consts constants))
@@ -446,10 +452,8 @@ USA.
 
 (define (de-register-c-callback id)
   (vector-set! registered-callbacks id #f)
-  ;; Uncomment to recycle ids.
-  ;;(if (< id first-free-id)
-  ;;    (set! first-free-id id))
-  )
+  (if (< id first-free-id)
+      (set! first-free-id id)))
 
 (define (normalize-aliens! args)
   ;; Any vectors among ARGS are assumed to be freshly-consed aliens
@@ -506,13 +510,25 @@ USA.
                (error "Cannot return from a callback more than once.")
                (loop)))))))))
 
-;; For callback debugging...
+;;; For callback debugging:
+
 (define (outf-console . objects)
   ((ucode-primitive outf-console 1)
    (apply string-append
          (map (lambda (o) (if (string? o) o (write-to-string o)))
               objects))))
 
+(define (registered-callback-count)
+  (let* ((vector registered-callbacks)
+        (end (vector-length vector)))
+    (let loop ((i 0)(count 0))
+      (if (fix:< i end)
+         (loop (fix:1+ i)
+               (if (vector-ref vector i)
+                   (fix:1+ count)
+                   count))
+         (cons count end)))))
+
 (define (initialize-callbacks!)
   (vector-set! (get-fixed-objects-vector) #x41 callback-handler))
 \f

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 9e2aa0ad247a4d22ce91e033c1db5e3492cd1942..45160b7a5bc13c5f83a31772a54c13a31a8575df 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3288,10 +3288,12 @@ USA.
          c-peek-cstring!
          c-peek-cstringp
          c-peek-cstringp!
+         c-peek-bytes
          c-poke-pointer
          c-poke-pointer!
          c-poke-string
          c-poke-string!
+         c-poke-bytes
          c-enum-name
          call-alien
          make-alien-to-free