change _pointer to mean a reference to non-GCed memory; add _gcpointer (v4.2.2.6)

svn: r16546

collects/scheme/foreign.ss

@@ -62,13 +62,13 @@
 
 (provide* ctype-sizeof ctype-alignof compiler-sizeof
           (unsafe malloc) (unsafe free) (unsafe end-stubborn-change)
-          cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!)
+          cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) (unsafe cast)
           ptr-offset ptr-add! offset-ptr? set-ptr-offset!
           ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout
           _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
           _fixint _ufixint _fixnum _ufixnum
           _float _double _double*
-          _bool _pointer _scheme _fpointer function-ptr
+          _bool _pointer _gcpointer _scheme _fpointer function-ptr
           (unsafe memcpy) (unsafe memmove) (unsafe memset)
           (unsafe malloc-immobile-cell) (unsafe free-immobile-cell))
 
@@ -1257,6 +1257,49 @@
 ;; Similar to the above, but can tolerate null pointers (#f).
 (define* _cpointer/null (cpointer-maker #t))
 
+(define (cast p from-type to-type)
+  (unless (ctype? from-type)
+    (raise-type-error 'cast "ctype" from-type))
+  (unless (ctype? to-type)
+    (raise-type-error 'cast "ctype" to-type))
+  (unless (= (ctype-sizeof to-type)
+             (ctype-sizeof from-type))
+    (raise-mismatch-error (format "representation sizes of types differ: ~e to "
+                                  from-type)
+                          to-type))
+  (let ([p2 (malloc from-type)])
+    (ptr-set! p2 from-type p)
+    (ptr-ref p2 to-type)))
+
+(define* (_or-null ctype)
+  (let ([coretype (ctype-coretype ctype)])
+    (unless (memq coretype '(pointer gcpointer fpointer))
+      (raise-type-error '_or-null "ctype buit on pointer, gcpointer, or fpointer" ctype))
+    (make-ctype
+     (case coretype
+       [(pointer) _pointer]
+       [(gcpointer) _gcpointer]
+       [(fpointer) _fpointer])
+     (lambda (v) (and v (cast _pointer v)))
+     (lambda (v) (and v (cast ctype v))))))
+
+(define* (_gcable ctype)
+  (unless (memq (ctype-coretype ctype) '(pointer gcpointer))
+    (raise-type-error '_or-null "pointer ctype" ctype))
+  (let loop ([ctype ctype])
+     (if (eq? ctype 'pointer)
+         _gcpointer
+         (make-ctype
+          (loop (ctype-basetype ctype))
+          (ctype-scheme->c ctype)
+          (ctype-c->scheme ctype)))))
+
+(define (ctype-coretype c)
+  (let loop ([c (ctype-basetype c)])
+    (if (symbol? c)
+        c
+        (loop c))))
+
 ;; A macro version of the above two functions, using the defined name for a tag
 ;; string, and defining a predicate too.  The name should look like `_foo', the
 ;; predicate will be `foo?', and the tag will be "foo".  In addition, `foo-tag'

collects/scribblings/foreign/derived.scrbl

@@ -9,12 +9,12 @@ The unsafe @scheme[cpointer-has-tag?] and @scheme[cpointer-push-tag!]
 operations manage tags to distinguish pointer types.
 
 @defproc*[([(_cpointer [tag any/c]
-                       [ptr-type ctype? _pointer]
+                       [ptr-type ctype? _xpointer]
                        [scheme-to-c (any/c . -> . any/c) values]
                        [c-to-scheme (any/c . -> . any/c) values])
             ctype]
            [(_cpointer/null [tag any/c]
-                            [ptr-type ctype? _pointer]
+                            [ptr-type ctype? _xpointer]
                             [scheme-to-c (any/c . -> . any/c) values]
                             [c-to-scheme (any/c . -> . any/c) values])
             ctype])]{

collects/scribblings/foreign/misc.scrbl

@@ -54,6 +54,20 @@ Like @scheme[list->cblock], but for Scheme vectors.}
 
 @section{Unsafe Miscellaneous Operations}
 
+@defproc[(cast [v any/c][from-type ctype?][to-type ctype?]) any/c]{
+
+Converts @scheme[v] from a value matching @scheme[from-type] to a
+value matching @scheme[to-type], where @scheme[(ctype-size from-type)]
+matches @scheme[(ctype-size to-type)].
+
+The conversion is equivalent to
+
+@schemeblock[
+  (let ([p (malloc from-type)])
+    (ptr-set! p from-type v)
+    (ptr-ref p to-type))
+]}
+
 @defproc[(cblock->list [cblock any/c][type ctype?][length exact-nonnegative-integer?])
          list?]{
 

collects/scribblings/foreign/pointers.scrbl

@@ -260,8 +260,8 @@ specification is required at minimum:
 ]
 
 If no mode is specified, then @scheme['nonatomic] allocation is used
-when the type is any pointer-based type, and @scheme['atomic]
+when the type is a @scheme[_gcpointer]- or @scheme[_scheme]-based
-allocation is used otherwise.}
+type, and @scheme['atomic] allocation is used otherwise.}
 
 
 @defproc[(free [cptr cpointer?]) void]{

collects/scribblings/foreign/types.scrbl

@@ -271,7 +271,28 @@ Corresponds to Scheme ``C pointer'' objects.  These pointers can have
 an arbitrary Scheme object attached as a type tag.  The tag is ignored
 by built-in functionality; it is intended to be used by interfaces.
 See @secref["foreign:tagged-pointers"] for creating pointer types that
-use these tags for safety.}
+use these tags for safety. A @scheme[#f] value is converted to
+@cpp{NULL} and vice-versa.
+
+The address referenced by a @scheme[_pointer] value must not refer to
+memory managed by the garbage collector (unless the address
+corresponds to a value that supports interior pointers and that is
+otherwise referenced to preserve the value from garbage collection).
+The reference is not traced or updated by the garbage collector.}
+
+
+@defthing[_gcpointer ctype?]{
+
+Like @scheme[_pointer], but for a value that can refer to memory
+managed by the garbage collector.
+
+Although a @scheme[_gcpointer] can reference to memory that is not
+managed by the garbage collector, beware of using an address that
+might eventually become managed by the garbage collector. For example,
+if a reference is created by @scheme[malloc] with @scheme['raw] and
+released by @scheme[free], then the @scheme[free] may allow the memory
+formerly occupied by the reference to be used later by the garbage
+collector.}
 
 
 @defthing[_scheme ctype?]{
@@ -295,6 +316,24 @@ A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer],
 and normally @scheme[_cprocedure] should be used instead of
 @scheme[_fpointer].}
 
+
+@defproc[(_or-null [ctype ctype?]) ctype?]{
+
+Creates a type that is like @scheme[ctype], but @scheme[#f] is
+converted to @cpp{NULL} and vice-versa. The given @scheme[ctype] must
+have the same C representation as @scheme[_pointer],
+@scheme[_gcpointer], or @scheme[_fpointer].}
+
+
+@defproc[(_gcable [ctype ctype?]) ctype?]{
+
+Creates a type that is like @scheme[ctype], but whose base
+representation is like @scheme[_gcpointer] instead of
+@scheme[_pointer]. The given @scheme[ctype] must have a base
+representation like @scheme[_pointer] or @scheme[_gcpointer] (and in
+the later case, the result is the @scheme[ctype]).}
+
+
 @; ------------------------------------------------------------
 
 @section[#:tag "foreign:procedures"]{Function Types}

collects/scribblings/inside/values.scrbl

@@ -667,7 +667,21 @@ Creates a C-pointer object that encapsulates @var{ptr} and uses
  the original @var{ptr} from the Scheme object, and
  @cppi{SCHEME_CPTR_TYPE} extracts the type tag.
  The @cppi{SCHEME_CPTR_OFFSETVAL} macro returns @cpp{0} 
- for the result Scheme object.}
+ for the result Scheme object.
+
+ The @var{ptr} can refer to either memory managed by the garbage
+ collector or by some other memory manager. Beware, however, of
+ retaining a @var{ptr} that refers to memory released by another
+ memory manager, since the enclosing memory range might later become
+ managed by the garbage collector (in which case @var{ptr} might
+ become an invalid pointer that can crash the garbage collector).}
+
+@function[(Scheme_Object* scheme_make_external_cptr
+           [void* ptr]
+           [const-Scheme_Object* typetag])]{
+
+Like @cpp{scheme_make_cptr}, but @var{ptr} is never treated as
+referencing memory managed by the garbage collector.}
 
 @function[(Scheme_Object* scheme_make_offset_cptr
            [void* ptr]
@@ -677,7 +691,20 @@ Creates a C-pointer object that encapsulates @var{ptr} and uses
 Creates a C-pointer object that encapsulates both @var{ptr} and @var{offset}.
  The @cppi{SCHEME_CPTR_OFFSETVAL} macro returns @var{offset} 
  for the result Scheme object (and the macro be used to change the offset,
- since it also works on objects with no offset).}
+ since it also works on objects with no offset).
+
+ The @var{ptr} can refer to either memory managed by the garbage
+ collector or by some other memory manager; see also 
+ @cpp{scheme_make_cptr}.}
+
+@function[(Scheme_Object* scheme_make_offset_external_cptr
+           [void* ptr]
+           [long offset]
+           [const-Scheme_Object* typetag])]{
+
+ Like @cpp{scheme_make_offset_cptr}, but @var{ptr} is never treated as
+referencing memory managed by the garbage collector.}
+
 
 @function[(void scheme_set_type_printer
            [Scheme_Type type]

src/foreign/foreign.c

@@ -766,14 +766,24 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * Predicate:   SCHEME_FFIANYPTRP(<Scheme>)
  * Scheme->C:   SCHEME_FFIANYPTR_VAL(<Scheme>)
  * S->C offset: FFIANYPTR
+ * C->Scheme:   scheme_make_foreign_external_cpointer(<C>)
+ */
+
+#define FOREIGN_gcpointer (24)
+/* Type Name:   gcpointer
+ * LibFfi type: ffi_type_gcpointer
+ * C type:      void*
+ * Predicate:   SCHEME_FFIANYPTRP(<Scheme>)
+ * Scheme->C:   SCHEME_FFIANYPTR_VAL(<Scheme>)
+ * S->C offset: FFIANYPTR
  * C->Scheme:   scheme_make_foreign_cpointer(<C>)
  */
 
 /* This is used for passing and Scheme_Object* value as is.  Useful for
  * functions that know about Scheme_Object*s, like MzScheme's. */
-#define FOREIGN_scheme (24)
+#define FOREIGN_scheme (25)
 /* Type Name:   scheme
- * LibFfi type: ffi_type_pointer
+ * LibFfi type: ffi_type_gcpointer
  * C type:      Scheme_Object*
  * Predicate:   1
  * Scheme->C:   <Scheme>
@@ -784,7 +794,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
 /* Special type, not actually used for anything except to mark values
  * that are treated like pointers but not referenced.  Used for
  * creating function types. */
-#define FOREIGN_fpointer (25)
+#define FOREIGN_fpointer (26)
 /* Type Name:   fpointer
  * LibFfi type: ffi_type_pointer
  * C type:      void*
@@ -817,12 +827,13 @@ typedef union _ForeignAny {
   char* x_path;
   char* x_symbol;
   void* x_pointer;
+  void* x_gcpointer;
   Scheme_Object* x_scheme;
   void* x_fpointer;
 } ForeignAny;
 
 /* This is a tag that is used to identify user-made struct types. */
-#define FOREIGN_struct (26)
+#define FOREIGN_struct (27)
 
 /*****************************************************************************/
 /* Type objects */
@@ -876,6 +887,8 @@ int ctype_FIXUP(void *p) {
 END_XFORM_SKIP;
 #endif
 
+static ffi_type ffi_type_gcpointer;
+
 #define CTYPE_BASETYPE(x)  (((ctype_struct*)(x))->basetype)
 #define CTYPE_USERP(x)     (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
 #define CTYPE_PRIMP(x)     (!CTYPE_USERP(x))
@@ -951,6 +964,7 @@ static int ctype_sizeof(Scheme_Object *type)
   case FOREIGN_path: return sizeof(char*);
   case FOREIGN_symbol: return sizeof(char*);
   case FOREIGN_pointer: return sizeof(void*);
+  case FOREIGN_gcpointer: return sizeof(void*);
   case FOREIGN_scheme: return sizeof(Scheme_Object*);
   case FOREIGN_fpointer: return sizeof(void*);
   /* for structs */
@@ -1148,6 +1162,9 @@ END_XFORM_SKIP;
 #define scheme_make_foreign_cpointer(x) \
   ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
 
+#define scheme_make_foreign_external_cpointer(x) \
+  ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL))
+
 #define MYNAME "cpointer?"
 static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[])
 {
@@ -1206,7 +1223,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
     else
       return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
   } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
-    return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta));
+    return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta));
   } else switch (CTYPE_PRIMLABEL(type)) {
     case FOREIGN_void: return scheme_void;
     case FOREIGN_int8: return scheme_make_integer(REF_CTYPE(Tsint8));
@@ -1230,7 +1247,8 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
     case FOREIGN_bytes: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_byte_string_without_copying(REF_CTYPE(char*));
     case FOREIGN_path: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_path_without_copying(REF_CTYPE(char*));
     case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*));
-    case FOREIGN_pointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*));
+    case FOREIGN_pointer: return scheme_make_foreign_external_cpointer(REF_CTYPE(void*));
+    case FOREIGN_gcpointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*));
     case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*);
     case FOREIGN_fpointer: return (REF_CTYPE(void*));
     case FOREIGN_struct:
@@ -1599,6 +1617,23 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
         scheme_wrong_type("Scheme->C","pointer",0,1,&(val));
         return NULL; /* hush the compiler */
       }
+    case FOREIGN_gcpointer:
+#     ifdef SCHEME_BIG_ENDIAN
+      if (sizeof(void*)<sizeof(int) && ret_loc) {
+        ((int*)W_OFFSET(dst,delta))[0] = 0;
+        delta += (sizeof(int)-sizeof(void*));
+      }
+#     endif /* SCHEME_BIG_ENDIAN */
+      if (SCHEME_FFIANYPTRP(val)) {
+        void* tmp; long toff;
+        tmp = (void*)(SCHEME_FFIANYPTR_VAL(val));
+        toff = SCHEME_FFIANYPTR_OFFSET(val);
+        if (_offset) *_offset = toff;
+        (((void**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
+      } else {
+        scheme_wrong_type("Scheme->C","gcpointer",0,1,&(val));
+        return NULL; /* hush the compiler */
+      }
     case FOREIGN_scheme:
 #     ifdef SCHEME_BIG_ENDIAN
       if (sizeof(Scheme_Object*)<sizeof(int) && ret_loc) {
@@ -1609,13 +1644,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
       if (1) {
         Scheme_Object* tmp;
         tmp = (Scheme_Object*)(val);
-        if (basetype_p == NULL || tmp == NULL) {
+        (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp; return NULL;
-          (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp;
-          return NULL;
-        } else {
-          *basetype_p = FOREIGN_scheme;
-          return tmp;
-        }
       } else {
         scheme_wrong_type("Scheme->C","scheme",0,1,&(val));
         return NULL; /* hush the compiler */
@@ -1845,7 +1874,7 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
   if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given");
   size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num);
   if (mode == NULL)
-    mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_pointer)
+    mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
       ? scheme_malloc : scheme_malloc_atomic;
   else if (SAME_OBJ(mode, nonatomic_sym))     mf = scheme_malloc;
   else if (SAME_OBJ(mode, atomic_sym))        mf = scheme_malloc_atomic;
@@ -1862,7 +1891,10 @@ static Scheme_Object *foreign_malloc(int argc, Scheme_Object *argv[])
   if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
   if (((from != NULL) || (foff != 0)) && (res != NULL))
     memcpy(res, W_OFFSET(from, foff), size);
-  return scheme_make_foreign_cpointer(res);
+  if (SAME_OBJ(mode, raw_sym))
+    return scheme_make_foreign_external_cpointer(res);
+  else
+    return scheme_make_foreign_cpointer(res);
 }
 #undef MYNAME
 
@@ -1906,7 +1938,7 @@ static Scheme_Object *foreign_free(int argc, Scheme_Object *argv[])
 #define MYNAME "malloc-immobile-cell"
 static Scheme_Object *foreign_malloc_immobile_cell(int argc, Scheme_Object *argv[])
 {
-  return scheme_make_foreign_cpointer(scheme_malloc_immobile_box(argv[0]));
+  return scheme_make_foreign_external_cpointer(scheme_malloc_immobile_box(argv[0]));
 }
 #undef MYNAME
 
@@ -1961,10 +1993,16 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
     ((Scheme_Offset_Cptr*)(argv[0]))->offset += noff;
     return scheme_void;
   } else {
-    return scheme_make_offset_cptr
+    if (SCHEME_CPTRP(argv[0]) && (SCHEME_CPTR_FLAGS(argv[0]) & 0x1))
-             (SCHEME_FFIANYPTR_VAL(argv[0]),
+      return scheme_make_offset_external_cptr
-              SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
+        (SCHEME_FFIANYPTR_VAL(argv[0]),
-              (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
+         SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
+         (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
+    else
+      return scheme_make_offset_cptr
+        (SCHEME_FFIANYPTR_VAL(argv[0]),
+         SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
+         (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
   }
 }
 
@@ -2741,6 +2779,7 @@ void scheme_init_foreign(Scheme_Env *env)
   Scheme_Env *menv;
   ctype_struct *t;
   Scheme_Object *s;
+  memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer));
   menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
   scheme_add_global("ffi-lib?",
     scheme_make_prim_w_arity(foreign_ffi_lib_p, "ffi-lib?", 1, 1), menv);
@@ -2981,11 +3020,18 @@ void scheme_init_foreign(Scheme_Env *env)
   t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_pointer);
   scheme_add_global("_pointer", (Scheme_Object*)t, menv);
+  s = scheme_intern_symbol("gcpointer");
+  t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
+  t->so.type = ctype_tag;
+  t->basetype = (s);
+  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
+  t->c_to_scheme = ((Scheme_Object*)FOREIGN_gcpointer);
+  scheme_add_global("_gcpointer", (Scheme_Object*)t, menv);
   s = scheme_intern_symbol("scheme");
   t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
   t->so.type = ctype_tag;
   t->basetype = (s);
-  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
+  t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer));
   t->c_to_scheme = ((Scheme_Object*)FOREIGN_scheme);
   scheme_add_global("_scheme", (Scheme_Object*)t, menv);
   s = scheme_intern_symbol("fpointer");

src/foreign/foreign.ssc

@@ -704,6 +704,13 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
  * ffi-obj and string values pass their pointer.  When used as a return
  * value, either a cpointer object or #f is returned. */
 @(defctype 'pointer
+   'ctype "void*"
+   'macro "FFIANYPTR"
+   'offset "FFIANYPTR"
+   'c->s  "scheme_make_foreign_external_cpointer")
+
+@(defctype 'gcpointer
+   'ftype "gcpointer"
    'ctype "void*"
    'macro "FFIANYPTR"
    'offset "FFIANYPTR"
@@ -721,7 +728,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
 /* This is used for passing and Scheme_Object* value as is.  Useful for
  * functions that know about Scheme_Object*s, like MzScheme's. */
 @(defctype 'scheme
-   'ftype "pointer"
+   'ftype "gcpointer"
    'ctype "Scheme_Object*"
    'pred (lambda (x aux) "1")
    's->c (lambda (x aux) x)
@@ -759,6 +766,8 @@ typedef union _ForeignAny {
   [scheme_to_c "Scheme_Object*"]
   [c_to_scheme "Scheme_Object*"]]
 
+static ffi_type ffi_type_gcpointer;
+
 #define CTYPE_BASETYPE(x)  (((ctype_struct*)(x))->basetype)
 #define CTYPE_USERP(x)     (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x)))
 #define CTYPE_PRIMP(x)     (!CTYPE_USERP(x))
@@ -950,6 +959,9 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
 #define scheme_make_foreign_cpointer(x) \
   ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL))
 
+#define scheme_make_foreign_external_cpointer(x) \
+  ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL))
+
 @cdefine[cpointer? 1]{
   return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false;
 }
@@ -999,7 +1011,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
     else
       return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res));
   } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) {
-    return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta));
+    return scheme_make_foreign_external_cpointer(*(void **)W_OFFSET(src, delta));
   } else switch (CTYPE_PRIMLABEL(type)) {
     @(map-types
       @list{case FOREIGN_@|cname|: return @;
@@ -1307,7 +1319,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
   if ((num == 0) && (size == 0)) scheme_signal_error(MYNAME": no size given");
   size = ((size==0) ? 1 : size) * ((num==0) ? 1 : num);
   if (mode == NULL)
-    mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_pointer)
+    mf = (base != NULL && CTYPE_PRIMTYPE(base) == &ffi_type_gcpointer)
       ? scheme_malloc : scheme_malloc_atomic;
   else if (SAME_OBJ(mode, nonatomic_sym))     mf = scheme_malloc;
   else if (SAME_OBJ(mode, atomic_sym))        mf = scheme_malloc_atomic;
@@ -1324,7 +1336,10 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
   if (failok) res = scheme_malloc_fail_ok(mf,size); else res = mf(size);
   if (((from != NULL) || (foff != 0)) && (res != NULL))
     memcpy(res, W_OFFSET(from, foff), size);
-  return scheme_make_foreign_cpointer(res);
+  if (SAME_OBJ(mode, raw_sym))
+    return scheme_make_foreign_external_cpointer(res);
+  else
+    return scheme_make_foreign_cpointer(res);
 }
 
 /* (end-stubborn-change ptr) */
@@ -1359,7 +1374,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
 
 /* (malloc-immobile-cell v) */
 @cdefine[malloc-immobile-cell 1]{
-  return scheme_make_foreign_cpointer(scheme_malloc_immobile_box(argv[0]));
+  return scheme_make_foreign_external_cpointer(scheme_malloc_immobile_box(argv[0]));
 }
 
 /* (free-immobile-cell b) */
@@ -1410,10 +1425,16 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang,
     ((Scheme_Offset_Cptr*)(argv[0]))->offset += noff;
     return scheme_void;
   } else {
-    return scheme_make_offset_cptr
+    if (SCHEME_CPTRP(argv[0]) && (SCHEME_CPTR_FLAGS(argv[0]) & 0x1))
-             (SCHEME_FFIANYPTR_VAL(argv[0]),
+      return scheme_make_offset_external_cptr
-              SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
+        (SCHEME_FFIANYPTR_VAL(argv[0]),
-              (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
+         SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
+         (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
+    else
+      return scheme_make_offset_cptr
+        (SCHEME_FFIANYPTR_VAL(argv[0]),
+         SCHEME_FFIANYPTR_OFFSET(argv[0]) + noff,
+         (SCHEME_CPTRP(argv[0])) ? SCHEME_CPTR_TYPE(argv[0]) : NULL);
   }
 }
 
@@ -2112,6 +2133,7 @@ void scheme_init_foreign(Scheme_Env *env)
   Scheme_Env *menv;
   ctype_struct *t;
   Scheme_Object *s;
+  memcpy(&ffi_type_gcpointer, &ffi_type_pointer, sizeof(ffi_type_pointer));
   menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env);
   @(maplines
      (lambda (x)

src/mzscheme/include/mzscheme.exp

@@ -300,6 +300,8 @@ scheme_get_unsigned_long_long_val
 scheme_real_to_double
 scheme_make_cptr
 scheme_make_offset_cptr
+scheme_make_external_cptr
+scheme_make_offset_external_cptr
 scheme_get_proc_name
 scheme_utf8_decode
 scheme_utf8_decode_as_prefix

src/mzscheme/include/mzscheme3m.exp

@@ -311,6 +311,8 @@ scheme_get_unsigned_long_long_val
 scheme_real_to_double
 scheme_make_cptr
 scheme_make_offset_cptr
+scheme_make_external_cptr
+scheme_make_offset_external_cptr
 scheme_get_proc_name
 scheme_utf8_decode
 scheme_utf8_decode_as_prefix

src/mzscheme/include/mzwin.def

@@ -288,6 +288,8 @@ EXPORTS
  scheme_real_to_double
  scheme_make_cptr
  scheme_make_offset_cptr
+ scheme_make_external_cptr
+ scheme_make_offset_external_cptr
  scheme_get_proc_name
  scheme_utf8_decode
  scheme_utf8_decode_as_prefix

src/mzscheme/include/mzwin3m.def

@@ -303,6 +303,8 @@ EXPORTS
  scheme_real_to_double
  scheme_make_cptr
  scheme_make_offset_cptr
+ scheme_make_external_cptr
+ scheme_make_offset_external_cptr
  scheme_get_proc_name
  scheme_utf8_decode
  scheme_utf8_decode_as_prefix

src/mzscheme/include/scheme.h

@@ -564,7 +564,7 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data)
 
 typedef struct Scheme_Cptr
 {
-  Scheme_Object so;
+  Scheme_Inclhash_Object so; /* 0x1 => an external pointer (not GCable) */
   void *val;
   Scheme_Object *type;
 } Scheme_Cptr;
@@ -577,6 +577,7 @@ typedef struct Scheme_Offset_Cptr
 #define SCHEME_CPTR_VAL(obj) (((Scheme_Cptr *)(obj))->val)
 #define SCHEME_CPTR_TYPE(obj) (((Scheme_Cptr *)(obj))->type)
 #define SCHEME_CPTR_OFFSET(obj) (SAME_TYPE(_SCHEME_TYPE(obj), scheme_offset_cpointer_type) ? ((Scheme_Offset_Cptr *)obj)->offset : 0)
+#define SCHEME_CPTR_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Cptr *)(obj))->so)
 
 #define SCHEME_SET_IMMUTABLE(obj)  ((MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= 0x1))
 #define SCHEME_SET_CHAR_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)

src/mzscheme/src/mzmark.c

@@ -156,14 +156,18 @@ static int cpointer_obj_SIZE(void *p) {
 }
 
 static int cpointer_obj_MARK(void *p) {
-  gcMARK(SCHEME_CPTR_VAL(p));
+  if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
+    gcMARK(SCHEME_CPTR_VAL(p));
+  }
   gcMARK(SCHEME_CPTR_TYPE(p));
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
 }
 
 static int cpointer_obj_FIXUP(void *p) {
-  gcFIXUP(SCHEME_CPTR_VAL(p));
+  if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
+    gcFIXUP(SCHEME_CPTR_VAL(p));
+  }
   gcFIXUP(SCHEME_CPTR_TYPE(p));
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
@@ -179,14 +183,18 @@ static int offset_cpointer_obj_SIZE(void *p) {
 }
 
 static int offset_cpointer_obj_MARK(void *p) {
-  gcMARK(SCHEME_CPTR_VAL(p));
+  if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
+    gcMARK(SCHEME_CPTR_VAL(p));
+  }
   gcMARK(SCHEME_CPTR_TYPE(p));
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));
 }
 
 static int offset_cpointer_obj_FIXUP(void *p) {
-  gcFIXUP(SCHEME_CPTR_VAL(p));
+  if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
+    gcFIXUP(SCHEME_CPTR_VAL(p));
+  }
   gcFIXUP(SCHEME_CPTR_TYPE(p));
   return
   gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));

