Add a way to recognize cpointer predicates. (#1368)

Similar to `struct-predicate-procedure?`. Allows Typed Racket
(and the contract system generally) to avoid chaperone wrapping
for cpointer predicates.

pkgs/racket-doc/scribblings/foreign/cpointer.scrbl

@@ -74,6 +74,14 @@ type produced by @racket[_cpointer/null] type. Finally,
 @racketvarfont{id}@racketidfont{-tag} is defined as an accessor to
 obtain a tag. The tag is the symbol form of @racketvarfont{id}.}
 
+@defproc[(cpointer-predicate-procedure? [v any/c]) boolean?]{Returns
+ @racket[#t] if @racket[v] is a predicate procedure generated by
+ @racket[define-cpointer-type] or @racket[define-cstruct], @racket[#f]
+ otherwise.
+
+@history[#:added "6.6.0.1"]{}
+}
+
 @defproc*[([(cpointer-has-tag? [cptr cpointer?] [tag any/c]) boolean?]
            [(cpointer-push-tag! [cptr cpointer?] [tag any/c]) void])]{
 

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

@@ -1020,6 +1020,8 @@
 
 (define-cpointer-type _foo)
 (test 'foo? object-name foo?)
+(test #t cpointer-predicate-procedure? foo?)
+(test #f cpointer-predicate-procedure? (λ (x) (foo? x)))
 
 (define-cpointer-type _also_foo #f #f (lambda (ptr)
                                         (cpointer-push-tag! ptr 'extra)
@@ -1027,6 +1029,7 @@
 (let ([p (cast (malloc 16) _pointer _also_foo)])
   (test #t also_foo? p)
   (test #t cpointer-has-tag? p 'extra))
+(test #t cpointer-predicate-procedure? foo?)
 
 ;; ----------------------------------------
 ;; Test JIT inlining
@@ -1161,6 +1164,7 @@
                          [non4 _intptr])
   #:define-unsafe
   #:malloc-mode 'tagged)
+(test #t cpointer-predicate-procedure? tagged?)
 
 (define t (scheme_make_type "new-type"))
 (scheme_register_type_gc_shape t (list SHAPE_STR_PTR_OFFSET tagged-obj1-offset

racket/collects/ffi/unsafe.rkt

@@ -1343,6 +1343,25 @@
      [else
       (loop (ctype-basetype c))])))
 
+;; a way to recognize predicates for cpointer types
+;; similar to `struct-predicate-procedure?`
+(struct cpointer-pred (f)
+  #:property prop:procedure 0)
+
+(define-syntax (define-cpointer-pred stx)
+  (syntax-case stx ()
+    [(_ id tag)
+     (syntax/loc stx
+       (define id
+         (cpointer-pred
+          ;; make sure it has the right inferred name
+          (let ([id (lambda (x) (and (cpointer? x) (cpointer-has-tag? x tag)))])
+            id))))]))
+
+(define cpointer-predicate-procedure? (procedure-rename cpointer-pred? 'cpointer-predicate-procedure?))
+
+(provide cpointer-predicate-procedure?)
+
 ;; A macro version of the above two functions, using the defined name for a tag
 ;; string, and defining a predicate too.  The name should look like `_foo', the
 ;; predicate will be `foo?', and the tag will be "foo".  In addition, `foo-tag'
@@ -1375,9 +1394,7 @@
                (_cpointer      TYPE-tag ptr-type scheme->c c->scheme))
              (define _TYPE/null
                (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme))
-             ;; Make the predicate function have the right inferred name
+             (define-cpointer-pred TYPE? TYPE-tag))))]))
-             (define (TYPE? x)
-               (and (cpointer? x) (cpointer-has-tag? x TYPE-tag))))))]))
 
 ;; ----------------------------------------------------------------------------
 ;; Struct wrappers