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
+   (let-values ([(_ allowed-kws) (procedure-keywords proc)])
-      (call-as-atomic
+     (define (register v)
-        (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))))
+       v)
-    proc))
+     (cond
-
+       [(null? allowed-kws)
-(define ((deallocator [get-arg car]) proc)
-  (rename
         (lambda args
           (call-as-atomic
            (lambda ()
-         (apply proc args)
+             (register (apply proc args)))))]
-         (let ([v (get-arg 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
+   (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))))))))
+               (hash-remove! allocated v)))))
-    proc))
+     (cond
-
+       [(null? allowed-kws)
-(define ((retainer d [get-arg car]) proc)
-  (rename
         (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
-           (apply proc args)
+                (keyword-apply proc kws kw-args rest)
-           (let ([v (get-arg args)])
+                (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
+   (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)))))))
+         (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)]
+       (let-values ([(required-kws allowed-kws) (procedure-keywords orig)]
-             [new (procedure-reduce-arity
+                    [(arity-mask) (procedure-arity-mask orig)]
+                    [(name) (object-name orig)])
+         (cond
+           [(null? allowed-kws)
+            (procedure-reduce-arity-mask
              new
-                   (procedure-arity orig))])
+             arity-mask
-         (if n
+             name)]
-             (procedure-rename new n)
+           [else
-             new))))
+            (procedure-reduce-keyword-arity-mask
+             (if name (procedure-rename new name) new)
+             arity-mask
+             required-kws
+             allowed-kws)]))))
 
 ;; ----------------------------------------