diff --git a/boot/pb/equates.h b/boot/pb/equates.h
index 4d052960a..b17da2f70 100644
--- a/boot/pb/equates.h
+++ b/boot/pb/equates.h
@@ -1,4 +1,4 @@
-/* equates.h for Chez Scheme Version 10.2.0-pre-release.1 */
+/* equates.h for Chez Scheme Version 10.2.0-pre-release.2 */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -1015,7 +1015,7 @@ typedef uint64_t U64;
 #define rtd_sealed 0x4
 #define sbwp (ptr)0x4E
 #define scaled_shot_1_shot_flag -0x8
-#define scheme_version 0xA020001
+#define scheme_version 0xA020002
 #define seginfo_generation_disp 0x1
 #define seginfo_list_bits_disp 0x8
 #define seginfo_space_disp 0x0
diff --git a/boot/pb/gc-ocd.inc b/boot/pb/gc-ocd.inc
index 6bbc8d555..2018cd28a 100644
--- a/boot/pb/gc-ocd.inc
+++ b/boot/pb/gc-ocd.inc
@@ -576,6 +576,15 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_impure(&obj, from_g);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 relocate_pure(&(RECORDDESCPM(rtd)));
@@ -1258,6 +1267,15 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_indirect(obj);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 relocate_pure(&(RECORDDESCPM(rtd)));
@@ -1837,6 +1855,15 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest)
                 }
               }
             }
+            else if (num == Strue)
+            {
+              uptr offset = (uptr)(*((pp + 1)));
+              {
+                ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                relocate_dirty(&obj, youngest);
+                *(pp) = TO_PTR((((uptr)obj) + offset));
+              }
+            }
             else
             {
               {
@@ -2095,6 +2122,15 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g)
               }
             }
           }
+          else if (num == Strue)
+          {
+            uptr offset = (uptr)(*((pp + 1)));
+            {
+              ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+              relocate_impure(&obj, from_g);
+              *(pp) = TO_PTR((((uptr)obj) + offset));
+            }
+          }
           else
           {
             relocate_pure(&(RECORDDESCPM(rtd)));
@@ -2157,6 +2193,15 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest)
             }
           }
         }
+        else if (num == Strue)
+        {
+          uptr offset = (uptr)(*((pp + 1)));
+          {
+            ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+            relocate_dirty(&obj, youngest);
+            *(pp) = TO_PTR((((uptr)obj) + offset));
+          }
+        }
         else
         {
           {
@@ -3580,6 +3625,15 @@ static IBOOL object_directly_refers_to_self(ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  if (p == obj) return 1;
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 if (p == RECORDDESCPM(rtd)) return 1;
diff --git a/boot/pb/gc-oce.inc b/boot/pb/gc-oce.inc
index 1d77a31b6..29d03695e 100644
--- a/boot/pb/gc-oce.inc
+++ b/boot/pb/gc-oce.inc
@@ -696,6 +696,15 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_impure(&obj, from_g);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 relocate_pure(&(RECORDDESCPM(rtd)));
@@ -1381,6 +1390,15 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_indirect(obj);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 relocate_pure(&(RECORDDESCPM(rtd)));
@@ -1961,6 +1979,15 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest)
                 }
               }
             }
+            else if (num == Strue)
+            {
+              uptr offset = (uptr)(*((pp + 1)));
+              {
+                ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                relocate_dirty(&obj, youngest);
+                *(pp) = TO_PTR((((uptr)obj) + offset));
+              }
+            }
             else
             {
               {
@@ -2221,6 +2248,15 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g)
               }
             }
           }
+          else if (num == Strue)
+          {
+            uptr offset = (uptr)(*((pp + 1)));
+            {
+              ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+              relocate_impure(&obj, from_g);
+              *(pp) = TO_PTR((((uptr)obj) + offset));
+            }
+          }
           else
           {
             relocate_pure(&(RECORDDESCPM(rtd)));
@@ -2285,6 +2321,15 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest)
             }
           }
         }
+        else if (num == Strue)
+        {
+          uptr offset = (uptr)(*((pp + 1)));
+          {
+            ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+            relocate_dirty(&obj, youngest);
+            *(pp) = TO_PTR((((uptr)obj) + offset));
+          }
+        }
         else
         {
           {
@@ -3823,6 +3868,15 @@ static IBOOL object_directly_refers_to_self(ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  if (p == obj) return 1;
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 if (p == RECORDDESCPM(rtd)) return 1;
@@ -4151,6 +4205,19 @@ static void measure(thread_gc *tgc, ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  { /* measure */
+                    ptr r_p = obj;
+                    if (!FIXMEDIATE(r_p))
+                      push_measure(tgc, r_p);
+                  }
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 {
diff --git a/boot/pb/gc-par.inc b/boot/pb/gc-par.inc
index 0d3198b2e..755c578b8 100644
--- a/boot/pb/gc-par.inc
+++ b/boot/pb/gc-par.inc
@@ -561,6 +561,15 @@ static void sweep(thread_gc *tgc, ptr p, IGEN from_g)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_impure(&obj, from_g);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 seginfo* pm_si = SegInfo((ptr_get_segment(num)));
@@ -1262,6 +1271,15 @@ static void sweep_object_in_old(thread_gc *tgc, ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  relocate_indirect(obj);
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 relocate_pure(&(RECORDDESCPM(rtd)));
@@ -1841,6 +1859,15 @@ static IGEN sweep_dirty_object(thread_gc *tgc, ptr p, IGEN youngest)
                 }
               }
             }
+            else if (num == Strue)
+            {
+              uptr offset = (uptr)(*((pp + 1)));
+              {
+                ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                relocate_dirty(&obj, youngest);
+                *(pp) = TO_PTR((((uptr)obj) + offset));
+              }
+            }
             else
             {
               {
@@ -2109,6 +2136,15 @@ static void sweep_record(thread_gc *tgc, ptr p, IGEN from_g)
               }
             }
           }
+          else if (num == Strue)
+          {
+            uptr offset = (uptr)(*((pp + 1)));
+            {
+              ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+              relocate_impure(&obj, from_g);
+              *(pp) = TO_PTR((((uptr)obj) + offset));
+            }
+          }
           else
           {
             seginfo* pm_si = SegInfo((ptr_get_segment(num)));
@@ -2180,6 +2216,15 @@ static IGEN sweep_dirty_record(thread_gc *tgc, ptr p, IGEN youngest)
             }
           }
         }
+        else if (num == Strue)
+        {
+          uptr offset = (uptr)(*((pp + 1)));
+          {
+            ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+            relocate_dirty(&obj, youngest);
+            *(pp) = TO_PTR((((uptr)obj) + offset));
+          }
+        }
         else
         {
           {
@@ -3621,6 +3666,15 @@ static IBOOL object_directly_refers_to_self(ptr p)
                   }
                 }
               }
+              else if (num == Strue)
+              {
+                uptr offset = (uptr)(*((pp + 1)));
+                {
+                  ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                  if (p == obj) return 1;
+                  *(pp) = TO_PTR((((uptr)obj) + offset));
+                }
+              }
               else
               {
                 if (p == RECORDDESCPM(rtd)) return 1;
diff --git a/boot/pb/heapcheck.inc b/boot/pb/heapcheck.inc
index c1e86b86a..3c9ddac64 100644
--- a/boot/pb/heapcheck.inc
+++ b/boot/pb/heapcheck.inc
@@ -43,6 +43,15 @@ static void check_object(ptr p, uptr seg, ISPC s_in, IBOOL aftergc)
                 }
               }
             }
