ffi/unsafe: repair cast from GCable pointer with offset

The repair in 601f4a76e7 did not correctly handle pointers with a
non-zero offset.

Thanks to Bruce O'Neel for the report.

pkgs/racket-test-core/tests/racket/foreign-test.rktl

@@ -731,6 +731,15 @@
   (test (cast p _thing-pointer _intptr)
         cast q _stuff-pointer _intptr))
 
+;; For casts where the BC output might share with the input, so
+;; an offset pointer needs to be 'atomic-interior
+(define (share-protect bstr)
+  (if (eq? 'racket (system-type 'vm))
+      (let ([new-bstr (malloc 'atomic-interior (add1 (bytes-length bstr)))])
+        (memcpy new-bstr bstr (add1 (bytes-length bstr)))
+        (make-sized-byte-string new-bstr (bytes-length bstr)))
+      bstr))
+
 ;; `cast` should auto-upgrade target pointer types using `_gcable` for a GCable argument
 (test #t cpointer-gcable? (cast #"x" _pointer _pointer))
 (test #t cpointer-gcable? (cast #"x" _gcpointer _pointer))
@@ -738,9 +747,22 @@
 (test #t cpointer-gcable? (cast (malloc 8) _pointer _pointer))
 (test #t cpointer-gcable? (cast (malloc 8) _gcpointer _pointer))
 (test #t cpointer-gcable? (cast (malloc 8) _pointer _gcpointer))
+(test #t cpointer-gcable? (cast (ptr-add (malloc 8) 5) _pointer _pointer))
 (test #t cpointer-gcable? (cast #"x" _bytes _pointer))
 (test #t cpointer-gcable? (cast #"x" _bytes _gcpointer))
 (test #t cpointer-gcable? (cast #"x" _bytes _bytes))
+(test "lo" cast #"lo\0" _pointer _string/utf-8)
+(test "lo" cast (if (system-big-endian?) #"l\0o\0\0\0" #"l\0o\0\0\0") _pointer _string/utf-16)
+(test "lo" cast (if (system-big-endian?) #"\0\0\0l\0\0\0o\0\0\0\0\0\0\0\0" #"l\0\0\0o\0\0\0\0\0\0\0")
+      _pointer _string/ucs-4)
+(test #t cpointer-gcable? (cast (ptr-add #"xy" 1) _pointer _bytes))
+(test #t cpointer-gcable? (cast (ptr-add #"xy" 1) _pointer _pointer))
+(test (char->integer #\y) ptr-ref (cast (ptr-add #"xy" 1) _pointer _pointer) _byte)
+(test #"lo" cast (ptr-add (share-protect #"hello\0") 3) _pointer _bytes)
+(test "lo" cast (ptr-add #"hello\0" 3) _pointer _string/utf-8)
+(test "lo" cast (ptr-add (if (system-big-endian?) #"e\0l\0l\0o\0\0\0" #"\0l\0l\0o\0\0\0") 3) _pointer _string/utf-16)
+(test "lo" cast (ptr-add (share-protect (if (system-big-endian?) #"\0\0\0l\0\0\0l\0\0\0o\0\0\0\0\0\0\0\0" #"\0\0\0\0l\0\0\0o\0\0\0\0\0\0\0")) 4)
+      _pointer _string/ucs-4)
 (test #t
       'many-casts
       (for/and ([i (in-range 1000)])

racket/collects/ffi/unsafe.rkt

@@ -1476,46 +1476,79 @@
   (cond
    [(and (cpointer? p)
          (cpointer-gcable? p))
+    (define to-ct (ctype-coretype to-type))
+    (define (pointer->gcpointer t)
+      (define ct (ctype-coretype t))
+      (if (eq? ct 'pointer)
+          (_gcable t)
+          t))
     (let loop ([p p])
       (cond
-        [(and (not (zero? (ptr-offset p)))
+        [(coretype-pointer? to-ct)
-              (let ([ct (ctype-coretype to-type)])
+         (cond
-                (or (eq? ct 'pointer)
+           [(not (zero? (ptr-offset p)))
-                    (eq? ct 'gcpointer))))
+            (cond
-         (define o (ptr-offset p))
+              [(coretype-plain-pointer? to-ct)
-         (define from-t (cpointer-tag p))
+               (define o (ptr-offset p))
-         (define z (ptr-add p (- o)))
+               (define from-t (cpointer-tag p))
-         (when from-t
+               (define z (ptr-add p (- o)))
-           (set-cpointer-tag! z from-t))
+               (when from-t
-         (define q (loop z))
+                 (set-cpointer-tag! z from-t))
-         (define to-t (cpointer-tag q))
+               (define q (loop z))
-         (define r (ptr-add q o))
+               (define to-t (cpointer-tag q))
-         (when to-t
+               (define r (ptr-add q o))
-           (set-cpointer-tag! r to-t))
+               (when to-t
-         r]
+                 (set-cpointer-tag! r to-t))
-        [(ctype-pointer? to-type)
+               r]
-         (define (pointer->cpointer t)
+              [(coretype-noncopying? to-ct)
-           (define ct (ctype-coretype t))
+               ;; we assume that an interior pointer is ok/wanted
-           (if (eq? ct 'pointer)
+               (convert p (pointer->gcpointer from-type) to-type)]
-               (_gcable t)
+              [else
-               t))
+               ;; converting to a string or similar;
-         (convert p (pointer->cpointer from-type) (pointer->cpointer to-type))]
+               ;; we can't store an offset pointer into
+               ;; GCable memory, so copy to fresh GCable
+               ;; memory, first
+               (define nul-count (case to-ct
+                                   [(string/ucs-4) 4]
+                                   [(string/utf-16) 2]
+                                   [else 1]))
+               (define len (let loop ([i 0] [count nul-count])
+                             (if (zero? (ptr-ref p _byte i))
+                                 (if (= count 1)
+                                     (+ i nul-count)
+                                     (loop (add1 i) (sub1 count)))
+                                 (loop (add1 i) nul-count))))
+               (define p2 (malloc len 'atomic))
+               (memcpy p2 p len)
+               (loop p2)])]
+           [else
+            (convert p (pointer->gcpointer from-type) (pointer->gcpointer to-type))])]
         [else
          (convert p from-type to-type)]))]
    [else
     (convert p from-type to-type)]))
 
-(define (ctype-pointer? ctype)
+(define (coretype-pointer? ct)
-  (define coretype (ctype-coretype ctype))
+  (memq ct '(pointer
-  (memq coretype '(pointer
+             gcpointer
-                   gcpointer
+             fpointer
-                   fpointer
+             bytes
-                   bytes
+             scheme
-                   scheme
+             string
-                   string
+             string/ucs-4
-                   string/ucs-4
+             string/utf-16
-                   string/utf-16
+             symbol)))
-                   symbol)))
+
+(define (coretype-plain-pointer? ct)
+  (or (eq? ct 'pointer)
+      (eq? ct 'gcpointer)
+      (eq? ct 'fpointer)))
+
+(define (coretype-noncopying? ct)
+  (or (and (eq? 'racket (system-type 'vm))
+           (or (eq? ct 'bytes)
+               (eq? ct 'string/ucs-4)))
+      (eq? ct 'scheme)))
 
 (define* (_or-null ctype)
   (let ([coretype (ctype-coretype ctype)])