diff --git a/pkgs/racket-doc/scribblings/foreign/cpointer.scrbl b/pkgs/racket-doc/scribblings/foreign/cpointer.scrbl index 9aa45e414f..686ea51bfd 100644 --- a/pkgs/racket-doc/scribblings/foreign/cpointer.scrbl +++ b/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])]{ diff --git a/pkgs/racket-test-core/tests/racket/foreign-test.rktl b/pkgs/racket-test-core/tests/racket/foreign-test.rktl index 5f674a94f1..ec083cadb0 100644 --- a/pkgs/racket-test-core/tests/racket/foreign-test.rktl +++ b/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 diff --git a/racket/collects/ffi/unsafe.rkt b/racket/collects/ffi/unsafe.rkt index 83ec48c1a2..dc2bb4ed56 100644 --- a/racket/collects/ffi/unsafe.rkt +++ b/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 (TYPE? x) - (and (cpointer? x) (cpointer-has-tag? x TYPE-tag))))))])) + (define-cpointer-pred TYPE? TYPE-tag))))])) ;; ---------------------------------------------------------------------------- ;; Struct wrappers