ffi/unsafe/alloc: allow #f as an "allocator"

Allowing #f as an allocator avoids problems composing `allocator` with
foreign-function lookup where failure is anticipated and implemented
as #f. For example, `g_settings_new` in the "gui-lib" package's
"mred/private/wx/gtk/gsettings.rkt" can be #f if the libgio libray is
too old, in which case there won't be an attempt to use
`g_settings_new`.

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

@@ -9,14 +9,16 @@
 ensuring that values allocated through foreign functions are reliably
 deallocated.}
 
-@defproc[((allocator [dealloc (any/c . -> . any)]) [alloc procedure?]) procedure?]{
+@defproc[((allocator [dealloc (any/c . -> . any)]) [alloc (or/c procedure? #f)]) (or/c procedure? #f)]{
 
 Produces an @deftech{allocator} procedure that behaves like
 @racket[alloc], but each result @racket[_v] of the @tech{allocator},
 if not @racket[#f], is given a finalizer that calls @racket[dealloc]
-on @racket[_v] --- unless the call has been canceled by applying a
+on @racket[_v]---unless the call has been canceled by applying a
 @tech{deallocator} (produced by @racket[deallocator]) to @racket[_v].
 Any existing @racket[dealloc] registered for @racket[_v] is canceled.
+If and only if @racket[alloc] is @racket[#f], @racket[((allocator
+alloc) dealloc)] produces @racket[#f].
 
 The resulting @tech{allocator} calls @racket[alloc] in @tech{atomic
 mode} (see @racket[call-as-atomic]). The result from @racket[alloc] is
@@ -44,7 +46,9 @@ a new deallocation action that will run earlier.
 
 @history[#:changed "7.0.0.4" @elem{Added atomic mode for @racket[dealloc]
                                    and changed non-main place exits to call
-                                   all remaining @racket[dealloc]s.}]}
+                                   all remaining @racket[dealloc]s.}
+         #:changed "7.4.0.4" @elem{Produce @racket[#f] when @racket[alloc]
+                                   is @racket[#f].}]}
 
 @deftogether[(
 @defproc[((deallocator [get-arg (list? . -> . any/c) car]) [dealloc procedure?]) 

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

@@ -5,6 +5,7 @@
 
 (require ffi/unsafe
          ffi/unsafe/cvector
+         ffi/unsafe/alloc
          ffi/unsafe/define
          ffi/unsafe/define/conventions
          ffi/vector
@@ -1302,6 +1303,11 @@
 
 ;; ----------------------------------------
 
+(test #t procedure? ((allocator void) void))
+(test #f (allocator void) #f)
+
+;; ----------------------------------------
+
 ;; Check `void/reference-sink`
 (let* ([sym (gensym)]
        [wb (make-weak-box sym)])

racket/collects/ffi/unsafe/alloc.rkt

@@ -61,28 +61,31 @@
 
 (define ((allocator d) proc)
   (check-arity-includes-1 'allocator d)
-  (rename
+  (cond
-   (let-values ([(_ allowed-kws) (procedure-keywords proc)])
+    [(not proc) #f]
-     (define (register v)
+    [else
-       (when v
+     (rename
-         (define ds (node (make-late-weak-box v) d #f #f #f))
+      (let-values ([(_ allowed-kws) (procedure-keywords proc)])
-         (add-node! ds)
+        (define (register v)
-         (hash-set! allocated v ds)
+          (when v
-         (register-finalizer v deallocate))
+            (define ds (node (make-late-weak-box v) d #f #f #f))
-       v)
+            (add-node! ds)
-     (cond
+            (hash-set! allocated v ds)
-       [(null? allowed-kws)
+            (register-finalizer v deallocate))
-        (lambda args
+          v)
-          (call-as-atomic
+        (cond
-           (lambda ()
+          [(null? allowed-kws)
-             (register (apply proc args)))))]
+           (lambda args
-       [else
+             (call-as-atomic
-        (make-keyword-procedure
+              (lambda ()
-         (λ (kws kw-args . rest)
+                (register (apply proc args)))))]
-           (call-as-atomic
+          [else
-            (lambda ()
+           (make-keyword-procedure
-              (register (keyword-apply proc kws kw-args rest))))))]))
+            (λ (kws kw-args . rest)
-   proc))
+              (call-as-atomic
+               (lambda ()
+                 (register (keyword-apply proc kws kw-args rest))))))]))
+      proc)]))
 
 (define ((deallocator [get-arg car]) proc)
   (check-arity-includes-1 'deallocator get-arg "(-> list/c any/c)")