From fea9a6b9bb575e53c7fb7d6caa32209cf3b91e7d Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Fri, 15 Jul 2011 18:21:08 -0700 Subject: [PATCH] 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. --- src/microcode/pruxffi.c | 34 ++++++++++++++++++++++++++++++++++ src/runtime/ffi.scm | 36 ++++++++++++++++++++++++++---------- src/runtime/runtime.pkg | 2 ++ 3 files changed, 62 insertions(+), 10 deletions(-) diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c index fe3bf1c1a..26fc706f2 100644 --- 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); +} #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); +} /* Malloc/Free. */ diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm index 55db9b89b..a0714a371 100644 --- 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)) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 9e2aa0ad2..45160b7a5 100644 --- 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 -- 2.25.1