src/mzscheme/src/mzmarksrc.c

@@ -56,7 +56,9 @@ quotesyntax_obj {
 
 cpointer_obj {
  mark:
-  gcMARK(SCHEME_CPTR_VAL(p));
+  if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
+    gcMARK(SCHEME_CPTR_VAL(p));
+  }
   gcMARK(SCHEME_CPTR_TYPE(p));
  size:
   gcBYTES_TO_WORDS(sizeof(Scheme_Cptr));
@@ -64,7 +66,9 @@ cpointer_obj {
 
 offset_cpointer_obj {
  mark:
-  gcMARK(SCHEME_CPTR_VAL(p));
+  if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) {
+    gcMARK(SCHEME_CPTR_VAL(p));
+  }
   gcMARK(SCHEME_CPTR_TYPE(p));
  size:
   gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr));

src/mzscheme/src/salloc.c

@@ -342,6 +342,14 @@ Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag)
   return o;
 }
 
+Scheme_Object *scheme_make_external_cptr(GC_CAN_IGNORE void *cptr, Scheme_Object *typetag)
+{
+  Scheme_Object *o;
+  o = scheme_make_cptr(NULL, typetag);
+  SCHEME_CPTR_VAL(o) = cptr;
+  return o;
+}
+
 Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *typetag)
 {
   Scheme_Object *o;
@@ -355,6 +363,15 @@ Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *t
   return o;
 }
 