+            else if (num == Strue)
+            {
+              uptr offset = (uptr)(*((pp + 1)));
+              {
+                ptr obj = TO_PTR((((uptr)(*(pp))) - offset));
+                check_pointer(&(obj), 0, 0, p, seg, s_in, aftergc);
+                *(pp) = TO_PTR((((uptr)obj) + offset));
+              }
+            }
             else
             {
               check_pointer(&(num), 0, 0, p, seg, s_in, aftergc);
diff --git a/boot/pb/petite.boot b/boot/pb/petite.boot
index 1240bad20..70a07764f 100644
Binary files a/boot/pb/petite.boot and b/boot/pb/petite.boot differ
diff --git a/boot/pb/scheme.boot b/boot/pb/scheme.boot
index cd9314a6e..262ca7fc5 100644
Binary files a/boot/pb/scheme.boot and b/boot/pb/scheme.boot differ
diff --git a/boot/pb/scheme.h b/boot/pb/scheme.h
index dbc5d55a3..eb2655543 100644
--- a/boot/pb/scheme.h
+++ b/boot/pb/scheme.h
@@ -1,4 +1,4 @@
-/* scheme.h for Chez Scheme Version 10.2.0-pre-release.1 (pb) */
+/* scheme.h for Chez Scheme Version 10.2.0-pre-release.2 (pb) */
 
 /* Do not edit this file.  It is automatically generated and */
 /* specifically tailored to the version of Chez Scheme named */
@@ -40,7 +40,7 @@
 #endif
 
 /* Chez Scheme Version and machine type */
-#define VERSION "10.2.0-pre-release.1"
+#define VERSION "10.2.0-pre-release.2"
 #define MACHINE_TYPE "pb"
 
 /* Integer typedefs */
diff --git a/csug/foreign.stex b/csug/foreign.stex
index da763b1f2..51d8a0044 100644
--- a/csug/foreign.stex
+++ b/csug/foreign.stex
@@ -306,10 +306,11 @@ and
 must be used with caution, however, since they allow allocated
 Scheme objects to be used in places the Scheme memory management system
 cannot control. No problems will arise as long as such objects are not
-retained in foreign variables or data structures while Scheme code is running,
-and as long as they are not passed as arguments to a \scheme{__collect_safe} procedure,
+retained in foreign variables or data structures while Scheme code is running;
+as long as they are not passed as arguments to a \scheme{__collect_safe} procedure,
 since garbage collection can occur only while Scheme code is running
-or when concurrent garbage collection is enabled.
+or when concurrent garbage collection is enabled; and as long as the foreign
+procedure does not reenter Scheme via a callable before returning.
 Other parameter types are converted to equivalent foreign
 representations and consequently they can be retained indefinitely in
 foreign variables and data structures.
@@ -621,6 +622,12 @@ appropriate depending on the size of a C \scheme{wchar_t}.
 For example, \scheme{wstring} is equivalent to \scheme{utf-16}
 under Windows running on Intel hardware.
 
+\foreigntype{\var{ftype-name}}
+\index{ftype}Any defined foreign type (ftype) can be used as long as it is
+equivalent to a type that would be allowed when written directly.
+See Section~\ref{SECTFOREIGNDATA} for a description of
+foreign types.
+
 \foreigntype{\scheme{(* \var{ftype-name})}}
 \index{ftype}This type allows a pointer to a foreign
 type (ftype) to be passed.
@@ -628,8 +635,31 @@ The argument must be an ftype pointer of the type identified by
 \var{ftype-name},
 and the actual argument is the address encapsulated in the
 ftype pointer.
-See Section~\ref{SECTFOREIGNDATA} for a description of
-foreign types.
+
+\foreigntype{\scheme{ftype-pointer}}
+\index{ftype-pointer}This type allows any pointer to a foreign type
+(ftype) to be passed, independent of the foreign type, and including
+generic foreign pointers and foreign pointers to Scheme objects. In
+other words, this type is specific to foreign pointers created with
+\scheme{make-ftype-pointer} and similar, but otherwise generic like
+\scheme{void*}.
+
+\foreigntype{\scheme{ftype-scheme-object-pointer}}
+\index{ftype-scheme-object-pointer}This type allows a foreign pointer
+to a Scheme object, such as one created with
+\scheme{make-ftype-scheme-object-pointer}. The address received on the
+C side is like the one produced by \scheme{object->reference-address}
+for a non-\scheme{#f} value; using the result of
+\scheme{object->reference-address} with \scheme{make-ftype-pointer}
+woudl produce the result, but only with locked objects that
+cannot move, while \scheme{make-ftype-scheme-object-pointer} defers
+conversion to an address to a point before the call but after a
+garbage collection cna take place (assuming that
+\scheme{__collect_safe} is not used). Note that
+\scheme{ftype-scheme-object-pointer} differs from \scheme{scheme-object}
+by delivering specifically a reference address to the foreign
+procedure, which can be useful for communicating
+bytevector and flvector content.
 
 \foreigntype{\scheme{(& \var{ftype-name})}}
 \index{ftype}This type allows a foreign
@@ -642,6 +672,14 @@ content at the foreign pointer's address instead of as the
 address. For example, if \var{ftype-name} identifies a \scheme{struct} type,
 then \scheme{(& \var{ftype-name})} passes a struct argument instead of
 a struct-pointer argument. The \var{ftype-name} cannot refer to an array type.
+The variant \scheme{(& \var{ftype-name} ftype-pointer)} is the same,
+except that the Scheme-side representation can be any foreign pointer
+type, not necessarily one specific to \var{ftype-name}.
+The variant \scheme{(& \var{ftype-name} ftype-scheme-object-pointer)}
+is also the same, except that Scheme-side representation must be a
+foreign object pointer to a Scheme object like one created by
+\scheme{make-ftype-scheme-object-pointer}.
+
 
 \medskip\noindent
 The result types are similar to the parameter types with the addition of a
@@ -656,6 +694,7 @@ Particular caution should be exercised with the result types
 \index{\scheme{double}}\scheme{double},
 \index{\scheme{single-float}}\scheme{single-float},
 \index{\scheme{float}}\scheme{float},
+\index{\scheme{ftype-scheme-object-pointer}}\scheme{ftype-scheme-object-pointer},
 and the types that result in the construction of bytevectors or strings,
 since invalid
 return values may lead to invalid memory references as well as incorrect
@@ -918,12 +957,32 @@ or \scheme{utf-32} as appropriate depending on the size of a C \scheme{wchar_t}.
 For example, \scheme{wstring} is equivalent to \scheme{utf-16}
 under Windows running on Intel hardware.
 
+\foreigntype{\var{ftype-name}}
+\index{ftype}Any defined foreign type (ftype) can be used as long as it is
+equivalent to a type that would be allowed when written directly.
+See Section~\ref{SECTFOREIGNDATA} for a description of
+foreign types.
+
 \foreigntype{\scheme{(* \var{ftype-name})}}
 \index{ftype}The result is interpreted as the address of a foreign object
 whose structure is described by the ftype identified by \var{ftype-name}, and a freshly allocated
 ftype pointer encapsulating the address is returned.
-See Section~\ref{SECTFOREIGNDATA} for a description of
-foreign types.
+
+\foreigntype{\scheme{ftype-pointer}}
+\index{ftype-pointer}The result is interpreted as the address of a
+foreign object of unspecified content, and a freshly allocated
+generic ftype pointer encapsulating the address is returned.
+
+\foreigntype{\scheme{ftype-scheme-object-pointer}}
+\index{ftype-scheme-object-pointer}The result is interpreted as the reference
+address of a Scheme object, and it is returned as encapsulated within
+foreign object pointer as created with
+\scheme{make-ftype-scheme-object-pointer}. Note that
+\scheme{ftype-scheme-object-pointer} differs from
+\scheme{scheme-object} in that it receives a reference address from the
+foreign procedure, which might be the start of bytevector or flvector
+content. Like \scheme{scheme-object}, however, this type is inherently dangerous,
+and a foreign procedure would rarely be expected to produce such a value.
 
 \foreigntype{\scheme{(& \var{ftype-name})}}
 \index{ftype}The result is interpreted as a foreign object
@@ -933,7 +992,17 @@ must provide an extra \scheme{(* \var{ftype-name})} argument before
 all other arguments to receive the result. An unspecified Scheme object
 is returned when the foreign procedure is called, since the result
 is instead written into storage referenced by the extra argument.
- The \var{ftype-name} cannot refer to an array type.
+The \var{ftype-name} cannot refer to an array type.
+The variant \scheme{(& \var{ftype-name} ftype-pointer)} is the same,
+except that the foreign pointer passed as an extra initial argument
+can be any foreign pointer type, not necessarily one specific to
+\var{ftype-name}.
+The variant \scheme{(& \var{ftype-name} ftype-scheme-object-pointer)}
+is also the same, except that the foreign pointer passed as an extra
+initial argument must be a foreign object pointer to a Scheme object
+like one created by \scheme{make-ftype-scheme-object-pointer}.
+
+
 
 \medskip\noindent
 Consider a C identity procedure:
@@ -1680,9 +1749,11 @@ ftype.
 Each \var{ftype-name} in an \var{ftype} must either
 (a) have been defined previously by \scheme{define-ftype},
 (b) be defined by the current \scheme{define-ftype},
-or
 (c) be a base-type name, i.e., one of the type names supported by
-\scheme{foreign-ref} and \scheme{foreign-set!}.
+\scheme{foreign-ref} and \scheme{foreign-set!}, or
+(d) \scheme{ftype-pointer} or \scheme{ftype-scheme-object-pointer},
+which indicate a generic ftype pointer or an ftype pointer for a Scheme
+object, respectivly.
 In case (b), any reference within one \var{ftype} to the
 \var{ftype-name} of one of the earlier bindings is permissible,
 but a reference to the \var{ftype-name} of the current or a
@@ -2001,12 +2072,35 @@ A library that defines \var{memcpy} must be loaded first via
 \scheme{load-shared-object}, or \scheme{memcpy} must be registered
 via one of the methods described in Section ~\ref{SECTFOREIGNACCESS}.
 
+%----------------------------------------------------------------------------
+\entryheader\label{desc:make-ftype-scheme-object-pointer}
+\formdef{make-ftype-scheme-object-pointer}{\categorysyntax}{(make-ftype-scheme-object-pointer \var{expr})}
+\formdef{make-ftype-scheme-object-pointer}{\categorysyntax}{(make-ftype-scheme-object-pointer \var{expr} \var{offset})}
+\returns an ftype-pointer object that refers to a Scheme object
+\listlibraries
+\endentryheader
+
+Returns a ftype pointer object that can be used in the same places as
+a generic ftype pointer, and where the address encapsulated by the
+pointer a reference address in the sense of
+\scheme{object->reference-address}. The reference address is for the
+result of \var{expr}, without special treatment of \scheme{#f}. If
+an \var{offset} expression is present, then it must produce a
+\scheme{iptr}-compatible integer, and the address encapsulated by the
+pointer is shifted by that amount.
+
+The resulting ftype pointer is rcognized by
+\scheme{ftype-scheme-object-pointer?} as well as
+\scheme{ftype-pointer?} without a \var{ftype-name}.
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{ftype-pointer?}{\categorysyntax}{(ftype-pointer? \var{obj})}
 \returns \scheme{#t} if \var{obj} is an ftype pointer, otherwise \scheme{#f}
 \formdef{ftype-pointer?}{\categorysyntax}{(ftype-pointer? \var{ftype-name} \var{obj})}
 \returns \scheme{#t} if \var{obj} is an \var{ftype-name}, otherwise \scheme{#f}
+\formdef{ftype-scheme-object-pointer?}{\categorysyntax}{(ftype-scheme-object-pointer? \var{obj})}
+\returns \scheme{#t} if \var{obj} is an ftype pointer for a Scheme object, otherwise \scheme{#f}
 \listlibraries
 \endentryheader
 
@@ -2044,6 +2138,23 @@ via one of the methods described in Section ~\ref{SECTFOREIGNACCESS}.
 (ftype-pointer-address x) ;=> #x80000000
 \endschemedisplay
 
+%----------------------------------------------------------------------------
+\entryheader
+\formdef{ftype-scheme-object-pointer-object}{\categoryprocedure}{(ftype-scheme-object-pointer-object \var{fptr})}
+\returns the Scheme object whose reference address is encapsulated within \var{fptr}
+\formdef{ftype-scheme-object-pointer-offset}{\categoryprocedure}{(ftype-scheme-object-pointer-offset \var{fptr})}
+\returns the offset of a reference address encapsulated within \var{fptr}
+\listlibraries
+\endentryheader
+
+\var{fptr} must be an ftype-pointer object that represents a Scheme object.
+
+\schemedisplay
+(define x (make-ftype-scheme-object-pointer #vu8(1 2 3) 1))
+(ftype-scheme-object-pointer-object x) ;=> #vu8(1 2 3)
+(ftype-scheme-object-pointer-offset x) ;=> 1
+\endschemedisplay
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{ftype-pointer=?}{\categorysyntax}{(ftype-pointer=? \var{fptr_1} \var{fptr_2})}
@@ -2155,7 +2266,7 @@ Otherwise, the \scheme{ftype-pointer} is freshly allocated.
 \returns unspecified
 \formdef{ftype-ref}{\categorysyntax}{(ftype-ref \var{ftype-name} (\var{a} ...) \var{fptr-expr})}
 \formdef{ftype-ref}{\categorysyntax}{(ftype-ref \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{index})}
-\returns an ftype-pointer object
+\returns a Scheme representation of a foreign object
 \listlibraries
 \endentryheader
 
@@ -2281,6 +2392,32 @@ Thus, \scheme{ftype-ref} with a function ftype is an alternative to
 for creating Scheme-callable wrappers for
 C functions.
 
+%----------------------------------------------------------------------------
+\entryheader\label{defn:ftype-any-set!}
+\formdef{ftype-any-set!}{\categorysyntax}{(ftype-any-set! \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{val-expr})}
+\formdef{ftype-any-set!}{\categorysyntax}{(ftype-any-set! \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{offset} \var{val-expr})}
+\returns unspecified
+\formdef{ftype-any-ref}{\categorysyntax}{(ftype-any-ref \var{ftype-name} (\var{a} ...) \var{fptr-expr})}
+\formdef{ftype-any-ref}{\categorysyntax}{(ftype-any-ref \var{ftype-name} (\var{a} ...) \var{fptr-expr} \var{offset})}
+\returns a Scheme representation of a foreign object
+\listlibraries
+\endentryheader
+
+These forms are like \scheme{ftype-set!} and \scheme{ftype-ref}, but
+with two differences:
+
+\begin{enumerate}
+
+\item The ftype pointer produced by \var{fptr-expr} can be any
+pointer. It does not have to be specifically for \var{ftype-name},
+even though an \var{ftype-name} value is written or read.
+
+\item The pointer's address is shifted by an absolute \var{offset}
+that is not scaled by the size of \var{fptr-expr} values.
+
+\end{enumerate}
+
+
 %----------------------------------------------------------------------------
 \entryheader
 \formdef{ftype-pointer-ftype}{\categoryprocedure}{(ftype-pointer-ftype \var{fptr})}
diff --git a/mats/foreign.ms b/mats/foreign.ms
index 783033ecb..cacaf54a8 100644
--- a/mats/foreign.ms
+++ b/mats/foreign.ms
@@ -975,6 +975,7 @@
     (define call-u8* (foreign-procedure "call_u8_star" (ptr u8*) u8*))
     (define call-u16* (foreign-procedure "call_u16_star" (ptr u16*) u16*))
     (define call-u32* (foreign-procedure "call_u32_star" (ptr u32*) u32*))
+    (define call-void* (foreign-procedure "call_u8_star" (ptr ftype-pointer) ftype-pointer))
     (define $bytevector-map
       (lambda (p bv)
         (u8-list->bytevector (map p (bytevector->u8-list bv)))))
@@ -983,7 +984,7 @@
     (call-u8* (foreign-callable
                 (lambda (x) ($bytevector-map (lambda (x) (if (= x 255) 0 (+ x 100))) x))
                 (u8*) u8*)
-      #vu8(1 2 3 4 5 255 0 ))
+      #vu8(1 2 3 4 5 255 0))
     '#vu8(103 104 105))
   (equal?
     (call-u16* (foreign-callable
@@ -1027,6 +1028,21 @@
                  (lambda (x) (list x (bytevector-length x)))
                  (u32*) u32*)
       '#(1 2 3 4 5 6 7 8 0 0 0 0)))
+  (equal?
+   (let* ([r (call-void* (foreign-callable
+                          (lambda (x)
+                            (let* ([x (reference-address->object (- (ftype-pointer-address x) 1))]
+                                   [bv ($bytevector-map (lambda (x) (if (= x 255) 0 (+ x 100))) x)])
+                              ;; lock, because a GC could happen between the foreign-call return
+                              ;; and the point where we convert the reference address to an object
+                              (lock-object bv)
+                              (make-ftype-scheme-object-pointer bv)))
+                          (ftype-pointer) ftype-pointer)
+                         (make-ftype-scheme-object-pointer #vu8(1 2 3 4 5 255 0)))]
+          [new-bv (reference-address->object (- (ftype-pointer-address r) 1))])
+     (unlock-object new-bv)
+     new-bv)
+    '#vu8(101 102 103 104 105 0 100))
 )
 
 (mat foreign-strings
@@ -1972,6 +1988,9 @@
     (define B->uptr (foreign-procedure "uptr_to_uptr" ((* B) int) uptr))
     (define uptr->A (foreign-procedure "uptr_to_uptr" (uptr int) (* A)))
     (define b ((foreign-procedure (if (windows?) "windows_malloc" "malloc") (ssize_t) (* B)) (ftype-sizeof B)))
+    (define void*->void* (foreign-procedure "uptr_to_uptr" (ftype-pointer int) ftype-pointer))
+    (define obj-void*->obj-void* (foreign-procedure "uptr_to_uptr" (ftype-scheme-object-pointer int) ftype-scheme-object-pointer))
+    (define void*->obj-void* (foreign-procedure "uptr_to_uptr" (ftype-pointer int) ftype-scheme-object-pointer))
     #t)
   (eqv?
     (ftype-pointer-address (uptr->A (ftype-pointer-address (ftype-&ref B (y) b)) 0))
@@ -2238,6 +2257,44 @@
     #t)
   (eqv? (ftype-pointer-address ((ftype-ref A () a) a)) (ftype-pointer-address a))
 
+  (error? (void*->void* 0 0))
+  (ftype-pointer-null? (void*->void* (make-ftype-pointer integer-8 0) 0))
+  (error? (ftype-ref integer-8 (void*->void* (make-ftype-pointer integer-8 0) 0)))
+  (let* ([addr (foreign-alloc (ftype-sizeof integer-8))]
+         [p (make-ftype-pointer integer-8 addr)])
+    (and
+     (equal? (+ addr 3) (ftype-pointer-address (void*->void* p 3)))
+     (begin (foreign-free addr) #t)))
+  (let* ([bv (bytevector 1 2 3 4 5)]
+         [p (make-ftype-scheme-object-pointer bv 2)])
+    (collect)
+    (lock-object bv)
+    (and
+     (eqv? (+ (object->reference-address bv) 3)
+           (ftype-pointer-address (void*->void* p 1)))
+     (begin (unlock-object bv)
+            #t)))
+
+  (let* ([bv (bytevector 1 2 3 4 5)]
+         [p (make-ftype-scheme-object-pointer bv -1)])
+    (let ([new-p (obj-void*->obj-void* p 1)])
+      (collect)
+      (and (ftype-scheme-object-pointer? new-p)
+           (eq? bv (ftype-scheme-object-pointer-object new-p)))))
+
+  (let* ([bv (bytevector 1 2 3 4 5)]
+         [p (make-ftype-scheme-object-pointer bv -1)])
+    (let ([new-p (void*->obj-void* p 1)])
+      (collect)
+      (and (ftype-scheme-object-pointer? new-p)
+           (eq? bv (ftype-scheme-object-pointer-object new-p)))))
+
+  (error?
+   (obj-void*->obj-void* (make-ftype-pointer integer-8 1) 0))
+
+  (ftype-pointer-null? (void*->obj-void* (make-ftype-pointer integer-8 0) 0))
+  (ftype-pointer-null? (void*->obj-void* (make-ftype-pointer integer-8 -1) 1))
+
   (begin 
     (define-ftype A (struct [x uptr] [y uptr]))
     (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
@@ -2341,6 +2398,25 @@
     (= (proc 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 three-floats 9.0)
        (+ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 10.0 11.0 12.0 9.0)))
 
+  (let ([proc
+         (foreign-procedure "many_doubles_and_three_floats_and_float" (double double double double double double double double (& three_floats ftype-pointer) float)
+                            double)]
+        [proc2
+         (foreign-procedure "many_doubles_and_three_floats_and_float" (double double double double double double double double (& three_floats ftype-scheme-object-pointer) float)
+                            double)]
+        [bv (make-bytevector (ftype-sizeof three_floats))])
+    (define (call proc three-floats)
+      (= (proc 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 three-floats 9.0)
+         (+ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 10.0 11.0 12.0 9.0)))
+    (let loop ([i 0])
+      (unless (= i (ftype-sizeof three_floats))
+        (bytevector-s8-set! bv i (ftype-any-ref integer-8 () three-floats i))
+        (loop (add1 i))))
+    (and (call proc three-floats)
+         (call proc (make-ftype-pointer integer-8 (ftype-pointer-address three-floats)))
+         (call proc (make-ftype-scheme-object-pointer bv 0))
+         (call proc2 (make-ftype-scheme-object-pointer bv 0))))
+
   (let ([proc
          (foreign-procedure "many_doubles_and_float_and_three_floats" (double double double double double double double double float (& three_floats))
                             double)])
diff --git a/mats/ftype.ms b/mats/ftype.ms
index 455328263..ec1ea841f 100644
--- a/mats/ftype.ms
+++ b/mats/ftype.ms
@@ -84,6 +84,7 @@
     #t)
 )
 
+
 (mat ftype
    (error? ; misplaced function type
      (define-ftype IV1 (struct [i integer-8] [f (function (int) int)])))
@@ -453,7 +454,9 @@
         (integer-64 . "int64_t")
         (unsigned-64 . "uint64_t")
         (single-float . "float")
-        (double-float . "double")))
+        (double-float . "double")
+        (ftype-pointer . "void*")
+        (ftype-scheme-object-pointer . "void*")))
 
     (define ftype-paths
       (lambda (name ftype alist)
@@ -699,7 +702,10 @@
     [M2 (struct [a M1] [b integer-32])]
     [M3 (struct [a integer-32] [b M1])]
     [N1 (struct [a integer-32] [b integer-64])]
-  )
+    [P1 (struct [a ftype-pointer])]
+    [P2 (struct [a (* ftype-pointer)])]
+    [P3 (struct [a ftype-scheme-object-pointer])]
+    [P4 (struct [a (* ftype-scheme-object-pointer)])])
 
  ; ----------------
 
@@ -1064,6 +1070,85 @@
     (fptr-free b)
     #t)
 
+ ; ----------------
+  (begin
+    (define-ftype A (struct [x (* integer-8)] [y ftype-pointer]))
+    (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A))))
+    (ftype-set! A (x) a (make-ftype-pointer integer-8 (foreign-alloc (ftype-sizeof integer-8))))
+    (ftype-set! A (y) a (make-ftype-pointer integer-8 0))
+    (ftype-set! A (x *) a 10)
+    (define bv (bytevector 1 2 3 4 5))
+    (define bv-p (make-ftype-scheme-object-pointer bv 2))
+    #t)
+
+  (error? ; wrong pointer type
+   (ftype-ref integer-8 () bv-p))
+  (error? ; wrong pointer type
+   (ftype-set! integer-8 () bv-p 0))
+  (error? ; wrong pointer type
+   (ftype-ref integer-8 () (ftype-any-ref ftype-pointer () a)))
+
+  (equal? (ftype-ref A (x *) a) 10)
+  (error? ; cannot deference void
+   (ftype-ref A (y *) a))
+  (error? ; wrong pointer type
+   (ftype-set! A (x *) bv-p))
+  (ftype-pointer-null? (ftype-ref A (y) a))
+
+  (equal? (ftype-any-ref integer-8 () (ftype-any-ref ftype-pointer () a)) 10)
+
+  (eq? bv (ftype-scheme-object-pointer-object bv-p))
+  (eqv? 2 (ftype-scheme-object-pointer-offset bv-p))
+  (eqv? 3 (ftype-any-ref integer-8 () bv-p 0))
+  (eqv? 4 (ftype-any-ref integer-8 () bv-p 1))
+  (eqv? 2 (ftype-any-ref integer-8 () (make-ftype-scheme-object-pointer bv -11) 12))
+  (begin
+    (ftype-any-set! integer-8 () bv-p 1 5)
+    (eqv? 5 (bytevector-u8-ref bv 3)))
+
+  (begin
+    (collect 0)
+    (eq? bv (ftype-scheme-object-pointer-object bv-p)))
+
+  (begin
+    (foreign-free (ftype-pointer-address (ftype-ref A (x) a)))
+    (lock-object bv)
+    (ftype-set! A (x) a (make-ftype-pointer integer-8 (ftype-pointer-address bv-p)))
+    (ftype-set! A (y) a bv-p)
+    #t)
+
+  (equal? (ftype-ref A (x *) a) 3)
+  (begin
+    (unlock-object bv)
+    #t)
+  (equal? (ftype-pointer->sexpr bv-p) `(offset ,bv 2))
+  (equal? (ftype-pointer->sexpr (make-ftype-scheme-object-pointer bv)) bv)
+  (equal? (ftype-pointer->sexpr (make-ftype-scheme-object-pointer bv 0)) bv)
+
+  (begin
+    (ftype-any-set! uptr () (ftype-&ref A (y) a) 0)
+    (ftype-pointer-null? (ftype-ref A (y) a)))
+
+  ;; null read as an object pointer produces a null fptr
+  (ftype-pointer-null? (ftype-any-ref ftype-scheme-object-pointer ()
+                                      (make-ftype-scheme-object-pointer
+                                       (bytevector 0 0 0 0 0 0 0 0)
+                                       0)))
+
+  ;; ftype-any-ref offsets are not scaled by the type
+  (equal? #x0202 (ftype-any-ref unsigned-16 () (make-ftype-scheme-object-pointer (bytevector 1 1 2 2 3 3 4 4))
+                                2))
+  (let ([bv (bytevector 1 1 2 2 3 3 4 4)])
+    (ftype-any-set! unsigned-16 () (make-ftype-scheme-object-pointer bv) 2 #x0505)
+    (equal? bv #vu8(1 1 5 5 3 3 4 4)))
+
+  (let ([bv (make-reference-bytevector 8)])
+    (ftype-any-set! ftype-scheme-object-pointer () (make-ftype-scheme-object-pointer bv) 0 (make-ftype-scheme-object-pointer 'hello))
+    (collect)
+    (eq? (ftype-scheme-object-pointer-object
+          (ftype-any-ref ftype-scheme-object-pointer () (make-ftype-scheme-object-pointer bv) 0))
+         'hello))
+
  ; ----------------
   (begin
     (define-ftype Q
diff --git a/mats/oop.ss b/mats/oop.ss
index 61081c02f..3130cfa9b 100644
--- a/mats/oop.ss
+++ b/mats/oop.ss
@@ -189,6 +189,7 @@ reaching into Chez Scheme's internals for:
       "root-vtable-rtd"
       '((immutable ptr interfaces))
       #f
+      #f
       #f))
 
   (define construct-name
@@ -686,6 +687,7 @@ reaching into Chez Scheme's internals for:
                                               name
                                               flds
                                               #f
+                                              #f
                                               #f)]
                                      [vtable-rtd (#%$make-record-type
                                                    #!base-rtd
@@ -693,6 +695,7 @@ reaching into Chez Scheme's internals for:
                                                    "compile-time-vtable-rtd"
                                                    (syntax->datum (map minfo-mname #'(generic ...)))
                                                    #f
+                                                   #f
                                                    #f)])
                          (with-syntax ([(ivar ...) ivar*]
                                        [(ivar-init ...) ivar-init*]
@@ -728,6 +731,7 @@ reaching into Chez Scheme's internals for:
                                                     'flds
                                                     #f
                                                     #f
+                                                    #f
                                                     (list iface-elt ...)
                                                     vtable-init ...)))]
                                          [((generic-name (generic-formals generic-flat-formals generic-offset) ...) ...)
diff --git a/mats/patch-interpret-0-f-f-f b/mats/patch-interpret-0-f-f-f
index d097c5d1f..e48d7302f 100644
--- a/mats/patch-interpret-0-f-f-f
+++ b/mats/patch-interpret-0-f-f-f
@@ -1,5 +1,5 @@
-*** output-compile-0-f-f-f-simple/errors-compile-0-f-f-f	Sat Aug  5 10:44:42 2023
---- output-interpret-0-f-f-f-cl6/errors-interpret-0-f-f-f	Sat Aug  5 10:50:25 2023
+*** output-compile-0-f-f-f-experr/errors-compile-0-f-f-f	Fri Dec 20 18:19:27 2024
+--- output-interpret-0-f-f-f-experr/errors-interpret-0-f-f-f	Fri Dec 20 18:20:50 2024
 ***************
 *** 24,31 ****
   primvars.mo:Expected error testing (call-in-continuation 1.0+2.0i (quote #f) values): Exception in call-in-continuation: 1.0+2.0i is not a continuation
@@ -234,7 +234,7 @@
   4.mo:Expected error in mat refcount-guardians: "first field must be a word-sized integer with native endianness (ftype-guardian A)".
   4.mo:Expected error in mat refcount-guardians: "first field must be a word-sized integer with native endianness (ftype-guardian A)".
 ***************
-*** 7453,7461 ****
+*** 7488,7496 ****
   io.mo:Expected error in mat transcoded-port-buffer-size: "transcoded-port-buffer-size: 1024.0 is not a positive fixnum".
   io.mo:Expected error in mat make-codec-buffer: "incorrect argument count in call (make-codec-buffer (lambda (bp) (make-bytevector 4)) "extra arg")".
   io.mo:Expected error in mat make-codec-buffer: "make-codec-buffer: shoe is not a procedure".
@@ -244,7 +244,7 @@
   io.mo:Expected error in mat compress-parameters: "compress-format: foo is not a supported format".
   io.mo:Expected error in mat compress-parameters: "compress-format: "gzip" is not a supported format".
   io.mo:Expected error in mat compress-parameters: "compress-level: foo is not a supported level".
---- 7453,7461 ----
+--- 7488,7496 ----
   io.mo:Expected error in mat transcoded-port-buffer-size: "transcoded-port-buffer-size: 1024.0 is not a positive fixnum".
   io.mo:Expected error in mat make-codec-buffer: "incorrect argument count in call (make-codec-buffer (lambda (bp) (make-bytevector 4)) "extra arg")".
   io.mo:Expected error in mat make-codec-buffer: "make-codec-buffer: shoe is not a procedure".
@@ -255,7 +255,7 @@
   io.mo:Expected error in mat compress-parameters: "compress-format: "gzip" is not a supported format".
   io.mo:Expected error in mat compress-parameters: "compress-level: foo is not a supported level".
 ***************
-*** 7728,7735 ****
+*** 7763,7770 ****
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@@ -264,7 +264,7 @@
   7.mo:Expected error in mat eval: "compile: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
---- 7728,7735 ----
+--- 7763,7770 ----
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@@ -274,7 +274,7 @@
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
 ***************
-*** 8123,8129 ****
+*** 8158,8164 ****
   record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
   record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
   record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@@ -282,7 +282,7 @@
   record.mo:Expected error in mat record25: "invalid value 12.0 for foreign type long-long".
   record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
   record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
---- 8123,8129 ----
+--- 8158,8164 ----
   record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
   record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
   record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@@ -291,7 +291,7 @@
   record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
   record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
 ***************
-*** 8167,8174 ****
+*** 8202,8209 ****
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
@@ -300,7 +300,7 @@
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: record constructor descriptor #<record constructor descriptor> is not for parent of record type #<record type grand-child>".
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo".
   record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point".
---- 8167,8174 ----
+--- 8202,8209 ----
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 1 to #<procedure>".
   record.mo:Expected error in mat r6rs-records-procedural: "incorrect number of arguments 3 to #<procedure>".
@@ -310,7 +310,7 @@
   record.mo:Expected error in mat r6rs-records-procedural: "make-record-type-descriptor: cannot extend sealed record type #<record type bar> as foo".
   record.mo:Expected error in mat r6rs-records-syntactic: "invalid syntax point".
 ***************
-*** 9449,9461 ****
+*** 9486,9498 ****
   fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@@ -324,7 +324,7 @@
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
---- 9449,9461 ----
+--- 9486,9498 ----
   fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx-/wraparound: "fx-: <-int> is not a fixnum".
   fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@@ -339,7 +339,7 @@
   fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
   fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
 ***************
-*** 10235,10259 ****
+*** 10283,10307 ****
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@@ -365,7 +365,7 @@
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier booleen".
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
---- 10235,10259 ----
+--- 10283,10307 ----
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@@ -392,7 +392,7 @@
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
 ***************
-*** 10266,10297 ****
+*** 10314,10345 ****
   foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@@ -425,7 +425,7 @@
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
---- 10266,10297 ----
+--- 10314,10345 ----
   foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@@ -459,7 +459,7 @@
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
 ***************
-*** 10299,10324 ****
+*** 10347,10372 ****
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@@ -486,7 +486,7 @@
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
---- 10299,10324 ----
+--- 10347,10372 ----
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@@ -514,7 +514,7 @@
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
 ***************
-*** 10330,10364 ****
+*** 10378,10412 ****
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@@ -550,7 +550,7 @@
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
---- 10330,10364 ----
+--- 10378,10412 ----
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@@ -587,7 +587,28 @@
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
 ***************
-*** 10973,10982 ****
+*** 10451,10459 ****
+  foreign.mo:Expected error in mat foreign-ftype: "foreign-entry: 1000000 is not a string".
+  foreign.mo:Expected error in mat foreign-ftype: "foreign-entry: no entry for "i am not defined"".
+  foreign.mo:Expected error in mat foreign-ftype: "unexpected function ftype name outside pointer field A".
+! foreign.mo:Expected error in mat foreign-ftype: "void*->void*: invalid foreign-procedure argument 0".
+  foreign.mo:Expected error in mat foreign-ftype: "invalid syntax (ftype-ref integer-8 (void*->void* (make-ftype-pointer integer-8 0) 0))".
+! foreign.mo:Expected error in mat foreign-ftype: "obj-void*->obj-void*: invalid foreign-procedure argument <ftype-pointer>".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+--- 10451,10459 ----
+  foreign.mo:Expected error in mat foreign-ftype: "foreign-entry: 1000000 is not a string".
+  foreign.mo:Expected error in mat foreign-ftype: "foreign-entry: no entry for "i am not defined"".
+  foreign.mo:Expected error in mat foreign-ftype: "unexpected function ftype name outside pointer field A".
+! foreign.mo:Expected error in mat foreign-ftype: "uptr_to_uptr: invalid foreign-procedure argument 0".
+  foreign.mo:Expected error in mat foreign-ftype: "invalid syntax (ftype-ref integer-8 (void*->void* (make-ftype-pointer integer-8 0) 0))".
+! foreign.mo:Expected error in mat foreign-ftype: "uptr_to_uptr: invalid foreign-procedure argument <ftype-pointer>".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+***************
+*** 11042,11051 ****
   exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
   exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
   exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@@ -598,7 +619,7 @@
   oop.mo:Expected error in mat oop: "m1: not applicable to 17".
   oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
   oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
---- 10973,10982 ----
+--- 11042,11051 ----
   exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
   exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
   exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
diff --git a/mats/patch-interpret-0-t-f-f b/mats/patch-interpret-0-t-f-f
index acb7cc0c9..f41832ae8 100644
--- a/mats/patch-interpret-0-t-f-f
+++ b/mats/patch-interpret-0-t-f-f
@@ -1,5 +1,5 @@
-*** output-compile-0-t-f-f-experr/errors-compile-0-t-f-f	Sat Aug  5 15:05:28 2023
---- output-interpret-0-t-f-f-experr/errors-interpret-0-t-f-f	Sat Aug  5 15:07:10 2023
+*** output-compile-0-t-f-f-experr/errors-compile-0-t-f-f	Fri Dec 20 18:23:34 2024
+--- output-interpret-0-t-f-f-experr/errors-interpret-0-t-f-f	Fri Dec 20 18:25:02 2024
 ***************
 *** 24,31 ****
   primvars.mo:Expected error testing (call-in-continuation 1.0+2.0i (quote #f) values): Exception in call-in-continuation: 1.0+2.0i is not a continuation
@@ -199,7 +199,7 @@
   4.mo:Expected error in mat refcount-guardians: "first field must be a word-sized integer with native endianness (ftype-guardian A)".
   4.mo:Expected error in mat refcount-guardians: "first field must be a word-sized integer with native endianness (ftype-guardian A)".
 ***************
-*** 7453,7461 ****
+*** 7488,7496 ****
   io.mo:Expected error in mat transcoded-port-buffer-size: "transcoded-port-buffer-size: 1024.0 is not a positive fixnum".
   io.mo:Expected error in mat make-codec-buffer: "incorrect number of arguments 2 to #<procedure make-codec-buffer>".
   io.mo:Expected error in mat make-codec-buffer: "make-codec-buffer: shoe is not a procedure".
@@ -209,7 +209,7 @@
   io.mo:Expected error in mat compress-parameters: "compress-format: foo is not a supported format".
   io.mo:Expected error in mat compress-parameters: "compress-format: "gzip" is not a supported format".
   io.mo:Expected error in mat compress-parameters: "compress-level: foo is not a supported level".
---- 7453,7461 ----
+--- 7488,7496 ----
   io.mo:Expected error in mat transcoded-port-buffer-size: "transcoded-port-buffer-size: 1024.0 is not a positive fixnum".
   io.mo:Expected error in mat make-codec-buffer: "incorrect number of arguments 2 to #<procedure make-codec-buffer>".
   io.mo:Expected error in mat make-codec-buffer: "make-codec-buffer: shoe is not a procedure".
@@ -220,7 +220,7 @@
   io.mo:Expected error in mat compress-parameters: "compress-format: "gzip" is not a supported format".
   io.mo:Expected error in mat compress-parameters: "compress-level: foo is not a supported level".
 ***************
-*** 7728,7735 ****
+*** 7763,7770 ****
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@@ -229,7 +229,7 @@
   7.mo:Expected error in mat eval: "compile: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
---- 7728,7735 ----
+--- 7763,7770 ----
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: file "testfile-mc-1a.ss" not found in source directories
   7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@@ -239,7 +239,7 @@
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
   7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
 ***************
-*** 8123,8129 ****
+*** 8158,8164 ****
   record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
   record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
   record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@@ -247,7 +247,7 @@
   record.mo:Expected error in mat record25: "invalid value 12.0 for foreign type long-long".
   record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
   record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
---- 8123,8129 ----
+--- 8158,8164 ----
   record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
   record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
   record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@@ -256,7 +256,7 @@
   record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
   record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
 ***************
-*** 10235,10259 ****
+*** 10283,10307 ****
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@@ -282,7 +282,7 @@
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier booleen".
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
---- 10235,10259 ----
+--- 10283,10307 ----
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
   foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@@ -309,7 +309,7 @@
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
   foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
 ***************
-*** 10266,10297 ****
+*** 10314,10345 ****
   foreign.mo:Expected error in mat foreign-sizeof: "incorrect number of arguments 2 to #<procedure foreign-sizeof>".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@@ -342,7 +342,7 @@
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
---- 10266,10297 ----
+--- 10314,10345 ----
   foreign.mo:Expected error in mat foreign-sizeof: "incorrect number of arguments 2 to #<procedure foreign-sizeof>".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
   foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@@ -376,7 +376,7 @@
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
 ***************
-*** 10299,10324 ****
+*** 10347,10372 ****
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@@ -403,7 +403,7 @@
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
---- 10299,10324 ----
+--- 10347,10372 ----
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
   foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@@ -431,7 +431,7 @@
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
 ***************
-*** 10330,10364 ****
+*** 10378,10412 ****
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@@ -467,7 +467,7 @@
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
---- 10330,10364 ----
+--- 10378,10412 ----
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
   foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@@ -504,7 +504,28 @@
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
   foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
 ***************
-*** 10973,10982 ****
+*** 10451,10459 ****
+  foreign.mo:Expected error in mat foreign-ftype: "foreign-entry: 1000000 is not a string".
+  foreign.mo:Expected error in mat foreign-ftype: "foreign-entry: no entry for "i am not defined"".
+  foreign.mo:Expected error in mat foreign-ftype: "unexpected function ftype name outside pointer field A".
+! foreign.mo:Expected error in mat foreign-ftype: "void*->void*: invalid foreign-procedure argument 0".
+  foreign.mo:Expected error in mat foreign-ftype: "invalid syntax (ftype-ref integer-8 (void*->void* (make-ftype-pointer integer-8 0) 0))".
+! foreign.mo:Expected error in mat foreign-ftype: "obj-void*->obj-void*: invalid foreign-procedure argument <ftype-pointer>".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+--- 10451,10459 ----
+  foreign.mo:Expected error in mat foreign-ftype: "foreign-entry: 1000000 is not a string".
+  foreign.mo:Expected error in mat foreign-ftype: "foreign-entry: no entry for "i am not defined"".
+  foreign.mo:Expected error in mat foreign-ftype: "unexpected function ftype name outside pointer field A".
+! foreign.mo:Expected error in mat foreign-ftype: "uptr_to_uptr: invalid foreign-procedure argument 0".
+  foreign.mo:Expected error in mat foreign-ftype: "invalid syntax (ftype-ref integer-8 (void*->void* (make-ftype-pointer integer-8 0) 0))".
+! foreign.mo:Expected error in mat foreign-ftype: "uptr_to_uptr: invalid foreign-procedure argument <ftype-pointer>".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+  foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
+***************
+*** 11042,11051 ****
   exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
   exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
   exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@@ -515,7 +536,7 @@
   oop.mo:Expected error in mat oop: "m1: not applicable to 17".
   oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
   oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
---- 10973,10982 ----
+--- 11042,11051 ----
   exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
   exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
   exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
diff --git a/mats/primvars.ms b/mats/primvars.ms
index bb44cf8a7..97eaa8fe4 100644
--- a/mats/primvars.ms
+++ b/mats/primvars.ms
@@ -419,6 +419,7 @@
               [(fixnum) -1 'q (+ (most-positive-fixnum) 1) (- (most-negative-fixnum) 1) #f]
               [(flonum) 0.0 0 0.0+1.0i 'a #f]
               [(ftype-pointer) *ftype-pointer 0 *time #f]
+              [(sub-ftype-pointer) no-good]
               [(fxvector) '#vfx(0) "a" #f]
               [(flvector) '#vfl(0.0) "a" #f]
               [(gensym) *genny 'sym #f]
diff --git a/mats/record.ms b/mats/record.ms
index 08b34aff5..94d05bd61 100644
--- a/mats/record.ms
+++ b/mats/record.ms
@@ -3593,6 +3593,7 @@
                '()               ; no fields to add
                #t                ; sealed
                #f                ; not opaque
+               #f                ; no alt-pm
                '*sym->index*     ; extras (tacked onto end of rtd)
                '*index->sym*)])  ; i.e., static (per enumeration type) fields
         (let ([make-this-enum (record-constructor this-enum-rtd)])
@@ -3605,8 +3606,8 @@
                 (get-index->sym rtd)))))))
     '(*members* *sym->index* *index->sym*))
   (error? ; cannot extend sealed record type
-    (let ([rtd1 (#%$make-record-type #!base-rtd #f "foo" '() #t #f '())])
-      (#%$make-record-type #!base-rtd rtd1 "bar" '() #f #f '())))
+    (let ([rtd1 (#%$make-record-type #!base-rtd #f "foo" '() #t #f #f '())])
+      (#%$make-record-type #!base-rtd rtd1 "bar" '() #f #f #f '())))
 )
 
 (mat record25
@@ -3789,9 +3790,9 @@
                (define-syntax a
                  (lambda (x)
                    (let* ([rtd1 (#%$make-record-type #!base-rtd #!base-rtd
-                                  "rtd1" '((mutable q)) #f #f)]
+                                  "rtd1" '((mutable q)) #f #f #f)]
                           [rtd2 (#%$make-record-type rtd1 #!base-rtd
-                                  "rtd2" '() #f #f #f)])
+                                  "rtd2" '() #f #f #f #f)])
                      ((record-mutator rtd1 0) rtd2 rtd2)
                      #`(quote #,rtd2))))
                a))))
@@ -3818,11 +3819,11 @@
                (define-syntax a
                  (lambda (x)
                    (let* ([rtd1 (#%$make-record-type #!base-rtd #!base-rtd
-                                  "rtd1" '((mutable q)) #f #f)]
+                                  "rtd1" '((mutable q)) #f #f #f)]
                           [rtd2 (#%$make-record-type rtd1 #!base-rtd
-                                  "rtd2" '() #f #f #f)]
+                                  "rtd2" '() #f #f #f #f)]
                           [rtd3 (#%$make-record-type rtd2 #!base-rtd
-                                  "rtd3" '() #f #f)])
+                                  "rtd3" '() #f #f #f)])
                      ((record-mutator rtd1 0) rtd2 rtd3)
                      #`(quote #,rtd3))))
                a))))
@@ -3848,11 +3849,11 @@
                (define-syntax a
                  (lambda (x)
                    (let* ([rtd1 (#%$make-record-type #!base-rtd #!base-rtd
-                                  "rtd1" '((mutable q)) #f #f)]
+                                  "rtd1" '((mutable q)) #f #f #f)]
                           [rtd2 (#%$make-record-type rtd1 #!base-rtd
-                                  "rtd2" '() #f #f #f)]
+                                  "rtd2" '() #f #f #f #f)]
                           [rtd3 (#%$make-record-type rtd2 #f
-                                  "rtd3" '((immutable a)) #f #f)])
+                                  "rtd3" '((immutable a)) #f #f #f)])
                      ((record-mutator rtd1 0) rtd2 ((record-constructor rtd3) 23))
                      #`(quote #,rtd3))))
                a))))
diff --git a/mats/root-experr-compile-0-f-f-f b/mats/root-experr-compile-0-f-f-f
index bc90688e4..e8c2d2edc 100644
--- a/mats/root-experr-compile-0-f-f-f
+++ b/mats/root-experr-compile-0-f-f-f
@@ -10451,6 +10451,9 @@ foreign.mo:Expected error in mat foreign-ftype: "invalid syntax (make-ftype-poin
 foreign.mo:Expected error in mat foreign-ftype: "foreign-entry: 1000000 is not a string".
 foreign.mo:Expected error in mat foreign-ftype: "foreign-entry: no entry for "i am not defined"".
 foreign.mo:Expected error in mat foreign-ftype: "unexpected function ftype name outside pointer field A".
+foreign.mo:Expected error in mat foreign-ftype: "void*->void*: invalid foreign-procedure argument 0".
+foreign.mo:Expected error in mat foreign-ftype: "invalid syntax (ftype-ref integer-8 (void*->void* (make-ftype-pointer integer-8 0) 0))".
+foreign.mo:Expected error in mat foreign-ftype: "obj-void*->obj-void*: invalid foreign-procedure argument <ftype-pointer>".
 foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
 foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
 foreign.mo:Expected error in mat foreign-callable: "foreign-callable: spam is not a procedure".
@@ -10540,6 +10543,11 @@ ftype.mo:Expected error in mat ftype: "non-scalar value cannot be assigned (ftyp
 ftype.mo:Expected error in mat ftype: "non-scalar value cannot be referenced (ftype-ref B (tail *) b)".
 ftype.mo:Expected error in mat ftype: "recursive or forward reference outside pointer field Qfrob".
 ftype.mo:Expected error in mat ftype: "recursive or forward reference outside pointer field Qsnark".
+ftype.mo:Expected error in mat ftype: "ftype-ref: ftype mismatch for <ftype-pointer>".
+ftype.mo:Expected error in mat ftype: "ftype-set!: ftype mismatch for <ftype-pointer>".
+ftype.mo:Expected error in mat ftype: "ftype-ref: ftype mismatch for <ftype-pointer>".
+ftype.mo:Expected error in mat ftype: "cannot dereference generic pointer *".
+ftype.mo:Expected error in mat ftype: "invalid syntax (ftype-set! A (x *) bv-p)".
 ftype.mo:Expected error in mat ftype: "ftype-ref: invalid index -1 for #<ftd array>".
 ftype.mo:Expected error in mat ftype: "ftype-ref: invalid index 3.2 for #<ftd array>".
 ftype.mo:Expected error in mat ftype: "ftype-ref: invalid index <int> for #<ftd array>".
diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex
index 4170a0d3a..db8258d97 100644
--- a/release_notes/release_notes.stex
+++ b/release_notes/release_notes.stex
@@ -121,6 +121,43 @@ Online versions of both books can be found at
 The type recovery pass has improved support for \scheme{abs} with a fixnum argument
 and added support for \scheme{1+}, \scheme{1-}, and \scheme{-1+}.
 
+\subsection{Foreign pointers to Scheme objects (10.2.0)}
+
+The \scheme{make-ftype-scheme-object-pointer} function facilitates a
+unified view of foreign-allocated addresses and addresses that are
+under control of the memory manager---especially addresses for
+bytevector and flvector content. Unlike extracting an address via
+\scheme{object->reference-address} and using it to construct a regular
+ftype pointer, the \scheme{make-ftype-scheme-object-pointer} function
+creates an ftype pointer that coopeartes with the memory manager to
+ensure that the encapsulated address does not go stale. When the
+pointer is passed in a call to a foreign function, its address can be
+extracted after the point where garbage collections can occur,
+assuming that \scheme{__collect_safe} is not used.
+
+To make this unified pointer representation at the ftype pointer layer
+(\scheme{ftype-ref}, \scheme{ftype-set!}, etc.) as flexible as the raw
+address layer (\scheme{foreign-ref}, \scheme{foreign-set!}, etc.), new
+forms such as \scheme{ftype-any-ref} use generic pointers independent
+of the pointer's ftype. This flexibility comes at the cost of
+consistency checking, which means that the new operations are less
+safe than operations that are sensitive to a pointer's ftype.
+
+Additions:
+
+\schemedisplay
+make-ftype-scheme-object-pointer
+ftype-scheme-object-pointer?
+ftype-scheme-object-pointer-object
+ftype-scheme-object-pointer-offset
+ftype-any-ref
+ftype-any-set!
+ftype-pointer               ; as \var{ftype-name}
+ftype-scheme-object-pointer ; as \var{ftype-name}
+(& \var{ftype-name} ftype-pointer) ; as call argument or result
+(& \var{ftype-name} ftype-scheme-object-pointer) ; as argument/result
+\endschemedisplay
+
 \subsection{Constrain signal delivery to the main thread (10.1.0)}
 
 Signals are now always delivered to the main Scheme thread to avoid crashes when a signal
diff --git a/s/arm32.ss b/s/arm32.ss
index 21b38c779..44dae1ba0 100644
--- a/s/arm32.ss
+++ b/s/arm32.ss
@@ -2396,7 +2396,7 @@
                                    (fx= (cadr m) 4)))
     (define (indirect-result-that-fits-in-registers? result-type)
       (nanopass-case (Ltype Type) result-type
-        [(fp-ftd& ,ftd)
+        [(fp-ftd& ,ftd ,fptd)
          (let* ([members ($ftd->members ftd)]
                 [num-members (length members)])
            (or (fx<= ($ftd-size ftd) 4)
@@ -2595,7 +2595,7 @@
                                (loop (cdr types)
                                      (cons (load-single-stack isp) locs)
                                      live* int* '() #f (fx+ isp 4))])]
-                            [(fp-ftd& ,ftd)
+                            [(fp-ftd& ,ftd ,fptd)
                              (let ([size ($ftd-size ftd)]
                                    [members ($ftd->members ftd)]
                                    [combine-loc (lambda (loc f)
@@ -2701,7 +2701,7 @@
                     (cond
                      [fill-result-here?
                       (nanopass-case (Ltype Type) result-type
-                        [(fp-ftd& ,ftd)
+                        [(fp-ftd& ,ftd ,fptd)
                          (let* ([members ($ftd->members ftd)]
                                 [num-members (length members)]
                                 ;; result pointer is stashed on the stack after all arguments:
@@ -2760,7 +2760,7 @@
                        (case bits
                          [(64) (list %r1 %Cretval)]
                          [else (list %Cretval)])]
-                      [(fp-ftd& ,ftd)
+                      [(fp-ftd& ,ftd ,fptd)
                        (let* ([members ($ftd->members ftd)]
                               [num-members (length members)])
                          (cond
@@ -2965,7 +2965,7 @@
                                (if (fx< idbl 8)
                                    (f (cdr types) iint (fx+ idbl 1) #t)
                                    (f (cdr types) iint idbl #f))))]
-                      [(fp-ftd& ,ftd)
+                      [(fp-ftd& ,ftd ,fptd)
                        (let* ([size ($ftd-size ftd)]
                               [members ($ftd->members ftd)]
                               [num-members (length members)])
@@ -3076,7 +3076,7 @@
                            (loop (cdr types)
                                  (cons (load-single-stack stack-arg-offset) locs)
                                  iint num-dbl-regs #f int-reg-offset float-reg-offset (fx+ stack-arg-offset 4))])]
-                        [(fp-ftd& ,ftd)
+                        [(fp-ftd& ,ftd ,fptd)
                          (let* ([size ($ftd-size ftd)]
                                 [members ($ftd->members ftd)]
                                 [num-members (length members)])
@@ -3163,7 +3163,7 @@
           (define do-result
             (lambda (result-type synthesize-first? varargs? return-stack-offset)
               (nanopass-case (Ltype Type) result-type
-                [(fp-ftd& ,ftd)
+                [(fp-ftd& ,ftd ,fptd)
                  (let* ([members ($ftd->members ftd)]
                         [num-members (length members)])
                    (cond
diff --git a/s/arm64.ss b/s/arm64.ss
index fe3e2de2c..23fab0ddf 100644
--- a/s/arm64.ss
+++ b/s/arm64.ss
@@ -2405,7 +2405,7 @@
                                    (fx= (cadr m) 4)))
     (define (indirect-result-that-fits-in-registers? result-type)
       (nanopass-case (Ltype Type) result-type
-        [(fp-ftd& ,ftd)
+        [(fp-ftd& ,ftd ,fptd)
          (let* ([members ($ftd->members ftd)]
                 [num-members (length members)])
            (or (fx<= ($ftd-size ftd) 4)
@@ -2478,9 +2478,10 @@
                                                (= stack-align (align 8 stack-align)))
                                                4
                                                8)]
-                                              [(fp-ftd& ,ftd) (cond
-                                                                [(> ($ftd-size ftd) 16) 8]
-                                                                [else ($ftd-alignment ftd)])]
+                                              [(fp-ftd& ,ftd ,fptd)
+                                               (cond
+                                                 [(> ($ftd-size ftd) 16) 8]
+                                                 [else ($ftd-alignment ftd)])]
                                               [(fp-integer ,bits) (fxquotient bits 8)]
                                               [(fp-unsigned ,bits) (fxquotient bits 8)]
                                               [else 8])])])
@@ -2513,19 +2514,20 @@
                        (nanopass-case (Ltype Type) (car types)
                          [(fp-double-float) (use-fp-regs 1)]
                          [(fp-single-float) (use-fp-regs 1)]
-                         [(fp-ftd& ,ftd) (cond
-                                           [(> ($ftd-size ftd) 16) (next-is-stack types)]
-                                           [else
-                                            (let ([members ($ftd->members ftd)])
-                                              (cond
-                                                [(and (fx= 8 ($ftd-alignment ftd))
-                                                      (andmap double-member? members))
-                                                 (use-fp-regs (length members))]
-                                                [(and (fx= 4 ($ftd-alignment ftd))
-                                                      (andmap float-member? members))
-                                                 (use-fp-regs (length members))]
-                                                [else
-                                                 (use-int-regs (fxquotient (align ($ftd-size ftd) 8) 8))]))])]
+                         [(fp-ftd& ,ftd ,fptd)
+                          (cond
+                            [(> ($ftd-size ftd) 16) (next-is-stack types)]
+                            [else
+                             (let ([members ($ftd->members ftd)])
+                               (cond
+                                 [(and (fx= 8 ($ftd-alignment ftd))
+                                       (andmap double-member? members))
+                                  (use-fp-regs (length members))]
+                                 [(and (fx= 4 ($ftd-alignment ftd))
+                                       (andmap float-member? members))
+                                  (use-fp-regs (length members))]
+                                 [else
+                                  (use-int-regs (fxquotient (align ($ftd-size ftd) 8) 8))]))])]
                          [else (use-int-regs 1)]))])))])]
           [else
            (k (align 8 size) 0 0)])))
@@ -2599,7 +2601,7 @@
                             (loop (cdr types) (rest-of int* 0 next-varargs-after)(rest-of fp* 1 next-varargs-after)
                                   next-varargs-after
                                   stack-align))])]
-                  [(fp-ftd& ,ftd)
+                  [(fp-ftd& ,ftd ,fptd)
                    (let* ([size ($ftd-size ftd)]
                           [members (filter-union ($ftd->members ftd))]
                           [num-members (length members)]
@@ -2820,7 +2822,7 @@
                                   (loop types cats
                                         (cons (load-single-stack isp) locs)
                                         (fx+ isp (cat-size cat) (cat-pad cat)) ind-sp)])]
-                              [(fp-ftd& ,ftd)
+                              [(fp-ftd& ,ftd ,fptd)
                                (let ([size ($ftd-size ftd)])
                                  (case (cat-place cat)
                                    [(int)
@@ -2903,7 +2905,7 @@
                   ;; may destroy the values in result registers
                   (lambda (result-cat result-type args-frame-size fill-result-here? e)
                     (nanopass-case (Ltype Type) result-type
-                      [(fp-ftd& ,ftd)
+                      [(fp-ftd& ,ftd ,fptd)
                        (let* ([size ($ftd-size ftd)]
                               [tmp %argtmp])
                          (case (and fill-result-here?
@@ -2949,7 +2951,7 @@
             (let* ([arg-type* (info-foreign-arg-type* info)]
                    [result-type (info-foreign-result-type info)]
                    [ftd-result? (nanopass-case (Ltype Type) result-type
-                                  [(fp-ftd& ,ftd) #t]
+                                  [(fp-ftd& ,ftd ,fptd) #t]
                                   [else #f])]
                    [arg-type* (if ftd-result?
                                   (cdr arg-type*)
@@ -3141,7 +3143,7 @@
                             (loop types cats
                                   (cons (load-single-stack stack-arg-offset) locs)
                                   int-reg-offset float-reg-offset (fx+ stack-arg-offset (cat-size cat) (cat-pad cat)))])]
-                        [(fp-ftd& ,ftd)
+                        [(fp-ftd& ,ftd ,fptd)
                          (case (cat-place cat)
                            [(int)
                             (let ([indirect-bytes (cat-indirect-bytes cat)])
@@ -3220,7 +3222,7 @@
                    `(set! ,%Cfpretval ,(%inline double->single ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp))))]
                 [(fp-void)
                  (lambda () `(nop))]
-                [(fp-ftd& ,ftd)
+                [(fp-ftd& ,ftd ,fptd)
                  (cond
                   [(cat-indirect-bytes result-cat)
                    ;; we passed the pointer to be filled, so nothing more to do here
@@ -3280,7 +3282,7 @@
             (let* ([arg-type* (info-foreign-arg-type* info)]
                    [result-type (info-foreign-result-type info)]
                    [ftd-result? (nanopass-case (Ltype Type) result-type
-                                  [(fp-ftd& ,ftd) #t]
+                                  [(fp-ftd& ,ftd ,fptd) #t]
                                   [else #f])]
                    [arg-type* (if ftd-result?
                                   (cdr arg-type*)
diff --git a/s/base-lang.ss b/s/base-lang.ss
index 433e701c4..dada27b83 100644
--- a/s/base-lang.ss
+++ b/s/base-lang.ss
@@ -190,10 +190,11 @@
 
   ; language of foreign types
   (define-language Ltype 
-    (nongenerative-id #{Ltype czp82kxwe75y4e18-1})
+    (nongenerative-id #{Ltype czp82kxwe75y4e77-1})
     (terminals
       (exact-integer (bits))
-      ($ftd (ftd)))
+      ($ftd (ftd))
+      ($fptd (fptd)))
     (Type (t)
       (fp-integer bits)
       (fp-unsigned bits)
@@ -205,8 +206,8 @@
       (fp-fixnum)
       (fp-double-float)
       (fp-single-float)
-      (fp-ftd ftd)
-      (fp-ftd& ftd)))
+      (fp-fptd fptd)       ; `fptd` is rtd for a pointer record
+      (fp-ftd& ftd fptd))) ; `ftd` describes passed value; `fptd` is rtd for a pointer record
 
   (define arity?
     (lambda (x)
diff --git a/s/cmacros.ss b/s/cmacros.ss
index 7033e07c0..369942338 100644
--- a/s/cmacros.ss
+++ b/s/cmacros.ss
@@ -357,7 +357,7 @@
 ;; ---------------------------------------------------------------------
 ;; Version and machine types:
 
-(define-constant scheme-version #x0a020001)
+(define-constant scheme-version #x0a020002)
 
 (define-syntax define-machine-types
   (lambda (x)
diff --git a/s/cp0.ss b/s/cp0.ss
index be6d88b1e..9c2ead447 100644
--- a/s/cp0.ss
+++ b/s/cp0.ss
@@ -133,7 +133,7 @@
   (define ctrtd-opaque-known #b0000001)
   (define ctrtd-sealed-known #b0000010)
 
-  (define base-ctrtd ($make-record-type #!base-rtd #!base-rtd "ctrtd" '((immutable flags)) #t #f))
+  (define base-ctrtd ($make-record-type #!base-rtd #!base-rtd "ctrtd" '((immutable flags)) #t #f #f))
   (define ctrtd? (record-predicate base-ctrtd))
   (define ctrtd-flags (record-accessor base-ctrtd 0))
 
@@ -3477,8 +3477,12 @@
                          (values #f ctrtd-opaque-known)
                          (values #f 0)))]
                 [else (values #f 0)])))
+        (define (get-alt-pm x)
+          (nanopass-case (Lsrc Expr) (if x (result-exp (value-visit-operand! x)) false-rec)
+            [(quote ,d) d]
+            [else #f]))
         (let ()
-          (define (mrt ?parent ?name ?fields maybe-?sealed maybe-?opaque ctxt level prim primname opnd*)
+          (define (mrt ?parent ?name ?fields maybe-?sealed maybe-?opaque maybe-?alt-pm ctxt level prim primname opnd*)
             (or (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?name))
                   [(quote ,d)
                    (and (gensym? d)
@@ -3495,11 +3499,12 @@
                     (get-fields ?fields
                       (lambda (fields)
                         (let-values ([(sealed? sealed-flag) (get-sealed maybe-?sealed)]
-                                     [(opaque? opaque-flag) (get-opaque maybe-?opaque prtd)])
+                                     [(opaque? opaque-flag) (get-opaque maybe-?opaque prtd)]
+                                     [(alt-pm) (get-alt-pm maybe-?alt-pm)])
                           (cond
                             [(guard (c [#t #f])
                                ($make-record-type base-ctrtd prtd "tmp" fields
-                                 sealed? opaque? (fxlogor sealed-flag opaque-flag))) =>
+                                  sealed? opaque? alt-pm (fxlogor sealed-flag opaque-flag))) =>
                              (lambda (ctrtd)
                                (residualize-seq opnd* '() ctxt)
                                `(record-type ,ctrtd
@@ -3509,16 +3514,16 @@
 
           (define-inline 2 make-record-type
             [(?name ?fields)
-             (mrt #f ?name ?fields #f #f ctxt level make-record-type 'make-record-type
+             (mrt #f ?name ?fields #f #f #f ctxt level make-record-type 'make-record-type
                (list ?name ?fields))]
             [(?parent ?name ?fields)
-             (mrt ?parent ?name ?fields #f #f ctxt level make-record-type 'make-record-type
+             (mrt ?parent ?name ?fields #f #f #f ctxt level make-record-type 'make-record-type
                (list ?parent ?name ?fields))])
 
           (define-inline 2 $make-record-type
-            [(?base-id ?parent ?name ?fields ?sealed ?opaque . ?extras)
-             (mrt ?parent ?name ?fields ?sealed ?opaque ctxt level $make-record-type '$make-record-type
-               (list* ?base-id ?parent ?name ?fields ?sealed ?opaque ?extras))]))
+            [(?base-id ?parent ?name ?fields ?sealed ?opaque ?alt-pm . ?extras)
+             (mrt ?parent ?name ?fields ?sealed ?opaque ?alt-pm ctxt level $make-record-type '$make-record-type
+               (list* ?base-id ?parent ?name ?fields ?sealed ?opaque ?alt-pm ?extras))]))
         (let ()
           (define (mrtd ?parent ?uid ?fields ?sealed ?opaque ctxt level prim primname opnd*)
             (or (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?uid))
diff --git a/s/cpcommonize.ss b/s/cpcommonize.ss
index 9cf63bed2..47856826e 100644
--- a/s/cpcommonize.ss
+++ b/s/cpcommonize.ss
@@ -200,9 +200,14 @@
                (nanopass-case (Ltype Type) ty2
                  [(fp-single-float) #t]
                  [else #f])]
-              [(fp-ftd ,ftd1)
+              [(fp-fptd ,fptd1)
                (nanopass-case (Ltype Type) ty2
-                 [(fp-ftd ,ftd2) (eq? ftd1 ftd2)]
+                 [(fp-fptd ,fptd2) (eq? fptd1 fptd2)]
+                 [else #f])]
+              [(fp-ftd& ,ftd1 ,fptd1)
+               (nanopass-case (Ltype Type) ty2
+                 [(fp-ftd& ,ftd2 ,fptd2) (and (eq? ftd1 ftd2)
+                                              (eq? fptd1 fptd2))]
                  [else #f])]
               [else (sorry! who "unhandled foreign type ~s" ty1)])))
         (define okay-to-subst?
diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss
index 45bc380bc..b774bb192 100644
--- a/s/cpnanopass.ss
+++ b/s/cpnanopass.ss
@@ -4476,6 +4476,13 @@
                                    (with-output-language (L13 Rhs)
                                      (%mref ,x ,%zero ,(constant flonum-data-disp) fp))
                                    x))))))
+                (define build-fptr-ref
+                  (lambda ()
+                    (let ([x (make-tmp 't)])
+                      `(seq
+                        (set! ,x ,t)
+                        ,(toC (in-context Rhs
+                                (%mref ,x ,(constant record-data-disp))))))))
                 (nanopass-case (Ltype Type) type
                   [(fp-scheme-object) (toC t)]
                   [(fp-fixnum) (toC (build-unfix t))]
@@ -4486,13 +4493,8 @@
                   [(fp-unsigned ,bits) (ptr->integer bits t toC)]
                   [(fp-double-float) (build-float)]
                   [(fp-single-float) (build-float)]
-                  [(fp-ftd ,ftd)
-                   (let ([x (make-tmp 't)])
-                     `(seq
-                        (set! ,x ,t)
-                        ,(toC (in-context Rhs
-                                (%mref ,x ,(constant record-data-disp))))))]
-                  [(fp-ftd& ,ftd)
+                  [(fp-fptd ,fptd) (build-fptr-ref)]
+                  [(fp-ftd& ,ftd ,fptd)
                    (let ([x (make-tmp 't)])
                      (%seq
                       (set! ,x ,t)
@@ -4503,7 +4505,7 @@
               (lambda (type toC t)
                 (nanopass-case (Ltype Type) type
                   [(fp-void) (toC)]
-                  [(fp-ftd& ,ftd)
+                  [(fp-ftd& ,ftd ,fptd)
                    ;; pointer isn't received as a result, but instead passed
                    ;; to the function as its first argument (or simulated as such)
                    (toC)]
@@ -4576,15 +4578,25 @@
                                          ,(e1 `(goto ,Lbig))
                                          (seq (label ,Lbig) ,e2)))))
                               (e1 e2))))))
-                (define (alloc-fptr ftd)
-                  (%seq
-                   (set! ,%xp
-                         ,(%constant-alloc type-typed-object (fx* (constant ptr-bytes) 2) #f))
-                   (set!
-                    ,(%mref ,%xp ,(constant record-type-disp))
-                    (literal ,(make-info-literal #f 'object ftd 0)))
-                   (set! ,(%mref ,%xp ,(constant record-data-disp)) ,%ac0)
-                   (set! ,lvalue ,%xp)))
+                (define (alloc-fptr fptd)
+                  (let ([object? ($fptd-object? fptd)])
+                    (let ([mk
+                           (%seq
+                            (set! ,%xp
+                                  ,(%constant-alloc type-typed-object (fx* (constant ptr-bytes) (if object? 3 2)) #f))
+                            (set! ,(%mref ,%xp ,(constant record-type-disp))
+                                  (literal ,(make-info-literal #f 'object fptd 0)))
+                            (set! ,(%mref ,%xp ,(constant record-data-disp)) ,%ac0)
+                            ,(if object?
+                                 `(set! ,(%mref ,%xp ,(fx+ (constant record-data-disp) (constant ptr-bytes)))
+                                        (immediate ,(constant reference-disp)))
+                                 `(nop))
+                            (set! ,lvalue ,%xp))])
+                      (if object?
+                          `(if ,(%inline eq? ,%ac0 (immediate 0))
+                               (set! ,lvalue (literal ,(make-info-literal #f 'object ($fptr-null-pointer) 0)))
+                               ,mk)
+                          mk))))
                 (define (receive-fp)
                   (if is-unboxed?
                       (fromC lvalue)
@@ -4632,14 +4644,14 @@
                       ,(unsigned->ptr bits lvalue))]
                   [(fp-double-float) (receive-fp)]
                   [(fp-single-float) (receive-fp)]
-                  [(fp-ftd ,ftd)
+                  [(fp-fptd ,fptd)
                    (%seq
                     ,(fromC %ac0) ; C integer return might be wiped out by alloc
-                    ,(alloc-fptr ftd))]
-                  [(fp-ftd& ,ftd)
+                    ,(alloc-fptr fptd))]
+                  [(fp-ftd& ,ftd ,fptd)
                    (%seq
                     ,(fromC %ac0)
-                    ,(alloc-fptr ftd))]
+                    ,(alloc-fptr fptd))]
                   [else ($oops who "invalid result type specifier ~s" type)]))))
           (define (pick-Scall result-type)
             (nanopass-case (Ltype Type) result-type
@@ -4673,7 +4685,7 @@
                                ,(let ([e (deallocate)])
                                   (if maybe-lvalue
                                       (nanopass-case (Ltype Type) result-type
-                                        [(fp-ftd& ,ftd)
+                                        [(fp-ftd& ,ftd ,fptd)
                                          ;; Don't actually return a value, because the result
                                          ;; was instead installed in the first argument.
                                          `(seq (set! ,maybe-lvalue ,(%constant svoid)) ,e)]
diff --git a/s/cpprim.ss b/s/cpprim.ss
index 248367f1c..b80101b39 100644
--- a/s/cpprim.ss
+++ b/s/cpprim.ss
@@ -5413,13 +5413,34 @@
                 (set! ,(%mref ,t ,(constant record-data-disp))
                   ,(ptr->integer e-addr (constant ptr-bits)))
                 ,t)))])])
+    (define-inline 3 $make-object-fptr
+      [(e-ftype e-obj e-offset)
+       (bind #f (e-ftype e-obj e-offset)
+         (let ([offset (make-assigned-tmp 'offset 'uptr)])
+           `(let ([,offset ,(%inline + ,(ptr->integer e-offset (constant ptr-bits))
+                                     (immediate ,(constant reference-disp)))])
+              ,(bind #t ([t (%constant-alloc type-typed-object (fx* 3 (constant ptr-bytes)))])
+                 (%seq
+                  (set! ,(%mref ,t ,(constant record-type-disp)) ,e-ftype)
+                  (set! ,(%mref ,t ,(constant record-data-disp)) ,(%inline + ,e-obj ,offset))
+                  (set! ,(%mref ,t ,(fx+ (constant record-data-disp) (constant ptr-bytes))) ,offset)
+                  ,t)))))])
     (define-inline 3 ftype-pointer-address
       [(e-fptr)
-       (build-object-ref #f
-         (constant-case ptr-bits
-           [(64) 'unsigned-64]
-           [(32) 'unsigned-32])
-         e-fptr %zero (constant record-data-disp))])
+       (build-object-ref #f ptr-type e-fptr %zero (constant record-data-disp))])
+    (define-inline 3 ftype-scheme-object-pointer-object
+      [(e-fptr)
+       (bind #t (e-fptr)
+         (%inline -
+                  ,(%mref ,e-fptr ,(constant record-data-disp))
+                  ,(%mref ,e-fptr ,(fx+ (constant record-data-disp)
+                                        (constant ptr-bytes)))))])
+    (define-inline 3 ftype-scheme-object-pointer-offset
+      [(e-fptr)
+       (unsigned->ptr (%inline -
+                               ,(%mref ,e-fptr ,(fx+ (constant record-data-disp) (constant ptr-bytes)))
+                               (immediate ,(constant reference-disp)))
+                      (constant ptr-bits))])
     (define-inline 3 ftype-pointer-null?
       [(e-fptr) (make-ftype-pointer-null? e-fptr)])
     (define-inline 3 ftype-pointer=?
@@ -5495,10 +5516,10 @@
              (build-$record e-ftd
                (list (build-fx+raw e-offset ($extract-fptr-address e-fptr)))))]))
       (define-inline 3 $fptr-fptr-ref
-        [(e-fptr e-offset e-ftd)
+        [(e-fptr e-offset e-fptrtd)
          (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)])
            (bind #f (e-index)
-             (build-$record e-ftd
+             (build-$record e-fptrtd
                (list `(inline ,(make-info-load ptr-type #f) ,%load
                         ,($extract-fptr-address e-fptr)
                         ,e-index (immediate ,imm-offset))))))])
@@ -5509,6 +5530,18 @@
              `(inline ,(make-info-load ptr-type #f) ,%store ,e-addr ,e-index (immediate ,imm-offset)
                 (inline ,(make-info-load ptr-type #f) ,%load ,e-val ,%zero
                   ,(%constant record-data-disp)))))])
+      (define-inline 3 $fptr-object-fptr-ref
+        [(e-fptr e-offset e-fptrtd)
+         (let-values ([(e-index imm-offset) (offset-expr->index+offset e-offset)])
+           (bind #f (e-index)
+             (bind #t ([val `(inline ,(make-info-load ptr-type #f) ,%load
+                               ,($extract-fptr-address e-fptr)
+                               ,e-index (immediate ,imm-offset))])
+               `(if ,(%inline eq? ,val (immediate 0))
+                    (literal ,(make-info-literal #f 'object ($fptr-null-pointer) 0))
+                    ,(build-$record e-fptrtd
+                       (list val
+                             `(immediate ,(constant reference-disp))))))))])
       (let ()
         (define $do-fptr-ref-inline
           (lambda (swapped? type e-fptr e-offset)
@@ -7678,7 +7711,7 @@
                            ,(%seq
                              (set! ,(%mref ,t-vec ,(constant stencil-vector-type-disp))
                                    ,(build-stencil-vector-type e-mask type))
-                             ;; Content not filled! This function is meant to be called by
+                             ;; Content not filled! This function is meant to be cal<led by
                              ;; `[$]$stencil-vector-do-update`, which has GC disabled between
                              ;; allocation and filling in the data
                              ,t-vec)))))))
diff --git a/s/cprep.ss b/s/cprep.ss
index 1917a20d2..dcfdbb6c9 100644
--- a/s/cprep.ss
+++ b/s/cprep.ss
@@ -120,8 +120,8 @@
                [(fp-fixnum) 'fixnum]
                [(fp-double-float) 'double-float]
                [(fp-single-float) 'single-float]
-               [(fp-ftd ,ftd) 'ftype]
-               [(fp-ftd& ,ftd) 'ftype])))
+               [(fp-fptd ,fptd) 'ftype]
+               [(fp-ftd& ,ftd ,fptd) 'ftype])))
          (define uncprep
            (lambda (x)
              (define keyword?
diff --git a/s/enum.ss b/s/enum.ss
index b5384ad21..46a04af05 100644
--- a/s/enum.ss
+++ b/s/enum.ss
@@ -176,6 +176,7 @@ an-enum-set:
                      '() ; no fields to add
                      #t ; sealed
                      #f ; not opaque
+                     #f ; no alt-pm
                      sym->index
                      index->sym)])
               (make-enum-set this-enum-rtd members-universe)))))))
diff --git a/s/ftype.ss b/s/ftype.ss
index dbbc83192..461d7f350 100644
--- a/s/ftype.ss
+++ b/s/ftype.ss
@@ -115,7 +115,7 @@ notes:
     big-endian machines, the first field occupies the high-order bits,
     with each subsequent field just below the preceding field.
 
-  - ftyp<e pointers are records encapsulating an ftype descriptor
+  - ftype pointers are records encapsulating an ftype descriptor
     (ftd) along with the address of the foreign object, except that
     pointers of type void* are just addresses.  the encapsulated
     ftd is used to verify the applicability of an ftype-&ref,
@@ -160,6 +160,17 @@ ftype operators:
 
    returns the address encapsulated within fptr.
 
+(make-ftype-scheme-object-pointer obj offset) [syntax]
+(ftype-scheme-object-pointer? expr) [syntax]
+(ftype-scheme-object-pointer-object fptr) [procedure]
+(ftype-scheme-object-pointer-offset fptr) [procedure]
+
+   for referencing a Scheme object, especially a bytevector or
+   flvector as a foreign-compatible pointer.  a scheme-object
+   pointer works as a ftype pointer, and as long as the address
+   is extracted only at the last moment, the GC keeps the address
+   up-to-date if the bytevector or flvector moves.
+
 (ftype-pointer-null? fptr) [procedure]
 
    returns #t if the address encapsulated within fptr is 0,
@@ -224,28 +235,65 @@ ftype operators:
 (begin
 (let ()
   (include "types.ss")
+  (define-syntax get-rtd/fptr
+    (let* ([rtd
+            ;; parent rtd for any object that holds a foreign pointer;
+            ;; used directly to construct `(* void)` pointers
+            ($make-record-type #!base-rtd #f
+               '#{ftype-pointer a9pth58056u34h517jsrqv-0}
+               '((immutable uptr address))
+               #f
+               #f
+               #f)]
+           [rtd/object
+            ;; sub-rtd for an object where the pointer is based on a GCable
+            ;; object like a bytevector; requires GC cooperation that is
+            ;; triggered by the `#t` alt-pm protocol (last argument below)
+            ($make-record-type #!base-rtd rtd
+               '#{ftype-scheme-object-pointer a9pth58056u34h517jsrqv-22}
+               '((immutable uptr offset))
+               #t
+               #f
+               #t)])
+      (make-compile-time-value
+       (lambda (which)
+         (case which
+           [(base) rtd]
+           [(object) rtd/object]
+           [_ ($oops 'get-rtd/fptr "unrecognized ~s" which)])))))
   (define-syntax rtd/fptr
-    (let ([rtd ($make-record-type #!base-rtd #f
-                 '#{ftype-pointer a9pth58056u34h517jsrqv-0}
-                 '((immutable uptr address))
-                 #f
-                 #f)])
-      (lambda (x) #`'#,rtd)))
+    (lambda (x) (lambda (r) #`'#,((r #'get-rtd/fptr) 'base))))
+  (define-syntax rtd/object-fptr
+    (lambda (x) (lambda (r) #`'#,((r #'get-rtd/fptr) 'object))))
   (define $fptr? (record-predicate rtd/fptr))
+  (define $object-fptr? (record-predicate rtd/object-fptr))
+  (define $code-fptr? (record-predicate rtd/object-fptr))
   (define $ftype-pointer-address (record-accessor rtd/fptr 0))
+  (define $ftype-scheme-object-pointer-offset (record-accessor rtd/object-fptr 0))
   (define-syntax rtd/ftd
+    ;; parent rtd for a record that describes a foreign-type shape,
+    ;; and where that record is itself a sub-rtd of `rtd/fptr` to
+    ;; represent pointers to values matching the foreign type
     (let ([rtd ($make-record-type #!base-rtd #!base-rtd
                  '#{rtd/ftd a9pth58056u34h517jsrqv-1}
                  '((immutable ptr stype)
                    (immutable ptr size)
                    (immutable ptr alignment))
                  #f
+                 #f
                  #f)])
       (lambda (x) #`'#,rtd)))
   (define ftd? (record-predicate rtd/ftd))
   (define ftd-stype (record-accessor rtd/ftd 0))
   (define ftd-size (record-accessor rtd/ftd 1))
   (define ftd-alignment (record-accessor rtd/ftd 2))
+  (define fptd? (lambda (x)
+                  ;; rtds that make sense in `ftd-pointer` instances
+                  ;; and as foreign function arguments/results; that is,
+                  ;; either a pointer to a known foreign type or a
+                  ;; generic pointer
+                  (or (ftd? x) (eq? x rtd/fptr) (eq? x rtd/object-fptr))))
+  (define fptd-object? (lambda (x) (eq? x rtd/object-fptr)))
   (define-syntax define-ftd-record-type
     (lambda (x)
       (define construct-name
@@ -298,14 +346,15 @@ ftype operators:
            #`(begin
                (define-syntax rtd
                  (let ([rtd ($make-record-type #!base-rtd rtd/ftd
-                              '?uid
-                              '(field ...)
-                              #t
-                              #f)])
+                               '?uid
+                               '(field ...)
+                               #t
+                               #f
+                               #f)])
                    (lambda (x) #`'#,rtd)))
                (define constructor-name
                  (lambda (parent uid stype size alignment field-name ...)
-                   ($make-record-type rtd parent (or uid #,(symbol->string (datum record-name))) '() #f #f stype size alignment field-name ...)))
+                   ($make-record-type rtd parent (or uid #,(symbol->string (datum record-name))) '() #f #f #f stype size alignment field-name ...)))
                (define #,(construct-name #'record-name "ftd-" #'record-name "?")
                  (record-predicate rtd))
                #,@(ftd-accessors #'record-name #'(field ...))))])))
@@ -314,7 +363,7 @@ ftype operators:
   (define-ftd-record-type struct #{rtd/ftd-struct a9pth58056u34h517jsrqv-3} field*)
   (define-ftd-record-type union #{rtd/ftd-union a9pth58056u34h517jsrqv-4} field*)
   (define-ftd-record-type array #{rtd/ftd-array a9pth58056u34h517jsrqv-5} length ftd)
-  (define-ftd-record-type pointer #{rtd/ftd-pointer a9pth58056u34h517jsrqv-6} (mutable ftd))
+  (define-ftd-record-type pointer #{rtd/ftd-pointer a9pth58056u34h517jsrqv-35} (mutable fptd))
   (define-ftd-record-type bits #{rtd/ftd-ibits a9pth58056u34h517jsrqv-19} eness field*)
   (define-ftd-record-type function #{rtd/ftd-function a9pth58056u34h517jsrqv-11} conv* arg-type* result-type)
   (module (pointer-size alignment pointer-alignment native-base-ftds swap-base-ftds big-base-ftds little-base-ftds)
@@ -392,7 +441,11 @@ ftype operators:
          [(let ([maybe-ftd (r ftype)]) (and maybe-ftd (ftd? maybe-ftd) maybe-ftd)) => (lambda (ftd) ftd)]
          [(find (let ([x (syntax->datum ftype)])
                   (lambda (ftd) (eq? (ftd-base-type ftd) x)))
-            native-base-ftds)]
+                native-base-ftds)]
+         [(eq? (syntax->datum ftype) 'ftype-pointer)
+          (make-ftd-pointer rtd/fptr #f 'void pointer-size pointer-alignment rtd/fptr)]
+         [(eq? (syntax->datum ftype) 'ftype-scheme-object-pointer)
+          (make-ftd-pointer rtd/fptr #f 'void pointer-size pointer-alignment rtd/object-fptr)]
          [else (and error? (syntax-error ftype "unrecognized ftype name"))])]))
   (define expand-ftype
     (case-lambda
@@ -442,6 +495,10 @@ ftype operators:
                    [(find (let ([x (syntax->datum ftype)])
                             (lambda (ftd) (eq? (ftd-base-type ftd) x)))
                           (native-ftds))]
+                   [(eq? (syntax->datum ftype) 'ftype-pointer)
+                    (make-ftd-pointer rtd/fptr #f 'void pointer-size pointer-alignment rtd/fptr)]
+                   [(eq? (syntax->datum ftype) 'ftype-scheme-object-pointer)
+                    (make-ftd-pointer rtd/fptr #f 'void pointer-size pointer-alignment rtd/object-fptr)]
                    [else (syntax-error ftype "unrecognized ftype name")])
                  (syntax-case ftype ()
                    [(struct-kwd (field-name ftype) ...)
@@ -586,10 +643,11 @@ ftype operators:
   (define expand-fp-ftype
     (lambda (who what r ftype def-alist)
       (syntax-case ftype ()
-        [(*/&-kwd ftype-name)
+        [(*/&-kwd ftype-name . ptr-kind)
          (and (or (eq? (datum */&-kwd) '*)
                   (eq? (datum */&-kwd) '&))
-              (identifier? #'ftype-name))
+              (identifier? #'ftype-name)
+              (member (datum ptr-kind) '(() (ftype-pointer) (ftype-scheme-object-pointer))))
          (let* ([stype (syntax->datum ftype)]
                 [ftd
                  (cond
@@ -605,38 +663,51 @@ ftype operators:
                      (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment ftd))]
                   [else (syntax-error #'ftype-name (format "unrecognized ~s ~s ftype name" who what))])])
            ;; Scheme-side argument is a pointer to a value, but foreign side has two variants:
-           (if (eq? (datum */&-kwd) '&)
+           (if (eq? (datum */&-kwd) '*)
+               ;; plain ftd => pass/receive a pointer
+               ftd
+               ;; pair => pass/receive a value, as opposed to a pointer to the value
                (cond
-                [(ftd-array? (ftd-pointer-ftd ftd))
-                 (syntax-error ftype (format "array value invalid as ~a ~s" who what))]
-                [else
-                 (box ftd)]) ; boxed ftd => pass/receive the value (as opposed to a pointer to the value)
-               ftd))]    ; plain ftd => pass/receive a pointer to the value
-        [_ (cond
+                 [(ftd-array? (ftd-pointer-fptd ftd))
+                  (syntax-error ftype (format "array value invalid as ~a ~s" who what))]
+                 [(null? (datum ptr-kind))
+                  (cons ftd ftd)]
+                 [else
+                  (let ([rep-fptd (if (eq? (car (datum ptr-kind)) 'ftype-scheme-object-pointer)
+                                      rtd/object-fptr
+                                      rtd/fptr)])
+                    (cons ftd
+                          (make-ftd-pointer rtd/fptr #f 'void pointer-size pointer-alignment rep-fptd)))])))]
+      [_ (cond
              [(and (identifier? ftype) (expand-ftype-name r ftype #f)) =>
               (lambda (ftd)
-                (unless (ftd-base? ftd)
-                  (syntax-error ftype (format "invalid (non-base) ~s ~s ftype" who what)))
-                (unless (eq? (ftd-base-eness ftd) 'native)
-                  (syntax-error ftype (format "invalid (not native) ~s ~s ftype" who what)))
-                (ftd-base-type ftd))]
+                (cond
+                  [(ftd-pointer? ftd)
+                   ftd]
+                  [else
+                   (unless (ftd-base? ftd)
+                     (syntax-error ftype (format "invalid (non-base) ~s ~s ftype" who what)))
+                   (unless (eq? (ftd-base-eness ftd) 'native)
+                     (syntax-error ftype (format "invalid (not native) ~s ~s ftype" who what)))
+                   (ftd-base-type ftd)]))]
              [else (syntax->datum ftype)])])))
   (define-who indirect-ftd-pointer
     (lambda (x)
       (cond
        [(ftd? x)
         (if (ftd-pointer? x)
-            (ftd-pointer-ftd x)
+            (ftd-pointer-fptd x)
             ($oops who "~s is not an ftd-pointer" x))]
-       [(box? x)
-        (box (indirect-ftd-pointer (unbox x)))]
+       [(pair? x)
+        (cons (indirect-ftd-pointer (car x))
+              (indirect-ftd-pointer (cdr x)))]
        [else x])))
   (define-who expand-ftype-defns
     (lambda (r defid* ftype*)
       (define patch-pointer-ftds!
         (lambda (id ftd)
           (lambda (pointer-ftd)
-            (ftd-pointer-ftd-set! pointer-ftd ftd))))
+            (ftd-pointer-fptd-set! pointer-ftd ftd))))
       (let ([alist (map list defid*)])
         (for-each
           (lambda (defid ftype a)
@@ -677,15 +748,15 @@ ftype operators:
       (lambda (pargs->new)
         (lambda (type expr)
           ((pargs->new expr) type)))))
-  (define-record-type ftd-info
+  (define-record-type fptd-info
     (parent src-info)
-    (nongenerative #{ftd-info sls7d75lyfm0jejerbq3n-2})
+    (nongenerative #{fptd-info sls7d75lyfm0jejerbq3n-5})
     (sealed #t)
-    (fields who ftd)
+    (fields who fptd)
     (protocol
       (lambda (pargs->new)
-        (lambda (whoid expr ftd)
-          ((pargs->new expr) (syntax->datum whoid) ftd)))))
+        (lambda (whoid expr fptd)
+          ((pargs->new expr) (syntax->datum whoid) fptd)))))
   (define-record-type index-info
     (parent src-info)
     (nongenerative #{index-info sls7d75lyfm0jejerbq3n-3})
@@ -750,7 +821,16 @@ ftype operators:
       (fprintf p "#<ftd ~s>" (record-type-name x))))
   (record-writer rtd/fptr
     (lambda (x p wr)
-      (fprintf p "#<ftype-pointer ~s ~s>" (record-type-name (record-rtd x)) ($ftype-pointer-address x))))
+      (let ([fptd (record-rtd x)])
+        (if (eq? fptd rtd/fptr)
+            (fprintf p "#<ftype-pointer ~s>"
+                     ($ftype-pointer-address x))
+            (fprintf p "#<ftype-pointer ~s ~s>"
+                     (record-type-name fptd)
+                     ($ftype-pointer-address x))))))
+  (record-writer rtd/object-fptr
+    (lambda (x p wr)
+      (fprintf p "#<ftype-scheme-object-pointer ~s ~s>" (ftype-scheme-object-pointer-object x) (ftype-scheme-object-pointer-offset x))))
   (set! $verify-ftype-address
     (lambda (who addr)
       (define address?
@@ -764,8 +844,8 @@ ftype operators:
             ($oops who "invalid address ~s" addr)))))
   (set! $verify-ftype-pointer
     (lambda (info fptr)
-      (unless (record? fptr (ftd-info-ftd info))
-        ($source-violation (ftd-info-who info) (src-info-src info) #t
+      (unless (record? fptr (fptd-info-fptd info))
+        ($source-violation (fptd-info-who info) (src-info-src info) #t
           (if ($fptr? fptr)
               "ftype mismatch for ~s"
               "~s is not an ftype pointer")
@@ -826,16 +906,40 @@ ftype operators:
                          #'(let ([addr addr-expr])
                              ($verify-ftype-address 'make-ftype addr)
                              addr)))))]))))
+  (set! $trans-make-ftype-scheme-object-pointer
+    (lambda (x)
+      (define (build bv-e offset-e)
+        (let ([ftd rtd/object-fptr]
+              [level (if (fx= (optimize-level) 3) 3 2)])
+          #`(($primitive #,level $make-object-fptr) '#,ftd #,bv-e #,offset-e)))
+      (syntax-case x ()
+        [(_ ?bv)
+         (build #'?bv #'0)]
+        [(_ ?bv ?offset)
+         (build #'?bv #'?offset)])))
   (set! $trans-ftype-pointer?
     (lambda (x)
       (lambda (r)
         (syntax-case x ()
           [(_ x) #`(record? x '#,rtd/fptr)]
           [(_ ftype x) (identifier? #'ftype) #`(record? x '#,(expand-ftype-name r #'ftype))]))))
+  (set! $trans-ftype-scheme-object-pointer?
+    (lambda (x)
+      (lambda (r)
+        (syntax-case x ()
+          [(_ x) #`(record? x '#,rtd/object-fptr)]))))
   (set-who! ftype-pointer-address
     (lambda (fptr)
       (unless ($fptr? fptr) ($oops who "~s is not an ftype pointer" fptr))
-      ($ftype-pointer-address fptr)))
+      (#3%ftype-pointer-address fptr)))
+  (set-who! ftype-scheme-object-pointer-object
+    (lambda (fptr)
+      (unless ($object-fptr? fptr) ($oops who "~s is not an ftype scheme-object pointer" fptr))
+      (#3%ftype-scheme-object-pointer-object fptr)))
+  (set-who! ftype-scheme-object-pointer-offset
+    (lambda (fptr)
+      (unless ($object-fptr? fptr) ($oops who "~s is not an ftype scheme-object pointer" fptr))
+      (- ($ftype-scheme-object-pointer-offset fptr) (constant reference-disp))))
   (set-who! ftype-pointer-null?
     (lambda (fptr)
       (unless ($fptr? fptr) ($oops who "~s is not an ftype pointer" fptr))
@@ -848,7 +952,14 @@ ftype operators:
   (set-who! ftype-pointer-ftype
     (lambda (fptr)
       (unless ($fptr? fptr) ($oops who "~s is not an ftype pointer" fptr))
-      (ftd-stype (record-rtd fptr))))
+      (let ([fptd (record-rtd fptr)])
+        (cond
+          [($ftd? fptd)
+           (ftd-stype (record-rtd fptr))]
+          [(eq? fptd rtd/object-fptr)
+           'scheme-object]
+          [else
+           'void]))))
   (set-who! ftype-pointer->sexpr
     (lambda (fptr)
       (module (record replay)
@@ -881,6 +992,7 @@ ftype operators:
         (let fptr->sexpr ([fptr fptr])
           (record fptr
             (let f ([fptr fptr] [ftd (record-rtd fptr)] [offset 0])
+              ;; `ftd` is more generally a `fptd`
               (cond
                 [(ftd-struct? ftd)
                  `(struct
@@ -917,11 +1029,13 @@ ftype operators:
                                         (g (fx+ i 1))))))))]
                 [(ftd-pointer? ftd)
                  (cond
-                   [(guard (c [#t #f]) ($fptr-fptr-ref fptr offset (ftd-pointer-ftd ftd))) =>
+                   [(guard (c [#t #f]) (if ($fptd-object? (ftd-pointer-fptd ftd))
+                                           ($fptr-object-fptr-ref fptr offset (ftd-pointer-fptd ftd))
+                                           ($fptr-fptr-ref fptr offset (ftd-pointer-fptd ftd)))) =>
                     (lambda (fptr)
                       (if (zero? (ftype-pointer-address fptr))
                           'null
-                          (let ([ftd (ftd-pointer-ftd ftd)])
+                          (let ([ftd (ftd-pointer-fptd ftd)])
                             (if (and (ftd-base? ftd) (memq (ftd-base-type ftd) '(char wchar)))
                                 (let g ([i 0])
                                   (let ([c (f fptr ftd (* i (ftd-size ftd)))])
@@ -953,7 +1067,14 @@ ftype operators:
                  (guard (c [#t 'invalid])
                    ($fptr-ref (filter-foreign-type (ftd-base-type ftd))
                      (ftd-base-eness ftd) fptr offset))]
-                [else ($oops '$fptr->sexpr "unhandled ftd ~s" ftd)])))))))
+                [(eq? ftd rtd/object-fptr)
+                 (let ([offset (ftype-scheme-object-pointer-offset fptr)])
+                   (if (eqv? offset 0)
+                       (ftype-scheme-object-pointer-object fptr)
+                       `(offset ,(ftype-scheme-object-pointer-object fptr) ,offset)))]
+                [(eq? ftd rtd/fptr)
+                 `(address ,($ftype-pointer-address fptr))]
+                [else ($oops '$fptr->sexpr "unhandled fptd ~s" ftd)])))))))
   (set! $unwrap-ftype-pointer
     (lambda (fptr)
       (let f ([ftd (record-rtd fptr)])
@@ -977,10 +1098,12 @@ ftype operators:
                      (errorf '$dump-foreign-type "invalid index ~s for array of length ~s" i n))
                    ($fptr-&ref fptr (* i (ftd-size ftd)) ftd))))]
           [(ftd-pointer? ftd)
-           (let ([ftd (ftd-pointer-ftd ftd)])
-             `(* ,(lambda () ($fptr-fptr-ref fptr 0 ftd))
+           (let ([fptd (ftd-pointer-fptd ftd)])
+             `(* ,(lambda () (if ($fptd-object? fptd)
+                                 ($fptr-object-fptr-ref fptr 0 fptd)
+                                 ($fptr-fptr-ref fptr 0 fptd)))
                  ,(lambda (who v)
-                    ($verify-ftype-pointer (make-ftd-info who #f ftd) v)
+                    ($verify-ftype-pointer (make-fptd-info who #f fptd) v)
                     (#3%$fptr-fptr-set! fptr 0 v))))]
           [(ftd-function? ftd)
            (let ([addr (ftype-pointer-address fptr)])
@@ -1005,7 +1128,14 @@ ftype operators:
                 ,type
                 ,(lambda () (guard (c [#t 'invalid]) ($fptr-ref type (ftd-base-eness ftd) fptr 0)))
                 ,(lambda (v) (#2%$fptr-set! (ftd-base-type ftd) type (ftd-base-eness ftd) fptr 0 v))))]
-          [else ($oops '$unwrap-ftype-pointer "unhandled ftd ~s" ftd)]))))
+          [(eq? ftd rtd/object-fptr)
+           (let ([offset (ftype-scheme-object-pointer-offset fptr)])
+             (if (eqv? offset 0)
+                 (ftype-scheme-object-pointer-object fptr)
+                 `(offset ,(ftype-scheme-object-pointer-object fptr) ,offset)))]
+          [(eq? ftd rtd/fptr)
+           `(address ,($ftype-pointer-address fptr))]
+          [else ($oops '$unwrap-ftype-pointer "unhandled fptd ~s" ftd)]))))
   (set! $trans-ftype-sizeof
     (lambda (x)
       (lambda (r)
@@ -1019,6 +1149,12 @@ ftype operators:
   (set! $ftd?
     (lambda (x)
       (ftd? x)))
+  (set! $fptd?
+    (lambda (x)
+      (fptd? x)))
+  (set! $fptd-object?
+    (lambda (x)
+      (fptd-object? x)))
   (set! $ftd-size
     (lambda (ftd)
       (constant-case special-initial-field-alignment?
@@ -1039,9 +1175,9 @@ ftype operators:
            (if (fx= initial 8)
                (fxlogand (fx+ (ftd-size ftd) 7) (fxlognot 7))
                (ftd-size ftd)))])))
-  (set! $ftd-as-box? ; represents `(& <ftype>)` from `$expand-fp-ftype`
+  (set! $ftd-pair? ; represents `(& <ftype> [<kind>])` `$expand-fp-ftype`
     (lambda (x)
-      (and (box? x) (ftd? (unbox x)))))
+      (and (pair? x) (ftd? (car x)) ($fptd? (cdr x)))))
   (set! $ftd-alignment
     (lambda (x)
       (ftd-alignment x)))
@@ -1169,6 +1305,8 @@ ftype operators:
               (values fptr-expr offset ftd idx* #f)
               (let ([a (car a*)])
                 (cond
+                  [(not ($ftd? ftd))
+                   (syntax-error a "cannot access generic pointer content")]
                   [(ftd-struct? ftd)
                    (let ([s (syntax->datum a)])
                      (cond
@@ -1194,14 +1332,20 @@ ftype operators:
                              #`(#3%fx+ #,offset (#3%fx* #,a-id #,(ftd-size elt-ftd)))
                              (cons (list ftd a-id a len) idx*)))))]
                   [(ftd-pointer? ftd)
-                   (let ([elt-ftd (ftd-pointer-ftd ftd)])
-                     (let ([fptr-expr #`(#3%$fptr-fptr-ref #,fptr-expr #,offset '#,elt-ftd)])
+                   (let ([elt-fptd (ftd-pointer-fptd ftd)])
+                     (let ([fptr-expr (if (eq? elt-fptd rtd/object-fptr)
+                                          #`(#3%$fptr-object-fptr-ref #,fptr-expr #,offset '#,elt-fptd)
+                                          #`(#3%$fptr-fptr-ref #,fptr-expr #,offset '#,elt-fptd))])
                         (if (memv (syntax->datum a) '(* 0))
-                            (loop elt-ftd (cdr a*) fptr-expr 0 idx*)
+                            (if ($ftd? elt-fptd)
+                                (loop elt-fptd (cdr a*) fptr-expr 0 idx*)
+                                (syntax-error a "cannot dereference generic pointer"))
                             (let ([a-id (car (generate-temporaries (list #'i)))])
-                              (loop elt-ftd (cdr a*) fptr-expr
-                                (trans-idx a-id a elt-ftd (make-index-info whoid a ftd #f))
-                                (cons (list ftd a-id a #f) idx*))))))]
+                              (if (or ($ftd? elt-fptd) (null? (cdr a*)))
+                                  (loop elt-fptd (cdr a*) fptr-expr
+                                    (trans-idx a-id a #f elt-fptd (make-index-info whoid a ftd #f))
+                                    (cons (list ftd a-id a #f) idx*))
+                                (syntax-error a "cannot dereference generic pointer"))))))]
                   [(ftd-bits? ftd)
                    (let ([s (syntax->datum a)])
                      (cond
@@ -1254,21 +1398,24 @@ ftype operators:
                         [else #f]))
                  (do-bits (ftd-size ftd) offset start end))]))))
     (define trans-idx
-      (lambda (?idx ?orig-idx ftd info)
-        (if (memv (syntax->datum ?idx) '(* 0))
-            0
-            (if (ftd-function? ftd)
-                (syntax-error ?orig-idx "cannot calculate offset for function index")
-                (let ([size (ftd-size ftd)])
-                  (if (fx= (optimize-level) 3)
-                      #`(#3%fx* #,size #,?idx)
-                      #`(let ([idx #,?idx])
-                          (or (and (fixnum? idx)
-                                   (let ([offset (* #,size idx)])
-                                     (and (fixnum? offset)
-                                          (fixnum? (+ offset #,(fx- size 1)))
-                                          offset)))
-                              ($invalid-ftype-index '#,info idx)))))))))
+      (lambda (?idx ?orig-idx any? ftd info)
+        (cond
+          [(memv (syntax->datum ?idx) '(* 0))
+           0]
+          [any? ?idx]
+          [(ftd-function? ftd)
+           (syntax-error ?orig-idx "cannot calculate offset for function index")]
+          [else
+           (let ([size (ftd-size ftd)])
+             (if (fx= (optimize-level) 3)
+                 #`(#3%fx* #,size #,?idx)
+                 #`(let ([idx #,?idx])
+                     (or (and (fixnum? idx)
+                              (let ([offset (* #,size idx)])
+                                (and (fixnum? offset)
+                                     (fixnum? (+ offset #,(fx- size 1)))
+                                     offset)))
+                         ($invalid-ftype-index '#,info idx)))))])))
     (set! $trans-ftype-&ref
       (lambda (q)
         (define trans
@@ -1278,11 +1425,11 @@ ftype operators:
                (let ([fptr-expr (if (fx= (optimize-level) 3)
                                     fptr-expr
                                     #`(let ([fptr #,fptr-expr])
-                                        ($verify-ftype-pointer '#,(make-ftd-info 'ftype-&ref fptr-expr ftd) fptr)
+                                        ($verify-ftype-pointer '#,(make-fptd-info 'ftype-&ref fptr-expr ftd) fptr)
                                         fptr))])
                  (if (and (null? a*) (memv (syntax->datum ?idx) '(* 0)))
                      fptr-expr
-                     #`(let ([offset #,(trans-idx ?idx ?idx ftd (make-index-info #'ftype-&ref ?idx ftd #t))])
+                     #`(let ([offset #,(trans-idx ?idx ?idx #f ftd (make-index-info #'ftype-&ref ?idx ftd #t))])
                          #,(let-values ([(fptr-expr offset ftd idx* bitfield)
                                          (ftype-access-code #'ftype-&ref ftd a* fptr-expr #'offset)])
                              (when bitfield (syntax-error q "cannot take address of bit field"))
@@ -1302,17 +1449,18 @@ ftype operators:
            (identifier? #'ftype)
            (trans #'ftype #'(a ...) #'fptr-expr #'?idx)])))
     (set! $trans-ftype-ref
-      (lambda (q)
+      (lambda (q any?)
         (define trans
           (lambda (ftype a* fptr-expr ?idx)
             (lambda (r)
               (let ([ftd (expand-ftype-name r ftype)])
                 (let ([fptr-expr (if (fx= (optimize-level) 3)
                                      fptr-expr
-                                     #`(let ([fptr #,fptr-expr])
-                                         ($verify-ftype-pointer '#,(make-ftd-info 'ftype-ref fptr-expr ftd) fptr)
-                                         fptr))])
-                  #`(let ([offset #,(trans-idx ?idx ?idx ftd (make-index-info #'ftype-ref ?idx ftd #t))])
+                                     (let ([ftd (if any? rtd/fptr ftd)])
+                                       #`(let ([fptr #,fptr-expr])
+                                           ($verify-ftype-pointer '#,(make-fptd-info 'ftype-ref fptr-expr ftd) fptr)
+                                           fptr)))])
+                  #`(let ([offset #,(trans-idx ?idx ?idx any? ftd (make-index-info #'ftype-ref ?idx ftd #t))])
                       #,(let-values ([(fptr-expr offset ftd idx* bitfield)
                                       (ftype-access-code #'ftype-ref ftd a* fptr-expr #'offset)])
                           (define (do-base type eness offset)
@@ -1357,7 +1505,10 @@ ftype operators:
                                                        #`(#3%$fptr-ref-bits 'type 'eness '#,signed? #,fptr-expr #,offset #,start #,end))])))))
                                           bitfield)]
                                       [(ftd-base? ftd) (do-base (filter-foreign-type (ftd-base-type ftd)) (ftd-base-eness ftd) offset)]
-                                      [(ftd-pointer? ftd) #`(#3%$fptr-fptr-ref #,fptr-expr #,offset '#,(ftd-pointer-ftd ftd))]
+                                      [(ftd-pointer? ftd)
+                                       (if (eq? (ftd-pointer-fptd ftd) rtd/object-fptr)
+                                           #`(#3%$fptr-object-fptr-ref #,fptr-expr #,offset '#,(ftd-pointer-fptd ftd))
+                                           #`(#3%$fptr-fptr-ref #,fptr-expr #,offset '#,(ftd-pointer-fptd ftd)))]
                                       [(ftd-function? ftd) 
                                        ($make-foreign-procedure 'make-ftype-pointer
                                          (ftd-function-conv* ftd)
@@ -1374,17 +1525,18 @@ ftype operators:
            (identifier? #'ftype)
            (trans #'ftype #'(a ...) #'fptr-expr #'?idx)])))
     (set! $trans-ftype-set!
-      (lambda (q)
+      (lambda (q any?)
         (define trans
           (lambda (ftype a* fptr-expr ?idx val-expr)
             (lambda (r)
               (let ([ftd (expand-ftype-name r ftype)])
                 (let ([fptr-expr (if (fx= (optimize-level) 3)
                                      fptr-expr
-                                     #`(let ([fptr #,fptr-expr])
-                                         ($verify-ftype-pointer '#,(make-ftd-info 'ftype-set! fptr-expr ftd) fptr)
-                                         fptr))])
-                  #`(let ([offset #,(trans-idx ?idx ?idx ftd (make-index-info #'ftype-set! ?idx ftd #t))] [val #,val-expr])
+                                     (let ([ftd (if any? rtd/fptr ftd)])
+                                       #`(let ([fptr #,fptr-expr])
+                                           ($verify-ftype-pointer '#,(make-fptd-info 'ftype-set! fptr-expr ftd) fptr)
+                                           fptr)))])
+                  #`(let ([offset #,(trans-idx ?idx ?idx any? ftd (make-index-info #'ftype-set! ?idx ftd #t))] [val #,val-expr])
                       #,(let-values ([(fptr-expr offset ftd idx* bitfield)
                                       (ftype-access-code #'ftype-set! ftd a* fptr-expr #'offset)])
                           (define (do-base orig-type)
@@ -1434,7 +1586,7 @@ ftype operators:
                                       [(ftd-pointer? ftd)
                                        #`(begin
                                            (unless #,(fx= (optimize-level) 3)
-                                             ($verify-ftype-pointer '#,(make-ftd-info 'ftype-set! val-expr (ftd-pointer-ftd ftd)) val))
+                                             ($verify-ftype-pointer '#,(make-fptd-info 'ftype-set! val-expr (ftd-pointer-fptd ftd)) val))
                                            (#3%$fptr-fptr-set! #,fptr-expr #,offset val))]
                                       [else (syntax-error q "non-scalar value cannot be assigned")])))))))))))
         (syntax-case q ()
@@ -1453,9 +1605,9 @@ ftype operators:
                 (let ([fptr-expr (if (fx= (optimize-level) 3)
                                      fptr-expr
                                      #`(let ([fptr #,fptr-expr])
-                                         ($verify-ftype-pointer '#,(make-ftd-info who fptr-expr ftd) fptr)
+                                         ($verify-ftype-pointer '#,(make-fptd-info who fptr-expr ftd) fptr)
                                          fptr))])
-                  #`(let ([offset #,(trans-idx ?idx ?idx ftd (make-index-info who ?idx ftd #t))])
+                  #`(let ([offset #,(trans-idx ?idx ?idx #f ftd (make-index-info who ?idx ftd #t))])
                       #,(let-values ([(fptr-expr offset ftd idx* bitfield)
                                       (ftype-access-code who ftd a* fptr-expr #'offset)])
                           (with-syntax ([((containing-ftd a-id a len) ...) idx*])
@@ -1515,6 +1667,15 @@ ftype operators:
   (set! $make-fptr
     (lambda (ftd addr)
       (#2%$make-fptr ftd addr)))
+  (set! $make-object-fptr
+    (lambda (ftd bv offset)
+      (unless (constant-case address-bits
+                [(32) ($integer-32? offset)]
+                [(64) ($integer-64? offset)])
+        ($oops 'make-ftype-scheme-object-pointer "invalid offset ~s" offset))
+      (#3%$make-object-fptr ftd bv offset)))
+  (set! $fptr-null-pointer
+    (lambda () ($record rtd/fptr 0)))
   (set! $fptr-offset-addr
     (lambda (fptr offset)
       (#3%$fptr-offset-addr fptr offset)))
@@ -1522,8 +1683,11 @@ ftype operators:
     (lambda (fptr offset ftd)
       (#3%$fptr-&ref fptr offset ftd)))
   (set! $fptr-fptr-ref
-    (lambda (fptr offset ftd)
-      (#3%$fptr-fptr-ref fptr offset ftd)))
+    (lambda (fptr offset fptd)
+      (#3%$fptr-fptr-ref fptr offset fptd)))
+  (set! $fptr-object-fptr-ref
+    (lambda (fptr offset fptd)
+      (#3%$fptr-object-fptr-ref fptr offset fptd)))
 
   (set! $fptr-ref-integer-8
     (lambda (fptr offset)
@@ -2209,20 +2373,24 @@ ftype operators:
   (set! $fptr-unlock!
     (lambda (fptr offset)
       (#3%$fptr-unlock! fptr offset)))
-)
+  )
 
 (define-syntax define-ftype (lambda (x) ($trans-define-ftype x)))
 (define-syntax make-ftype-pointer (lambda (x) ($trans-make-ftype-pointer x)))
+(define-syntax make-ftype-scheme-object-pointer (lambda (x) ($trans-make-ftype-scheme-object-pointer x)))
 (define-syntax ftype-pointer? (lambda (x) ($trans-ftype-pointer? x)))
+(define-syntax ftype-scheme-object-pointer? (lambda (x) ($trans-ftype-scheme-object-pointer? x)))
 (define-syntax ftype-sizeof (lambda (x) ($trans-ftype-sizeof x)))
 (define-syntax ftype-guardian (lambda (x) ($trans-ftype-guardian x)))
 (define-syntax ftype-&ref (lambda (x) ($trans-ftype-&ref x)))
-(define-syntax ftype-ref (lambda (x) ($trans-ftype-ref x)))
+(define-syntax ftype-ref (lambda (x) ($trans-ftype-ref x #f)))
+(define-syntax ftype-any-ref (lambda (x) ($trans-ftype-ref x #t)))
 (define-syntax ftype-locked-incr! (lambda (x) ($trans-ftype-locked-op! #'ftype-locked-incr! x #'$fptr-locked-incr!)))
 (define-syntax ftype-locked-decr! (lambda (x) ($trans-ftype-locked-op! #'ftype-locked-decr! x #'$fptr-locked-decr!)))
 (define-syntax ftype-init-lock! (lambda (x) ($trans-ftype-locked-op! #'ftype-init-lock! x #'$fptr-init-lock!)))
 (define-syntax ftype-lock! (lambda (x) ($trans-ftype-locked-op! #'ftype-lock! x #'$fptr-lock!)))
 (define-syntax ftype-spin-lock! (lambda (x) ($trans-ftype-locked-op! #'ftype-spin-lock! x #'$fptr-spin-lock!)))
 (define-syntax ftype-unlock! (lambda (x) ($trans-ftype-locked-op! #'ftype-unlock! x #'$fptr-unlock!)))
-(define-syntax ftype-set! (lambda (x) ($trans-ftype-set! x)))
+(define-syntax ftype-set! (lambda (x) ($trans-ftype-set! x #f)))
+(define-syntax ftype-any-set! (lambda (x) ($trans-ftype-set! x #t)))
 )
diff --git a/s/loongarch64.ss b/s/loongarch64.ss
index f81859180..ab2c8c7e4 100644
--- a/s/loongarch64.ss
+++ b/s/loongarch64.ss
@@ -1840,7 +1840,7 @@
                 (nanopass-case (Ltype Type) (car types)
                                [(fp-double-float) (fp-arg)]
                                [(fp-single-float) (fp-arg)]
-                               [(fp-ftd& ,ftd)
+                               [(fp-ftd& ,ftd ,fptd)
                                 ;; A non-union with one floating-point member is treated
                                 ;;  like that member by itself.
                                 ;; A non-union that has exactly two members, at least one as
@@ -1942,7 +1942,7 @@
 
     (define (result-via-pointer-argument? type)
       (nanopass-case (Ltype Type) type
-                     [(fp-ftd& ,ftd) (> ($ftd-size ftd) 16)]
+                     [(fp-ftd& ,ftd ,fptd) (> ($ftd-size ftd) 16)]
                      [else #f]))
 
     ;; result only meaningful if not `(result-via-pointer-argument? type)`
@@ -2107,7 +2107,7 @@
                                                                     [(int) (use-int-reg (load-single-into-int-reg reg))]
                                                                     [else (use-stack (load-single-stack isp))])]
                                                                  ;; need to move the aggregate data into regs or onto the stack
-                                                                 [(fp-ftd& ,ftd)
+                                                                 [(fp-ftd& ,ftd ,fptd)
                                                                   (case (cat-place cat)
                                                                     [(fp)
                                                                      ;; must be 1 register
@@ -2226,7 +2226,7 @@
                                        [arg-type* (info-foreign-arg-type* info)]
                                        [result-type (info-foreign-result-type info)]
                                        [ftd-result? (nanopass-case (Ltype Type) result-type
-                                                                   [(fp-ftd& ,ftd) #t]
+                                                                   [(fp-ftd& ,ftd ,fptd) #t]
                                                                    [else #f])]
                                        [pass-result-ptr? (result-via-pointer-argument? result-type)]
                                        [arg-type* (if (and ftd-result?
@@ -2387,7 +2387,7 @@
                                                           (case (cat-place cat)
                                                             [(fp int) (use-reg (load-single-stack reg-offset))]
                                                             [else (use-stack (load-single-stack stack-arg-offset))])]
-                                                         [(fp-ftd& ,ftd)
+                                                         [(fp-ftd& ,ftd ,fptd)
                                                           (cond
                                                            [(cat-by-reference cat)
                                                             ;; register or stack contains pointer to data; we
@@ -2454,7 +2454,7 @@
                                                              ,(%inline double->single ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp))))]
                                                    [(fp-void)
                                                     (lambda () `(nop))]
-                                                   [(fp-ftd& ,ftd)
+                                                   [(fp-ftd& ,ftd ,fptd)
                                                     (cond
                                                      [(not synthesize-first?)
                                                       ;; we passed the pointer to be filled, so nothing more to do here
@@ -2508,7 +2508,7 @@
                                                             '()
                                                             (cat-regs result-cat))]
                                            [ftd-result? (nanopass-case (Ltype Type) result-type
-                                                                       [(fp-ftd& ,ftd) #t]
+                                                                       [(fp-ftd& ,ftd ,fptd) #t]
                                                                        [else #f])]
                                            ;;@ size < 16, not passed as ptr, need to synthesize the result in return register(s)
                                            [synthesize-first? (and ftd-result?
diff --git a/s/mkgc.ss b/s/mkgc.ss
index 2a2b44f68..4445a644a 100644
--- a/s/mkgc.ss
+++ b/s/mkgc.ss
@@ -839,6 +839,12 @@
                  (trace (* pp)))
                (set! mask >>= 1)
                (set! pp += 1))]))]
+        [(== num #t)
+         ;; special protocol for an object created by `make-object-ftype-pointer`
+         (define offset : uptr (cast uptr (* (+ pp  1))))
+         (define obj : ptr (TO_PTR (- (cast uptr (* pp)) offset)))
+         (trace (just obj))
+         (set! (* pp) (TO_PTR (+ (cast uptr obj) offset)))]
         [else
          (case-flag as-dirty?
           [on]
diff --git a/s/pb.ss b/s/pb.ss
index 83a136d45..098bdb58a 100644
--- a/s/pb.ss
+++ b/s/pb.ss
@@ -1595,7 +1595,7 @@
 
     (define (is-result-as-arg? info)
       (nanopass-case (Ltype Type) (info-foreign-result-type info)
-        [(fp-ftd& ,ftd) #t]
+        [(fp-ftd& ,ftd ,fptd) #t]
         [else #f]))
 
     (define (adjust-active? info)
@@ -1715,7 +1715,7 @@
                                    locs)
                              (cons (constant ffi-typerep-float) encs)
                              (fx+ off 8))]
-                      [(fp-ftd& ,ftd)
+                      [(fp-ftd& ,ftd ,fptd)
                        (loop types
                              (cons (if in?
                                        (load-int off)
@@ -1803,7 +1803,7 @@
                                      (cons (load-double-reg (car fp*)) locs)
                                      (cons (car fp*) live*)
                                      int* (cdr fp*))]
-                              [(fp-ftd& ,ftd)
+                              [(fp-ftd& ,ftd ,fptd)
                                (sorry! who "indirect arguments not supported")]
                               [else
                                (when (null? int*) (sorry! who "too many integer/pointer arguments: ~s" (length in-types)))
@@ -1830,7 +1830,7 @@
                        (values (lambda (lvalue) ; unboxed
                                  `(set! ,lvalue ,(%inline single->double ,%Cfpretval)))
                                (list %Cfpretval))]
-                      [(fp-ftd& ,ftd)
+                      [(fp-ftd& ,ftd ,fptd)
                        (sorry! who "unhandled result type ~s" type)]
                       [else
                        (when (64-bit-type-on-32-bit? type)
@@ -1871,7 +1871,7 @@
                                      [(fp-scheme-object) 'uptr]
                                      [(fp-fixnum) 'uptr]
                                      [(fp-u8*) 'void*]
-                                     [(fp-ftd ,ftd) 'void*]
+                                     [(fp-fptd ,fptd) 'void*]
                                      [(fp-void) 'void]
                                      [else (if (eq? (subset-mode) 'system)
                                                (sorry! who "unhandled type in prototype ~s" type)
diff --git a/s/ppc32.ss b/s/ppc32.ss
index a1de9bf11..0ee95aafa 100644
--- a/s/ppc32.ss
+++ b/s/ppc32.ss
@@ -2185,17 +2185,17 @@
     (define fp-result-regs (lambda () (list %Cfpretval)))
     (define (indirect-result-that-fits-in-registers? result-type)
       (nanopass-case (Ltype Type) result-type
-        [(fp-ftd& ,ftd) (not ($ftd-compound? ftd))]
+        [(fp-ftd& ,ftd ,fptd) (not ($ftd-compound? ftd))]
         [else #f]))
     (define (indirect-result-to-pointer result-type arg-type*)
       (constant-case machine-type-name
         [(ppc32osx tppc32osx)
          (nanopass-case (Ltype Type) result-type
-           [(fp-ftd& ,ftd) (if ($ftd-compound? ftd)
-                               (cons (with-output-language (Ltype Type)
-                                       `(fp-integer 32))
-                                     (cdr arg-type*))
-                               arg-type*)]
+           [(fp-ftd& ,ftd ,fptd) (if ($ftd-compound? ftd)
+                                     (cons (with-output-language (Ltype Type)
+                                             `(fp-integer 32))
+                                           (cdr arg-type*))
+                                     arg-type*)]
            [else arg-type*])]
         [else arg-type*]))
 
@@ -2520,7 +2520,7 @@
                                 (cons (load-single-reg+int-regs (car flt*) (car int*) (cadr int*) isp indirect?) locs)
                                 (cons* (car int*) (cadr int*) live*) (cdr (cdr int*)) (cdr flt*) (fx+ isp 8) (fx+ fp-live-count 1)
                                 #f)])]
-                       [(fp-ftd& ,ftd)
+                       [(fp-ftd& ,ftd ,fptd)
                         (let ([members ($ftd->members ftd)])
                           (cond
                            [(or (not (and (pair? members)
@@ -2680,7 +2680,7 @@
                                       (cons (load-single-reg (car flt*) fp-disp) locs)
                                       live* int* (cdr flt*) isp (fx+ fp-live-count 1)
                                       #f)))]
-                       [(fp-ftd& ,ftd)
+                       [(fp-ftd& ,ftd ,fptd)
                         (cond
                           [($ftd-compound? ftd)
                            ;; pass as pointer
@@ -2780,7 +2780,7 @@
                   [(fp-single-float) (handle-32-bit)]
                   [(fp-integer ,bits) (handle-integer-cases bits)]
                   [(fp-integer ,bits) (handle-integer-cases bits)]
-                  [(fp-ftd& ,ftd) (handle-ftd&-case ftd)]
+                  [(fp-ftd& ,ftd ,fptd) (handle-ftd&-case ftd)]
                   [else (values (reg-list %Cretval) 0 (lambda (e) e))]))
               (let ()
                 (define handle-integer-cases
@@ -2809,7 +2809,7 @@
                   [(fp-single-float) (values (reg-list) 1 (lambda (e) e))]
                   [(fp-integer ,bits) (handle-integer-cases bits)]
                   [(fp-unsigned ,bits) (handle-integer-cases bits)]
-                  [(fp-ftd& ,ftd) (handle-ftd&-case ftd)]
+                  [(fp-ftd& ,ftd ,fptd) (handle-ftd&-case ftd)]
                   [else (values (reg-list %Cretval) 0 (lambda (e) e))]))))
         (define do-indirect-result-from-registers
           (lambda (ftd offset)
@@ -3187,7 +3187,7 @@
                                             (fx+ stack-arg-offset size)
                                             next-varargs-after)])))]
                            [(nanopass-case (Ltype Type) (car types)
-                              [(fp-ftd& ,ftd) ftd]
+                              [(fp-ftd& ,ftd ,fptd) ftd]
                               [else #f])
                             =>
                             (lambda (ftd)
@@ -3295,7 +3295,7 @@
                           (f (cdr types)
                              (fxmin gp-reg-count (fx+ iint 1))
                              (fxmin fp-reg-count (fx+ iflt 1)))]
-                         [(fp-ftd& ,ftd)
+                         [(fp-ftd& ,ftd ,fptd)
                           (let ([words (fxsra (align 4 ($ftd-size ftd)) 2)]
                                 [members ($ftd->members ftd)])
                             (cond
@@ -3385,11 +3385,11 @@
                                    (cons (load-soft-single-stack stack-arg-offset) locs)
                                    iint iflt int-reg-offset float-reg-offset (fx+ stack-arg-offset 4)))]
                         [(nanopass-case (Ltype Type) (car types)
-                                        [(fp-ftd& ,ftd) (not ($ftd-compound? ftd))]
+                                        [(fp-ftd& ,ftd ,fptd) (not ($ftd-compound? ftd))]
                                         [else #f])
                          ;; load pointer to address on the stack
                          (let ([ftd (nanopass-case (Ltype Type) (car types)
-                                                   [(fp-ftd& ,ftd) ftd])])
+                                                   [(fp-ftd& ,ftd ,fptd) ftd])])
                            (case (and (not (constant software-floating-point))
                                       ($ftd-atomic-category ftd))
                              [(float)
@@ -3458,14 +3458,14 @@
                               (nanopass-case (Ltype Type) (car types)
                                 [(fp-double-float) #t]
                                 [(fp-single-float) #t]
-                                [(fp-ftd& ,ftd) (eq? 'float ($ftd-atomic-category ftd))]
+                                [(fp-ftd& ,ftd ,fptd) (eq? 'float ($ftd-atomic-category ftd))]
                                 [else #f]))
                          (f (cdr types) iint (if (fx< iflt fp-reg-count) (fx+ iflt 1) iflt))]
                         [(or (nanopass-case (Ltype Type) (car types)
                                [(fp-integer ,bits) (fx= bits 64)]
                                [(fp-unsigned ,bits) (fx= bits 64)]
-                               [(fp-ftd& ,ftd) (and (not ($ftd-compound? ftd))
-                                                    (fx= 8 ($ftd-size ftd)))]
+                               [(fp-ftd& ,ftd ,fptd) (and (not ($ftd-compound? ftd))
+                                                          (fx= 8 ($ftd-size ftd)))]
                                [else #f])
                              (and (constant software-floating-point)
                                   (nanopass-case (Ltype Type) (car types)
@@ -3517,7 +3517,7 @@
           (define do-result
             (lambda (result-type return-space-offset int-reg-offset)
               (nanopass-case (Ltype Type) result-type
-                [(fp-ftd& ,ftd)
+                [(fp-ftd& ,ftd ,fptd)
                  (case ($ftd-atomic-category ftd)
                    [(float)
                     (values
diff --git a/s/primdata.ss b/s/primdata.ss
index 0bd5e1baf..794f3e3d2 100644
--- a/s/primdata.ss
+++ b/s/primdata.ss
@@ -1077,11 +1077,14 @@
   (fluid-let-syntax [flags])
   (foreign-callable [flags])
   (foreign-procedure [flags])
+  (ftype-any-ref [flags])
+  (ftype-any-set! [flags])
   (ftype-guardian [flags])
   (ftype-init-lock! [flags])
   (ftype-lock! [flags])
   (ftype-locked-decr! [flags])
   (ftype-locked-incr! [flags])
+  (ftype-scheme-object-pointer? [flags])
   (ftype-pointer? [flags])
   (ftype-sizeof [flags])
   (ftype-&ref [flags])
@@ -1098,6 +1101,7 @@
   (library [flags])
   (library-requirements-options [flags])
   (make-ftype-pointer [flags])
+  (make-ftype-scheme-object-pointer [flags])
   (meta [flags])
   (meta-cond [flags])
   (module [flags])
@@ -1384,6 +1388,8 @@
   (ftype-pointer-ftype [sig [(ftype-pointer) -> (symbol/list)]] [flags mifoldable discard true])
   (ftype-pointer-null? [sig [(ftype-pointer) -> (boolean)]] [flags pure mifoldable discard])
   (ftype-pointer->sexpr [sig [(ftype-pointer) -> (ptr)]] [flags])
+  (ftype-scheme-object-pointer-object [sig [(sub-ftype-pointer) -> (ptr)]] [flags mifoldable discard])
+  (ftype-scheme-object-pointer-offset [sig [(sub-ftype-pointer) -> (exact-integer)]] [flags mifoldable discard true])
   (fx* [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])  ; not restricted to 2 arguments
   (fx*/wraparound [sig [(fixnum fixnum) -> (fixnum)]] [flags arith-op partial-folder safeongoodargs])
   (fx+ [sig [(fixnum ...) -> (fixnum)]] [flags arith-op partial-folder])  ; not restricted to 2 arguments
@@ -2042,7 +2048,9 @@
   ($fptr-locked-decr! [flags single-valued])
   ($fptr-locked-incr! [flags single-valued])
   ($fptr-lock! [flags single-valued])
+  ($fptr-null-pointer [flags single-valued])
   ($fptr-offset-addr [flags single-valued])
+  ($fptr-object-fptr-ref [flags single-valued discard])
   ($fptr-ref-bits [flags single-valued discard])
   ($fptr-ref-boolean [flags single-valued discard])
   ($fptr-ref-char [flags single-valued discard])
@@ -2182,9 +2190,11 @@
   ($fptr-spin-lock! [flags single-valued])
   ($fptr-unlock! [flags single-valued])
   ($fp-type->pred [flags single-valued])
+  ($fptd? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
+  ($fptd-object? [sig [(sub-ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
   ($ftd? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
   ($ftd-alignment [flags single-valued])
-  ($ftd-as-box? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
+  ($ftd-pair? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
   ($ftd-atomic-category [flags single-valued])
   ($ftd-compound? [sig [(sub-ptr) -> (boolean)]] [flags discard])
   ($ftd-ffi-encode [flags single-valued])
@@ -2293,13 +2303,14 @@
   ($make-library-requirements-options [flags single-valued pure discard true])
   ($make-load-binary [flags single-valued])
   ($make-object-finder [flags single-valued])
+  ($make-object-fptr [flags single-valued pure mifoldable discard true])
   ($make-phantom-bytevector [flags single-valued])
   ($make-promise [flags single-valued alloc])
   ($make-read [flags single-valued])
   ($make-recompile-condition [flags single-valued])
   ($make-record-constructor-descriptor [flags single-valued pure true cp02])
   ($make-record-type-descriptor [flags single-valued pure alloc cp02])
-  ($make-record-type [sig [(rtd maybe-rtd sub-ptr sub-list ptr ptr ptr ...) -> (rtd)]] [flags pure alloc cp02])
+  ($make-record-type [sig [(rtd maybe-rtd sub-ptr sub-list ptr ptr ptr ptr ...) -> (rtd)]] [flags pure alloc cp02])
   ($make-relocation-table! [flags single-valued])
   ($make-rnrs-libraries [flags single-valued])
   ($make-source-oops [flags single-valued])
@@ -2479,11 +2490,13 @@
   ($transformer->binding [flags single-valued])
   ($trans-ftype-guardian [flags single-valued])
   ($trans-ftype-locked-op! [flags single-valued])
+  ($trans-ftype-scheme-object-pointer? [sig [(ptr) -> (procedure)]] [flags alloc]) ; not boolean
   ($trans-ftype-pointer? [sig [(ptr) -> (procedure)]] [flags alloc]) ; not boolean
   ($trans-ftype-&ref [flags single-valued])
   ($trans-ftype-ref [flags single-valued])
   ($trans-ftype-set! [flags single-valued])
   ($trans-ftype-sizeof [flags single-valued])
+  ($trans-make-ftype-scheme-object-pointer [flags single-valued])
   ($trans-make-ftype-pointer [flags single-valued])
   ($unbound-object?  [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable])
   ($unbound-object [sig [() -> (unbound-object)]] [flags pure unrestricted mifoldable true])
diff --git a/s/reboot-record.ss b/s/reboot-record.ss
index c1fc2b168..2450317d9 100644
--- a/s/reboot-record.ss
+++ b/s/reboot-record.ss
@@ -5,8 +5,8 @@
 ;; to access host Scheme primitives.
 
 (define-record-type/orig re:rtd
-  (fields base-rtd name parent uid fields count sealed? opaque? extras)
-  (nongenerative #{re:rtd bxw8uzjdge5u6o5xp0kovyiun-0}))
+  (fields base-rtd name parent uid fields count sealed? opaque? alt-pm extras)
+  (nongenerative #{re:rtd bxw8uzjdge5u6o5xp0kovyiun-5}))
 
 (define-record-type/orig re:record
   (fields rtd vec)
@@ -53,6 +53,7 @@
                          (length fields)
                          #f
                          #f
+                         #f
                          '()))]
          [else (loop)])))))
 
@@ -100,22 +101,23 @@
            (handle x (+ (lookup-constant 'header-size-record)
                         (* (re:rtd-count (subst-base-rtd x)) (lookup-constant 'ptr-bytes))))]
           [(pm)
-           (handle x (let ([fields (all-fields (subst-base-rtd x))])
-                       (cond
-                         [(andmap (lambda (f)
-                                    (ptr-type? (field-type f)))
-                                  fields)
-                          -1]
-                         [else
-                          (let loop ([pm 1]
-                                     [m 2] ; start after base-rtd
-                                     [fields fields])
-                            (cond
-                              [(null? fields) pm]
-                              [else
-                               (loop (if (ptr-type? (field-type (car fields))) (bitwise-ior pm m) pm)
-                                     (bitwise-arithmetic-shift-left m 1)
-                                     (cdr fields))]))])))]
+           (handle x (or (and (re:rtd? x) (re:rtd-alt-pm x))
+                         (let ([fields (all-fields (subst-base-rtd x))])
+                           (cond
+                             [(andmap (lambda (f)
+                                        (ptr-type? (field-type f)))
+                                      fields)
+                              -1]
+                             [else
+                              (let loop ([pm 1]
+                                         [m 2] ; start after base-rtd
+                                         [fields fields])
+                                (cond
+                                  [(null? fields) pm]
+                                  [else
+                                   (loop (if (ptr-type? (field-type (car fields))) (bitwise-ior pm m) pm)
+                                         (bitwise-arithmetic-shift-left m 1)
+                                         (cdr fields))]))]))))]
           [(mpm)
            (handle x (let ([fields (all-fields (subst-base-rtd x))])
                        (let loop ([pm 0]
@@ -263,7 +265,7 @@
 
 (define all-rtds (make-eq-hashtable))
 
-(define-primitive ($make-record-type-descriptor base-rtd name parent uid sealed? opaque? fields . extras)
+(define-primitive ($make-record-type-descriptor* base-rtd name parent uid sealed? opaque? alt-pm fields . extras)
   (unless (or (eq? #!base-rtd base-rtd)
               (re:rtd? base-rtd))
     (error '$make-record-type-descriptor "bad base-rtd ~s" base-rtd))
@@ -283,12 +285,17 @@
                                 sealed?
                                 (or opaque? (and parent
                                                  (re:rtd-opaque? (subst-base-rtd parent))))
+                                alt-pm
                                 extras)])
           (hashtable-set! all-rtds uid rtd)
           rtd))))
 
-(define-primitive ($make-record-type base-rtd parent name fields sealed? opaque? . extras)
-  (apply $make-record-type-descriptor base-rtd name parent (if (#%gensym? name) name (gensym)) sealed? opaque?
+(define-primitive ($make-record-type-descriptor base-rtd name parent uid sealed? opaque? fields . extras)
+  (apply $make-record-type-descriptor* base-rtd name parent uid sealed? opaque? #f fields extras))
+
+(define-primitive ($make-record-type base-rtd parent name fields sealed? opaque? alt-pm . extras)
+  (apply $make-record-type-descriptor* base-rtd name parent (if (#%gensym? name) name (gensym)) sealed? opaque?
+         alt-pm
          (list->vector (map (lambda (f)
                               (if (symbol? f)
                                   (list 'mutable f)
@@ -297,10 +304,10 @@
          extras))
 
 (define-primitive (make-record-type-descriptor name parent uid sealed? opaque? fields)
-  ($make-record-type-descriptor #!base-rtd name parent uid sealed? opaque? fields))
+  ($make-record-type-descriptor* #!base-rtd name parent uid sealed? opaque? #f fields))
 
 (define-primitive (r6rs:make-record-type-descriptor name parent uid sealed? opaque? fields)
-  ($make-record-type-descriptor #!base-rtd name parent uid sealed? opaque? fields))
+  ($make-record-type-descriptor* #!base-rtd name parent uid sealed? opaque? #f fields))
 
 (define-primitive record-type-descriptor?
   (lambda (v)
@@ -316,7 +323,7 @@
                                   (make-field 'mutable 'scheme-object f)
                                   f))
                             fields)
-                       #f #f)]))
+                       #f #f #f)]))
 
 (define-primitive ($remake-rtd rtd compute-field-offsets)
   ;; We don't have to do anything here, because `base-rtd-accessor`
diff --git a/s/reboot.ss b/s/reboot.ss
index 8dbe02a80..80b3dfac0 100644
--- a/s/reboot.ss
+++ b/s/reboot.ss
@@ -373,8 +373,8 @@
  [else
   ;; If records in the host Scheme have the same representation as the target, we can
   ;; use the host Scheme's implementation of records, and things are about twice as fast:
-  (define-primitive ($make-record-type base-rtd parent name fields sealed? opaque? . extras)
-    (apply #%$make-record-type base-rtd parent name fields sealed? opaque? extras))
+  (define-primitive ($make-record-type base-rtd parent name fields sealed? opaque? alt-pm . extras)
+    (apply #%$make-record-type base-rtd parent name fields sealed? opaque? alt-pm extras))
   (define-primitive ($make-record-type-descriptor base-rtd parent name uid sealed? opaque? fields . extras)
     (apply #%$make-record-type-descriptor base-rtd parent name uid sealed? opaque? fields extras))
   (define-primitive ($make-record-constructor-descriptor rts parent protocol name)
@@ -404,7 +404,8 @@
 (define-primitive $expand-fp-ftype (lambda (who what r ftype)
                                      (#%$expand-fp-ftype who what r (syntax->datum ftype))))
 (define-primitive $ftd? #%$ftd?)
-(define-primitive $ftd-as-box? #%$ftd-as-box?)
+(define-primitive $ftd-pair? (lambda (x) (and (pair? x) (#%$ftd? (car x)))))
+(define-primitive $fptd? #%$ftd?)
 (define-primitive $filter-foreign-type #%$filter-foreign-type)
 
 (define-primitive $make-fmt->expr #%$make-fmt->expr)
@@ -530,7 +531,7 @@
 
 (define-primitive ($make-source-oops who . args)
   (($top-level-value 'datum->syntax) (or who ($make-interaction-syntax 'unknown))
-                                     `(error 'source "oops ~s" '(,who . ,args))))
+                                     `(error 'source "oops ~s" '(,who . ,(($top-level-value 'syntax->datum) args)))))
 
 (define-primitive ($source-warning . args)
   (printf "~s\n" args))
diff --git a/s/record.ss b/s/record.ss
index 9224ff72f..a0f57421d 100644
--- a/s/record.ss
+++ b/s/record.ss
@@ -567,7 +567,7 @@
             (constant rtd-opaque)
             0)
         (if sealed? (constant rtd-sealed) 0)))
-    (define ($mrt who base-rtd name parent uid flags fields anonymous-fields? extras)
+    (define ($mrt who base-rtd name parent uid flags fields anonymous-fields? alt-pm extras)
       (include "layout.ss")
       (when parent
         (when ($record-type-act-sealed? parent)
@@ -577,6 +577,15 @@
               ($oops who "cannot make anonymous-field record type ~s from named-field parent record type ~s" name parent))
             (when (fixnum? (rtd-flds parent))
               ($oops who "cannot make named-field record type ~s from anonymous-field parent record type ~s" name parent))))
+      (when alt-pm
+        (case alt-pm
+          [(#t) (let ([fields (append (if (not parent) '() (csv7:record-type-field-decls parent))
+                                      fields)])
+                  (unless (and (= 2 (length fields))
+                               (eq? 'uptr (cadr (car fields)))
+                               (eq? 'uptr (cadr (cadr fields))))
+                    ($oops who "fields ~s inconsistent with pointer-mask protocol ~s" fields alt-pm)))]
+          [else ($oops who "unrecognized alternative pointer-mask protocol ~s" alt-pm)]))
       (let ([uid (or uid ((current-generate-id) name))])
        ; start base offset at rtd field
        ; synchronize with syntax.ss and front.ss
@@ -632,6 +641,9 @@
                  (unless (eq? ($record-type-descriptor rtd) base-rtd) (squawk "different base rtd"))
                  (unless (eq? (rtd-parent rtd) parent) (squawk "different parent"))
                  (unless (same-fields? (rtd-flds rtd) (if (pair? flds) (cdr flds) (fx- flds 1))) (squawk "different fields"))
+                 (let ([pm (rtd-pm rtd)])
+                   (unless (if alt-pm (eq? pm alt-pm) (or (fixnum? pm) (bignum? pm)))
+                     (squawk "different pointer mask")))
                  (unless (= (rtd-mpm rtd) mpm) (squawk "different mutability"))
                  (unless (fx= (rtd-flags rtd) flags) (squawk "different flags"))
                  (unless (eq? (rtd-size rtd) size) (squawk "different size")))
@@ -643,7 +655,7 @@
                  (unless (fx= i len)
                    (vector-set! ancestry i (vector-ref (rtd-ancestry parent) i))
                    (loop (fx+ i 1))))
-               (let ([rtd (apply #%$record base-rtd ancestry size pm mpm name
+               (let ([rtd (apply #%$record base-rtd ancestry size (or alt-pm pm) mpm name
                                  (if (pair? flds) (cdr flds) (fx- flds 1)) flags uid #f extras)])
                  (vector-set! ancestry len rtd)
                  (with-tc-mutex ($sputprop uid '*rtd* rtd))
@@ -658,7 +670,10 @@
                     [ancestry (rtd-ancestry rtd)]
                     [name (rtd-name rtd)]
                     [flags (rtd-flags rtd)]
-                    [old-flds (rtd-flds rtd)])
+                    [old-flds (rtd-flds rtd)]
+                    [alt-pm (let ([old-pm (rtd-pm rtd)])
+                              (and (not (or (fixnum? old-pm) (bignum? old-pm)))
+                                   old-pm))])
                 (let-values ([(pm mpm flds size)
                               (if (fixnum? old-flds)
                                   (compute-field-offsets who
@@ -687,7 +702,7 @@
                                            (car flds))
                                        (loop (cdr flds) (cdr old-flds) (cdr parent-flds) (cdr parent-old-flds)))])))
                           flds)))
-                  (let ([rtd (apply #%$record base-rtd ancestry size pm mpm name
+                  (let ([rtd (apply #%$record base-rtd ancestry size (or alt-pm pm) mpm name
                                (if (pair? flds)
                                    (share-with-remade-parent (cdr flds))
                                    (fx- flds 1))
@@ -703,18 +718,18 @@
                     rtd)))))))
 
     (let ()
-      (define (mrt base-rtd parent name fields sealed? opaque? extras)
+      (define (mrt base-rtd parent name fields sealed? opaque? alt-pm extras)
         (cond
           [(gensym? name)
            ($mrt 'make-record-type base-rtd
              (string->symbol (symbol->string name)) parent name
              (make-flags name sealed? opaque? parent)
-             fields #f extras)]
+             fields #f alt-pm extras)]
           [(string? name)
            ($mrt 'make-record-type base-rtd
              (string->symbol name) parent #f
              (make-flags #f sealed? opaque? parent)
-             fields #f extras)]
+             fields #f alt-pm extras)]
           [else ($oops 'make-record-type "invalid record name ~s" name)]))
 
       (set-who! make-record-type
@@ -723,26 +738,26 @@
             [(name fields)
              (unless (list? fields)
                ($oops who "invalid field list ~s" fields))
-             (mrt base-rtd #f name fields #f #f '())]
+             (mrt base-rtd #f name fields #f #f #f '())]
             [(parent name fields)
              (unless (or (not parent) (record-type-descriptor? parent))
                ($oops who "~s is not a record type descriptor"
                  parent))
              (unless (list? fields)
                ($oops who "invalid field list ~s" fields))
-             (mrt base-rtd parent name fields #f #f '())])))
+             (mrt base-rtd parent name fields #f #f #f '())])))
 
-      (set! $make-record-type
-        (lambda (base-rtd parent name fields sealed? opaque? . extras)
+      (set-who! $make-record-type
+        (lambda (base-rtd parent name fields sealed? opaque? alt-pm . extras)
           (unless (record-type-descriptor? base-rtd)
-            ($oops 'make-record-type "~s is not a record type descriptor"
+            ($oops who "~s is not a record type descriptor"
               base-rtd))
           (unless (or (not parent) (record-type-descriptor? parent))
-            ($oops 'make-record-type "~s is not a record type descriptor"
+            ($oops who "~s is not a record type descriptor"
               parent))
           (unless (list? fields)
-            ($oops 'make-record-type "invalid field list ~s" fields))
-          (mrt base-rtd parent name fields sealed? opaque? extras))))
+            ($oops who "invalid field list ~s" fields))
+          (mrt base-rtd parent name fields sealed? opaque? alt-pm extras))))
 
     (let ()
       (define (mrtd base-rtd name parent uid sealed? opaque? fields anon-ok? who extras)
@@ -787,6 +802,7 @@
                              ($oops who "invalid field specifier ~s" x))
                            (cons x (f (fx+ i 1)))))))])
               (pair? fields)
+              #f
               extras))
 
       (set! $make-record-type-descriptor
diff --git a/s/riscv64.ss b/s/riscv64.ss
index 965358bd3..86c3fb9fc 100644
--- a/s/riscv64.ss
+++ b/s/riscv64.ss
@@ -1794,7 +1794,7 @@
                 (nanopass-case (Ltype Type) (car types)
                   [(fp-double-float) (fp-arg)]
                   [(fp-single-float) (fp-arg)]
-                  [(fp-ftd& ,ftd)
+                  [(fp-ftd& ,ftd ,fptd)
                    ;; A non-union with one floating-point member is treated
                    ;;  like that member by itself.
                    ;; A non-union that has exactly two members, at least one as
@@ -1895,7 +1895,7 @@
 
     (define (result-via-pointer-argument? type)
       (nanopass-case (Ltype Type) type
-        [(fp-ftd& ,ftd) (> ($ftd-size ftd) 16)]
+        [(fp-ftd& ,ftd ,fptd) (> ($ftd-size ftd) 16)]
         [else #f]))
 
     ;; result only meaningful if not `(result-via-pointer-argument? type)`
@@ -2054,7 +2054,7 @@
                                    [(fp) (use-fp-reg (load-single-reg reg))]
                                    [(int) (use-int-reg (load-single-into-int-reg reg))]
                                    [else (use-stack (load-single-stack isp))])]
-                                [(fp-ftd& ,ftd)
+                                [(fp-ftd& ,ftd ,fptd)
                                  (case (cat-place cat)
                                    [(fp)
                                     ;; must be 1 register
@@ -2170,7 +2170,7 @@
                    [arg-type* (info-foreign-arg-type* info)]
                    [result-type (info-foreign-result-type info)]
                    [ftd-result? (nanopass-case (Ltype Type) result-type
-                                  [(fp-ftd& ,ftd) #t]
+                                  [(fp-ftd& ,ftd ,fptd) #t]
                                   [else #f])]
                    [pass-result-ptr? (result-via-pointer-argument? result-type)]
                    [arg-type* (if (and ftd-result?
@@ -2322,7 +2322,7 @@
                            (case (cat-place cat)
                              [(fp int) (use-reg (load-single-stack reg-offset))]
                              [else (use-stack (load-single-stack stack-arg-offset))])]
-                          [(fp-ftd& ,ftd)
+                          [(fp-ftd& ,ftd ,fptd)
                            (cond
                              [(cat-by-reference cat)
                               ;; register or stack contains pointer to data; we
@@ -2386,7 +2386,7 @@
                      `(set! ,(car regs) ,(%inline double->single ,(%mref ,rhs ,%zero ,(constant flonum-data-disp) fp))))]
                   [(fp-void)
                    (lambda () `(nop))]
-                  [(fp-ftd& ,ftd)
+                  [(fp-ftd& ,ftd ,fptd)
                    (cond
                      [(not synthesize-first?)
                       ;; we passed the pointer to be filled, so nothing more to do here
@@ -2437,7 +2437,7 @@
                                         '()
                                         (cat-regs result-cat))]
                        [ftd-result? (nanopass-case (Ltype Type) result-type
-                                      [(fp-ftd& ,ftd) #t]
+                                      [(fp-ftd& ,ftd ,fptd) #t]
                                       [else #f])]
                        [synthesize-first? (and ftd-result?
                                                (not pass-result-ptr?))]
diff --git a/s/syntax.ss b/s/syntax.ss
index 424d62752..d53ccd5bd 100644
--- a/s/syntax.ss
+++ b/s/syntax.ss
@@ -664,8 +664,8 @@
               [(void) (and void-okay? `(fp-void))]
               [else
                (cond
-                [($ftd? x) `(fp-ftd ,x)]
-                [($ftd-as-box? x) `(fp-ftd& ,(unbox x))]
+                [($fptd? x) `(fp-fptd ,x)]
+                [($ftd-pair? x) `(fp-ftd& ,(car x) ,(cdr x))]
                 [else #f])])
             ($oops #f "invalid ~a ~a specifier ~s" who what x)))))
 
@@ -8877,7 +8877,7 @@
               ($syntax-match? (cdr pat) (cdr exp)))]))))
 
 (define $fp-filter-type
-  (lambda (type void-okay?)
+  (lambda (type as-result?)
    ; not the same as cmacros filter-type, which allows things like bigit
     (case type
       [(scheme-object double-float single-float
@@ -8886,7 +8886,7 @@
         integer-56 unsigned-56 integer-64 unsigned-64
         boolean stdbool fixnum char wchar u8* u16* u32* utf-8 utf-16le utf-16be utf-16
         utf-32le utf-32be utf-32) type]
-      [(void) (and void-okay? type)]
+      [(void) (and as-result? type)]
       [(ptr) 'scheme-object]
       [(iptr)
        (constant-case ptr-bits
@@ -8959,7 +8959,7 @@
             [(big) 'utf-32be]
             [(unknown) 'utf-32])])]
       [else
-       (and (or ($ftd? type) ($ftd-as-box? type))
+       (and (or ($fptd? type) ($ftd-pair? type))
             type)])))
 
 (define $fp-type->pred
@@ -9178,8 +9178,8 @@
                                     (check-floats-allowed pos)
                                     #f]
                                    [else #f])
-                                 (if (or ($ftd? type) ($ftd-as-box? type))
-                                     (let ([ftd (if ($ftd? type) type (unbox type))])
+                                 (if (or ($fptd? type) ($ftd-pair? type))
+                                     (let ([ftd (if ($fptd? type) type (cdr type))])
                                        #`(#,(if unsafe? #'() #`((unless (record? x '#,ftd) (err ($moi) x))))
                                           (x)
                                           (#,type)))
@@ -9221,7 +9221,7 @@
                          [(unsigned-56) #`((lambda (x) (mod x #x100000000000000)) unsigned-64)]
                          [else
                           (cond
-                            [($ftd-as-box? result-type)
+                            [($ftd-pair? result-type)
                              ;; Return void, since an extra first argument receives the result,
                              ;; but tell `$foreign-procedure` that the result is actually an & form
                              #`((lambda (r) (void)) #,(datum->syntax #'foreign-procedure result-type))]
@@ -9234,12 +9234,12 @@
                        ;; explicit for `$foreign-procedure`, and the return type is preserved as-is
                        ;; to let `$foreign-procedure` know that it needs to fill the first argument.
                        (cond
-                         [($ftd-as-box? result-type)
+                         [($ftd-pair? result-type)
                           #`([&-result]
-                             [#,(unbox result-type)]
+                             [#,(cdr result-type)]
                              #,(if unsafe?
                                    #`[]
-                                   #`[(unless (record? &-result '#,(unbox result-type)) (err ($moi) &-result))]))]
+                                   #`[(unless (record? &-result '#,(cdr result-type)) (err ($moi) &-result))]))]
                          [else #'([] [] [])])])
           #`(let ([p ($foreign-procedure conv* foreign-name ?foreign-addr (extra-arg ... arg ... ...) result)]
                   #,@(if unsafe?
@@ -9520,20 +9520,20 @@
                              [] [])]
                          [else
                           (cond
-                            [($ftd? result-type)
+                            [($fptd? result-type)
                              (with-syntax ([type (datum->syntax #'foreign-callable result-type)])
                                #`((lambda (x)
                                     #,@(if unsafe? #'() #'((unless (record? x 'type) (err x))))
                                     x)
                                   type
                                   [] []))]
-                            [($ftd-as-box? result-type)
+                            [($ftd-pair? result-type)
                              ;; callable receives an extra pointer argument to fill with the result;
                              ;; we add this type to `$foreign-callable` as an initial address argument,
                              ;; which may be actually provided by the caller or synthesized by the
                              ;; back end, depending on the type and architecture
                              (with-syntax ([type (datum->syntax #'foreign-callable result-type)]
-                                           [ftd (datum->syntax #'foreign-callable (unbox result-type))])
+                                           [ftd (datum->syntax #'foreign-callable (cdr result-type))])
                                #`((lambda (x) (void)) ; callable result is ignored
                                   type
                                   [ftd]
diff --git a/s/types.ss b/s/types.ss
index fb6c78ee2..bcbca114d 100644
--- a/s/types.ss
+++ b/s/types.ss
@@ -103,7 +103,7 @@
                      (let ([rtd ($make-record-type #!base-rtd #f
                                   '#{profile-counter b5vnnom9h4o4uny0-2}
                                   '((mutable uptr count))
-                                  #t #f)])
+                                  #t #f #f)])
                        #`(begin
                            (define make-profile-counter (record-constructor '#,rtd))
                            (define profile-counter? (record-predicate '#,rtd))
diff --git a/s/x86.ss b/s/x86.ss
index fb28ac7be..16e1c5856 100644
--- a/s/x86.ss
+++ b/s/x86.ss
@@ -2183,12 +2183,12 @@
   (define callee-expects-result-pointer?
     (lambda (result-type)
       (nanopass-case (Ltype Type) result-type
-        [(fp-ftd& ,ftd) (constant-case machine-type-name
-                          [(i3osx ti3osx i3nt ti3nt)
-                           (case ($ftd-size ftd)
-                             [(1 2 4 8) #f]
-                             [else #t])]
-                          [else ($ftd-compound? ftd)])]
+        [(fp-ftd& ,ftd  ,fptd) (constant-case machine-type-name
+                                 [(i3osx ti3osx i3nt ti3nt)
+                                  (case ($ftd-size ftd)
+                                    [(1 2 4 8) #f]
+                                    [else #t])]
+                                 [else ($ftd-compound? ftd)])]
         [else #f])))
   (define callee-pops-result-pointer?
     (lambda (result-type)
@@ -2196,7 +2196,7 @@
   (define fill-result-pointer-from-registers?
     (lambda (result-type)
       (nanopass-case (Ltype Type) result-type
-        [(fp-ftd& ,ftd) (not (callee-expects-result-pointer? result-type))]
+        [(fp-ftd& ,ftd ,fptd) (not (callee-expects-result-pointer? result-type))]
         [else #f])))
 
   (module (push-registers pop-registers push-registers-size)
@@ -2297,12 +2297,12 @@
                            (cons (load-single-stack n) locs)
                            (fx+ n 4)
                            #f)]
-                        [(fp-ftd& ,ftd)
+                        [(fp-ftd& ,ftd ,fptd)
                          (do-stack (cdr types)
                            (cons (load-content n ($ftd-size ftd)) locs)
                            (fx+ n (fxlogand (fx+ ($ftd-size ftd) 3) -4))
                            #f)]
-                        [(fp-ftd ,ftd)
+                        [(fp-fptd ,fptd)
                          (cond
                           [(and result-type
                                 (fill-result-pointer-from-registers? result-type))
@@ -2341,7 +2341,7 @@
           (cond
            [fill-result-here?
             (let* ([ftd (nanopass-case (Ltype Type) result-type
-                          [(fp-ftd& ,ftd) ftd])]
+                          [(fp-ftd& ,ftd ,fptd) ftd])]
                    [size ($ftd-size ftd)])
               (case size
                 [(4)
@@ -2448,7 +2448,7 @@
                       (cond
                        [fill-result-here?
                         (let* ([ftd (nanopass-case (Ltype Type) result-type
-                                      [(fp-ftd& ,ftd) ftd])]
+                                      [(fp-ftd& ,ftd ,fptd) ftd])]
                                [size ($ftd-size ftd)])
                           (%seq
                            ,call
@@ -2598,7 +2598,7 @@
                    (do-stack (cdr types)
                      (cons (load-single-stack n) locs)
                      (fx+ n 4))]
-                  [(fp-ftd& ,ftd)
+                  [(fp-ftd& ,ftd ,fptd)
                    (do-stack (cdr types)
                      (cons (load-stack-address n) locs)
                      (fx+ n (fxlogand (fx+ ($ftd-size ftd) 3) -4)))]
@@ -2615,7 +2615,7 @@
                          (fx+ n 4)))]))))
           (define (do-result result-type init-stack-offset indirect-result-to-registers?)
             (nanopass-case (Ltype Type) result-type
-              [(fp-ftd& ,ftd)
+              [(fp-ftd& ,ftd ,fptd)
                (cond
                 [indirect-result-to-registers?
                  (cond
diff --git a/s/x86_64.ss b/s/x86_64.ss
index 4a49b1464..c6cc6db2b 100644
--- a/s/x86_64.ss
+++ b/s/x86_64.ss
@@ -2473,12 +2473,12 @@
 
     (define (classify-type type)
       (nanopass-case (Ltype Type) type
-        [(fp-ftd& ,ftd) (classify-eightbytes ftd)]
+        [(fp-ftd& ,ftd ,fptd) (classify-eightbytes ftd)]
         [else #f]))
 
     (define (classified-size type)
       (nanopass-case (Ltype Type) type
-        [(fp-ftd& ,ftd) ($ftd-size ftd)]
+        [(fp-ftd& ,ftd ,fptd) ($ftd-size ftd)]
         [else #f]))
 
     ;; classify-eightbytes: returns '(memory) or a nonemtpy list of 'integer/'sse
@@ -2740,7 +2740,7 @@
                                    (loop (cdr types)
                                      (cons (load-single-stack isp) locs)
                                      regs fp-regs i (fx+ isp 8)))]
-                              [(fp-ftd& ,ftd)
+                              [(fp-ftd& ,ftd ,fptd)
                                (cond
                                 [(memv ($ftd-size ftd) '(1 2 4 8))
                                  ;; pass as value in register or as value on the stack
@@ -2808,7 +2808,7 @@
                                    (loop (cdr types)
                                      (cons (load-single-stack isp) locs)
                                      regs fp-regs iint ifp (fx+ isp 8)))]
-                              [(fp-ftd& ,ftd)
+                              [(fp-ftd& ,ftd ,fptd)
                                (let* ([classes (classify-eightbytes ftd)]
                                       [ints (count 'integer classes)]
                                       [fps (count 'sse classes)])
@@ -3116,7 +3116,7 @@ incoming           |   incoming return address | one quad
                                ,(%inline store-single ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp i))
                                ,(f (cdr types) (fx+ i 1) (fx+ isp 8)))
                              (f (cdr types) i isp))]
-                        [(fp-ftd& ,ftd)
+                        [(fp-ftd& ,ftd ,fptd)
                          (cond
                           [(memv ($ftd-size ftd) '(1 2 4 8))
                            ;; receive as value in register or on the stack
@@ -3171,7 +3171,7 @@ incoming           |   incoming return address | one quad
                                ,(%inline store-single ,(%mref ,%sp ,%zero ,isp fp) ,(vector-ref vfp ifp))
                                ,(f (cdr types) iint (fx+ ifp 1) (fx+ isp 8)))
                              (f (cdr types) iint ifp isp))]
-                        [(fp-ftd& ,ftd)
+                        [(fp-ftd& ,ftd ,fptd)
                          (let* ([classes (classify-eightbytes ftd)]
                                 [ints (count 'integer classes)]
                                 [fps (count 'sse classes)])
@@ -3212,7 +3212,7 @@ incoming           |   incoming return address | one quad
                            (nanopass-case (Ltype Type) (car types)
                              [(fp-double-float) (load-double-stack isp)]
                              [(fp-single-float) (load-single-stack isp)]
-                             [(fp-ftd& ,ftd)
+                             [(fp-ftd& ,ftd ,fptd)
                               (cond
                                [(memq ($ftd-size ftd) '(1 2 4 8))
                                 ;; passed by value
@@ -3248,7 +3248,7 @@ incoming           |   incoming return address | one quad
                              (f (cdr types)
                                (cons (load-single-stack risp) locs)
                                iint (fx+ ifp 1) (fx+ risp 8) sisp))]
-                        [(fp-ftd& ,ftd)
+                        [(fp-ftd& ,ftd ,fptd)
                          (let* ([classes (classify-eightbytes ftd)]
                                 [ints (count 'integer classes)]
                                 [fps (count 'sse classes)])
@@ -3275,7 +3275,7 @@ incoming           |   incoming return address | one quad
                                (fx+ iint 1) ifp (fx+ risp 8) sisp))]))))))
           (define (do-result result-type result-classes adjust-active?)
             (nanopass-case (Ltype Type) result-type
-              [(fp-ftd& ,ftd)
+              [(fp-ftd& ,ftd ,fptd)
                (cond
                 [(result-fits-in-registers? result-classes)
                  ;; Copy content of result area on stack into