From 9ea047a05e1b1f033b3ba0815a86b74201cf17a0 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 19 Dec 2008 23:39:55 +0000
Subject: [PATCH] fix ptr-set! to allow installing function points into an
 offset cpointer

svn: r12910
---
 src/foreign/foreign.c   | 18 +++++++++++-------
 src/foreign/foreign.ssc | 18 +++++++++++-------
 2 files changed, 22 insertions(+), 14 deletions(-)

diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c
index 0518cd0397..53c08951b5 100644
--- a/src/foreign/foreign.c
+++ b/src/foreign/foreign.c
@@ -2166,13 +2166,15 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[])
   if (NULL == (base = get_ctype_base(argv[1])))
     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
   else size = ctype_sizeof(base);
+
   if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
-    if (argc > 3) {
-      scheme_signal_error
-        (MYNAME": setting fpointer value with extra arguments");
-    } else if (SCHEME_CPTRP(argv[0])) {
-      ptr = SCHEME_CPTR_VAL(argv[0]);
+    if (SCHEME_CPTRP(argv[0])) {
+      /* offset is ok */
     } else if SCHEME_FFIOBJP(argv[0]) {
+      if (argc > 3) {
+        scheme_signal_error
+          (MYNAME": cannot set fpointer value with offset");
+      }
       ptr = ((ffi_obj_struct*)(argv[0]))->obj;
     } else {
       scheme_signal_error
@@ -2183,9 +2185,11 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[])
     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
   } else if (size == 0) {
     scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
-  } else if (argc > 4) {
+  }
+
+  if (argc > 4) {
     if (!SAME_OBJ(argv[2],abs_sym))
-      scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
+      scheme_wrong_type(MYNAME, "'abs", 2, argc, argv);
     if (!SCHEME_INTP(argv[3]))
       scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
     delta += SCHEME_INT_VAL(argv[3]);
diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc
index fc8193244b..95f5ad4abd 100755
--- a/src/foreign/foreign.ssc
+++ b/src/foreign/foreign.ssc
@@ -1616,13 +1616,15 @@ static Scheme_Object *do_memop(const char *who, int mode,
   if (NULL == (base = get_ctype_base(argv[1])))
     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
   else size = ctype_sizeof(base);
+
   if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
-    if (argc > 3) {
-      scheme_signal_error
-        (MYNAME": setting fpointer value with extra arguments");
-    } else if (SCHEME_CPTRP(argv[0])) {
-      ptr = SCHEME_CPTR_VAL(argv[0]);
+    if (SCHEME_CPTRP(argv[0])) {
+      /* offset is ok */
     } else if SCHEME_FFIOBJP(argv[0]) {
+      if (argc > 3) {
+        scheme_signal_error
+          (MYNAME": cannot set fpointer value with offset");
+      }
       ptr = ((ffi_obj_struct*)(argv[0]))->obj;
     } else {
       scheme_signal_error
@@ -1633,9 +1635,11 @@ static Scheme_Object *do_memop(const char *who, int mode,
     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
   } else if (size == 0) {
     scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv);
-  } else if (argc > 4) {
+  }
+
+  if (argc > 4) {
     if (!SAME_OBJ(argv[2],abs_sym))
-      scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv);
+      scheme_wrong_type(MYNAME, "'abs", 2, argc, argv);
     if (!SCHEME_INTP(argv[3]))
       scheme_wrong_type(MYNAME, "integer", 3, argc, argv);
     delta += SCHEME_INT_VAL(argv[3]);