From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Fri, 19 Aug 2011 02:42:36 +0000 (-0700)
Subject: Added c-peek-bytes, c-poke-bytes.
X-Git-Tag: release-9.2.0~347^2~2^2~4
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=886dc4489099c7935167175af14488b9d8fe5831;p=mit-scheme.git

Added c-peek-bytes, c-poke-bytes.
---

diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index 2f45ea3da..b0bbc8bc0 100644
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -214,6 +214,23 @@ DEFINE_PRIMITIVE ("C-PEEK-CSTRINGP!", Prim_peek_cstringp_bang, 2, 2, 0)
       }
   }
 }
+
+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)					\
 {									\
@@ -305,6 +322,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 7ee4bd6a0..2e629e920 100644
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -96,6 +96,11 @@ USA.
   (+ (* (%alien/high-bits alien) (radix))
      (%alien/low-bits alien)))
 
+(define (%set-alien/address! alien address)
+  (let ((qr (integer-divide address (radix))))
+    (set-%alien/high-bits! alien (integer-divide-quotient qr))
+    (set-%alien/low-bits! alien (integer-divide-remainder qr))))
+
 (declare (integrate-operator copy-alien-address!))
 (define (copy-alien-address! alien source)
   (if (not (eq? alien source))
@@ -267,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))
 
@@ -298,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))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 99cefe50b..0dd1fef85 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3271,10 +3271,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