+Scheme_Object *scheme_make_offset_external_cptr(GC_CAN_IGNORE void *cptr, long offset, Scheme_Object *typetag)
+{
+  Scheme_Object *o;
+  o = scheme_make_offset_cptr(NULL, offset, typetag);
+  SCHEME_CPTR_VAL(o) = cptr;
+  return o;
+}
+
+
 /************************************************************************/
 /*                            allocation                                */
 /************************************************************************/

src/mzscheme/src/schemef.h

@@ -576,6 +576,8 @@ XFORM_NONGCING MZ_EXTERN double scheme_real_to_double(Scheme_Object *r);
 
 MZ_EXTERN Scheme_Object *scheme_make_cptr(void *cptr, Scheme_Object *typetag);
 MZ_EXTERN Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *typetag);
+MZ_EXTERN Scheme_Object *scheme_make_external_cptr(void *cptr, Scheme_Object *typetag);
+MZ_EXTERN Scheme_Object *scheme_make_offset_external_cptr(void *cptr, long offset, Scheme_Object *typetag);
 
 MZ_EXTERN const char *scheme_get_proc_name(Scheme_Object *p, int *len, int for_error);
 

src/mzscheme/src/schemex.h

@@ -475,6 +475,8 @@ int (*scheme_get_unsigned_long_long_val)(Scheme_Object *o, umzlonglong *v);
 double (*scheme_real_to_double)(Scheme_Object *r);
 Scheme_Object *(*scheme_make_cptr)(void *cptr, Scheme_Object *typetag);
 Scheme_Object *(*scheme_make_offset_cptr)(void *cptr, long offset, Scheme_Object *typetag);
