ffi/unsafe/alloc: handle keyword arguments

closes https://github.com/racket/racket/issues/2484

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

@@ -63,6 +63,9 @@ The optional @racket[get-arg] procedure determines which of
 @racket[dealloc]'s arguments correspond to the released object;
 @racket[get-arg] receives a list of arguments passed to
 @racket[dealloc], so the default @racket[car] selects the first one.
+Note that @racket[get-arg] can only choose one of the by-position
+arguments to @racket[dealloc], though the @tech{deallocator} will
+require and accept the same keyword arguments as @racket[dealloc], if any.
 
 The @racket[releaser] procedure is a synonym for
 @racket[deallocator].}
@@ -94,6 +97,9 @@ The optional @racket[get-arg] procedure determines which of the
 arguments) correspond to the retained object @racket[_v];
 @racket[get-arg] receives a list of arguments passed to
 @racket[retain], so the default @racket[car] selects the first one.
+Note that @racket[get-arg] can only choose one of the by-position
+arguments to @racket[retain], though the @tech{retainer} will
+require and accept the same keyword arguments as @racket[retain], if any.
 
 @history[#:changed "7.0.0.4" @elem{Added atomic mode for @racket[release]
                                    and changed non-main place exits to call

racket/collects/ffi/unsafe/alloc.rkt

@@ -55,61 +55,111 @@
        ;; replaced existing allocations/retains.
        (remove-node! expected-ds)])))
 
+(define (check-arity-includes-1 who proc [expected "(-> any/c any)"])
+  (unless (procedure-arity-includes? proc 1)
+    (raise-argument-error who expected proc)))
+
 (define ((allocator d) proc)
+  (check-arity-includes-1 'allocator d)
   (rename
-    (lambda args
-      (call-as-atomic
-        (lambda ()
-          (let ([v (apply proc args)])
-            (when v
-              (define ds (node (make-late-weak-box v) d #f #f #f))
-              (add-node! ds)
-              (hash-set! allocated v ds)
-              (register-finalizer v deallocate))
-            v))))
-    proc))
+   (let-values ([(_ allowed-kws) (procedure-keywords proc)])
+     (define (register v)
+       (when v
+         (define ds (node (make-late-weak-box v) d #f #f #f))
+         (add-node! ds)
+         (hash-set! allocated v ds)
+         (register-finalizer v deallocate))
+       v)
+     (cond
+       [(null? allowed-kws)
+        (lambda args
+          (call-as-atomic
+           (lambda ()
+             (register (apply proc args)))))]
+       [else
+        (make-keyword-procedure
+         (λ (kws kw-args . rest)
+           (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)")
   (rename
-    (lambda args
-      (call-as-atomic
-        (lambda ()
-         (apply proc args)
-         (let ([v (get-arg args)])
-           (let ([ds (hash-ref allocated v #f)])
-             (when ds
-               (remove-node! ds)
-               (define rest-ds (node-rest ds))
-               (if rest-ds
-                   (hash-set! allocated v rest-ds)
-                   (hash-remove! allocated v))))))))
-    proc))
+   (let-values ([(_ allowed-kws) (procedure-keywords proc)])
+     (define (handle v)
+       (let ([ds (hash-ref allocated v #f)])
+         (when ds
+           (remove-node! ds)
+           (define rest-ds (node-rest ds))
+           (if rest-ds
+               (hash-set! allocated v rest-ds)
+               (hash-remove! allocated v)))))
+     (cond
+       [(null? allowed-kws)
+        (lambda args
+          (call-as-atomic
+           (lambda ()
+             (begin0 (apply proc args)
+                     (handle (get-arg args))))))]
+       [else
+        (make-keyword-procedure
+         (λ (kws kw-args . rest)
+           (call-as-atomic
+            (lambda ()
+              (begin0
+                (keyword-apply proc kws kw-args rest)
+                (handle (get-arg rest)))))))]))
+   proc))
 
 (define ((retainer d [get-arg car]) proc)
+  (check-arity-includes-1 'retainer d)
+  (check-arity-includes-1 'retainer get-arg "(-> list/c any/c)")
   (rename
-   (lambda args
-     (call-as-atomic
-       (lambda ()
-         (begin0
-           (apply proc args)
-           (let ([v (get-arg args)])
-             (define next-ds (hash-ref allocated v #f))
-             (define ds (node (make-late-weak-box v) d #f #f next-ds))
-             (add-node! ds)
-             (hash-set! allocated v ds)
-             (unless next-ds
-               (register-finalizer v deallocate)))))))
+   (let-values ([(_ allowed-kws) (procedure-keywords proc)])
+     (define (handle v)
+       (define next-ds (hash-ref allocated v #f))
+       (define ds (node (make-late-weak-box v) d #f #f next-ds))
+       (add-node! ds)
+       (hash-set! allocated v ds)
+       (unless next-ds
+         (register-finalizer v deallocate)))
+     (cond
+       [(null? allowed-kws)
+        (lambda args
+          (call-as-atomic
+           (lambda ()
+             (begin0 (apply proc args)
+                     (handle (get-arg args))))))]
+       [else
+        (make-keyword-procedure
+         (λ (kws kw-args . rest)
+           (call-as-atomic
+            (lambda ()
+              (begin0
+                (keyword-apply proc kws kw-args rest)
+                (handle (get-arg rest)))))))]))
    proc))
 
+
 (define (rename new orig)
   (and orig
-       (let ([n (object-name orig)]
-             [new (procedure-reduce-arity
-                   new
-                   (procedure-arity orig))])
-         (if n
-             (procedure-rename new n)
-             new))))
+       (let-values ([(required-kws allowed-kws) (procedure-keywords orig)]
+                    [(arity-mask) (procedure-arity-mask orig)]
+                    [(name) (object-name orig)])
+         (cond
+           [(null? allowed-kws)
+            (procedure-reduce-arity-mask
+             new
+             arity-mask
+             name)]
+           [else
+            (procedure-reduce-keyword-arity-mask
+             (if name (procedure-rename new name) new)
+             arity-mask
+             required-kws
+             allowed-kws)]))))
 
 ;; ----------------------------------------