+Scheme_Object *(*scheme_make_external_cptr)(void *cptr, Scheme_Object *typetag);
+Scheme_Object *(*scheme_make_offset_external_cptr)(void *cptr, long offset, Scheme_Object *typetag);
 const char *(*scheme_get_proc_name)(Scheme_Object *p, int *len, int for_error);
 /*========================================================================*/
 /*                               strings                                  */

src/mzscheme/src/schemex.inc

@@ -337,6 +337,8 @@
   scheme_extension_table->scheme_real_to_double = scheme_real_to_double;
   scheme_extension_table->scheme_make_cptr = scheme_make_cptr;
   scheme_extension_table->scheme_make_offset_cptr = scheme_make_offset_cptr;
+  scheme_extension_table->scheme_make_external_cptr = scheme_make_external_cptr;
+  scheme_extension_table->scheme_make_offset_external_cptr = scheme_make_offset_external_cptr;
   scheme_extension_table->scheme_get_proc_name = scheme_get_proc_name;
   scheme_extension_table->scheme_utf8_decode = scheme_utf8_decode;
   scheme_extension_table->scheme_utf8_decode_as_prefix = scheme_utf8_decode_as_prefix;

src/mzscheme/src/schemexm.h

@@ -337,6 +337,8 @@
 #define scheme_real_to_double (scheme_extension_table->scheme_real_to_double)
 #define scheme_make_cptr (scheme_extension_table->scheme_make_cptr)
 #define scheme_make_offset_cptr (scheme_extension_table->scheme_make_offset_cptr)
+#define scheme_make_external_cptr (scheme_extension_table->scheme_make_external_cptr)
+#define scheme_make_offset_external_cptr (scheme_extension_table->scheme_make_offset_external_cptr)
 #define scheme_get_proc_name (scheme_extension_table->scheme_get_proc_name)
 #define scheme_utf8_decode (scheme_extension_table->scheme_utf8_decode)
 #define scheme_utf8_decode_as_prefix (scheme_extension_table->scheme_utf8_decode_as_prefix)

src/mzscheme/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "4.2.2.5"
+#define MZSCHEME_VERSION "4.2.2.6"
 
 #define MZSCHEME_VERSION_X 4
 #define MZSCHEME_VERSION_Y 2
 #define MZSCHEME_VERSION_Z 2
-#define MZSCHEME_VERSION_W 5
+#define MZSCHEME_VERSION_W 6
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)