Move contents of unstable/function to racket/function.

Split implementation of racket/function to avoid circular dependencies.

pkgs/racket-doc/scribblings/reference/procedures.scrbl

@@ -562,6 +562,38 @@ returns the @racket[not] of @racket[proc]'s result.
 (map (negate =) '(1 2 3) '(1 1 1))
 ]}
 
+@defproc[((conjoin [f (-> A ... boolean?)] ...) [x A] ...) boolean?]{
+
+Combines calls to each function with @racket[and].  Equivalent to
+@racket[(and (f x ...) ...)]
+
+@defexamples[
+#:eval fun-eval
+(define f (conjoin exact? integer?))
+(f 1)
+(f 1.0)
+(f 1/2)
+(f 0.5)
+]
+
+}
+
+@defproc[((disjoin [f (-> A ... boolean?)] ...) [x A] ...) boolean?]{
+
+Combines calls to each function with @racket[or].  Equivalent to
+@racket[(or (f x ...) ...)]
+
+@defexamples[
+#:eval fun-eval
+(define f (disjoin exact? integer?))
+(f 1)
+(f 1.0)
+(f 1/2)
+(f 0.5)
+]
+
+}
+
 @defproc*[([(curry [proc procedure?]) procedure?]
            [(curry [proc procedure?] [v any/c] ...+) any/c])]{
 

pkgs/racket-test/tests/racket/bool.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(require racket/bool rackunit)
+(require racket/bool racket/function rackunit)
 
 (check-true true)
 (check-false false)
@@ -41,3 +41,13 @@
 (check-equal? (xor 11 #f) 11)
 (check-equal? (xor #f 22) 22)
 (check-equal? (xor #f #f) #f)
+
+(check-true ((conjoin) 'x #:y 'z)) ; no function
+(check-true ((conjoin integer? exact?) 1))
+(check-false ((conjoin integer? exact?) 1.0))
+(check-false ((conjoin integer? exact?) 0.5))
+
+(check-false ((disjoin) 'x #:y 'z)) ; no function
+(check-true ((disjoin integer? exact?) 1))
+(check-true ((disjoin integer? exact?) 1/2))
+(check-false ((disjoin integer? exact?) 0.5))

racket/collects/racket/function.rkt

@@ -1,9 +1,11 @@
 #lang racket/base
 
-(require (for-syntax racket/base syntax/name) racket/private/norm-arity)
+(require (for-syntax racket/base racket/list syntax/name)
+         racket/match racket/private/arity)
 
 (provide identity const thunk thunk* negate curry curryr
-         normalize-arity normalized-arity? arity=? arity-includes?)
+         (all-from-out racket/private/arity)
+         conjoin disjoin)
 
 (define (identity x) x)
 
@@ -82,104 +84,126 @@
 (define curry  (make-curry #f))
 (define curryr (make-curry #t))
 
-(define (normalized-arity? a)
-  (or (null? a)
-      (arity? a)
-      (and (list? a)
-           ((length a) . >= . 2)
-           (andmap arity? a)
-           (if (ormap arity-at-least? a)
-               (non-empty-non-singleton-sorted-list-ending-with-arity? a)
-               (non-singleton-non-empty-sorted-list? a)))))
 
-(define (arity? a)
+;; Originally from `unstable/function`.
-  (or (exact-nonnegative-integer? a)
+;; Originally written by Carl Eastlund
-      (and (arity-at-least? a)
-           (exact-nonnegative-integer? (arity-at-least-value a)))))
 
-;; non-empty-non-singleton-sorted-list-ending-with-arity? : xx -> boolean
+;; ryanc: adjusted limit of inner cases from 8 to 2
-;; know that 'a' is a list of at least 2 elements
+;; All uses so far seem to be predicates, so more cases seem
-(define (non-empty-non-singleton-sorted-list-ending-with-arity? a)
+;; unnecessary. Also, all uses so far are first-order, so
-  (let loop ([bound (car a)]
+;; outer case-lambda* might be better replaced with macro.
-             [lst (cdr a)])
+
+(define conjoin
+  (case-lambda*
+   [(f ... 8)
+    (make-intermediate-procedure
+     'conjoined
+      [(x (... ...) 2) (and (f x (... ...)) ...)]
+      [xs (and (apply f xs) ...)]
+      #:keyword
+      [(keys vals . args)
+       (and (keyword-apply f keys vals args) ...)])]
+   [fs
+    (make-intermediate-procedure
+     'conjoined
+     [(x ... 2) (andmap (lambda (f) (f x ...)) fs)]
+     [xs (andmap (lambda (f) (apply f xs)) fs)]
+     #:keyword
+     [(keys vals . args)
+      (andmap (lambda (f) (keyword-apply f keys vals args)) fs)])]))
+
+(define disjoin
+  (case-lambda*
+   [(f ... 8)
+    (make-intermediate-procedure
+     'disjoined
+      [(x (... ...) 2) (or (f x (... ...)) ...)]
+      [xs (or (apply f xs) ...)]
+      #:keyword
+      [(keys vals . args)
+       (or (keyword-apply f keys vals args) ...)])]
+   [fs
+    (make-intermediate-procedure
+     'disjoined
+     [(x ... 2) (ormap (lambda (f) (f x ...)) fs)]
+     [xs (ormap (lambda (f) (apply f xs)) fs)]
+     #:keyword
+     [(keys vals . args)
+      (ormap (lambda (f) (keyword-apply f keys vals args)) fs)])]))
+
+(define-syntax (make-intermediate-procedure stx)
+  (syntax-case stx [quote]
+    [(_ (quote name) positional-clause ... #:keyword keyword-clause)
+     (syntax/loc stx
+       (make-keyword-procedure
+        (let* ([name (case-lambda keyword-clause)]) name)
+        (let* ([name (case-lambda* positional-clause ...)]) name)))]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Automatic case-lambda repetition
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-for-syntax (split-syntax-at orig stx id)
+  (let loop ([found #f]
+             [seen null]
+             [stx stx])
+    (syntax-case stx []
+      [(head . tail)
+       (and (identifier? #'head)
+            (free-identifier=? #'head id))
+       (if found
+           (raise-syntax-error
+            #f
+            (format "duplicate occurrence of ~a" (syntax-e id))
+            orig
+            #'head)
+           (loop (list (reverse seen) #'head #'tail)
+                 (cons #'head seen)
+                 #'tail))]
+      [(head . tail) (loop found (cons #'head seen) #'tail)]
+      [_ found])))
+
+(define-for-syntax (expand-ellipsis-clause stx pattern expr)
   (cond
-      [(null? (cdr lst))
+   [(split-syntax-at stx pattern #'(... ...))
-       (and (arity-at-least? (car lst))
+    =>
-            (> (arity-at-least-value (car lst)) (+ 1 bound)))]
+    (lambda (found)
-      [else
+      (syntax-case found [...]
-       (and (exact-nonnegative-integer? (car lst))
+        [([pre ... repeat] (... ...) [count post ... . tail])
-            ((car lst) . > . bound)
+         (and (identifier? #'repeat)
-            (loop (car lst)
+              (exact-nonnegative-integer? (syntax-e #'count)))
-                  (cdr lst)))])))
+         (build-list
+          (add1 (syntax-e #'count))
+          (lambda (i)
+            (with-syntax ([(var ...)
+                           (generate-temporaries
+                            (build-list i (lambda (j) #'repeat)))]
+                          [body expr])
+              (list
+               (syntax/loc pattern (pre ... var ... post ... . tail))
+               (syntax/loc expr
+                 (let-syntax ([the-body
+                               (lambda _
+                                 (with-syntax ([(repeat (... ...)) #'(var ...)])
+                                   #'body))])
+                   the-body))))))]
+        [(pre mid post)
+         (raise-syntax-error
+          #f
+          "expected ellipsis between identifier and natural number literal"
+          stx
+          #'mid)]))]
+   [else (list (list pattern expr))]))
 
-(define (non-empty-sorted-list? a)
+(define-syntax (case-lambda* stx)
-  (and (pair? a)
+  (syntax-case stx []
-       (sorted-list? a)))
+    [(_ [pattern body] ...)
-
+     (with-syntax ([([pattern body] ...)
-(define (non-singleton-non-empty-sorted-list? a)
+                    (append-map
-  (and (pair? a)
+                     (lambda (p e) (expand-ellipsis-clause stx p e))
-       (pair? (cdr a))
+                     (syntax->list #'(pattern ...))
-       (sorted-list? a)))
+                     (syntax->list #'(body ...)))])
-
+       (syntax/loc stx
-(define (sorted-list? a)
+         (case-lambda [pattern body] ...)))]))
-  (or (null? a)
-      (sorted/bounded-list? (cdr a) (car a))))
-
-(define (sorted/bounded-list? a bound)
-  (or (null? a)
-      (and (number? (car a))
-           (< bound (car a))
-           (sorted/bounded-list? (cdr a) (car a)))))
-
-(define (arity-supports-number? arity n)
-  (cond
-    [(exact-nonnegative-integer? arity) (= arity n)]
-    [(arity-at-least? arity) (<= (arity-at-least-value arity) n)]
-    [(list? arity)
-     (for/or {[elem (in-list arity)]}
-       (arity-supports-number? elem n))]))
-
-(define (arity-supports-at-least? arity n)
-  (cond
-    [(exact-nonnegative-integer? arity) #f]
-    [(arity-at-least? arity) (<= (arity-at-least-value arity) n)]
-    [(list? arity)
-     (define min-at-least
-       (for/fold {[min-at-least #f]} {[elem (in-list arity)]}
-         (cond
-           [(exact-nonnegative-integer? elem) min-at-least]
-           [(arity-at-least? elem)
-            (cond
-              [(not min-at-least) (arity-at-least-value elem)]
-              [else (min min-at-least (arity-at-least-value elem))])])))
-     (cond
-       [(not min-at-least) #f]
-       [else
-        (for/and {[i (in-range n min-at-least)]}
-          (arity-supports-number? arity i))])]))
-
-(define (unchecked-arity-includes? one two)
-  (cond
-    [(exact-nonnegative-integer? two)
-     (arity-supports-number? one two)]
-    [(arity-at-least? two)
-     (arity-supports-at-least? one (arity-at-least-value two))]
-    [(list? two)
-     (for/and {[elem (in-list two)]}
-       (unchecked-arity-includes? one elem))]))
-
-(define (arity-includes? one two)
-  (unless (procedure-arity? one)
-    (raise-argument-error 'arity-includes? "procedure-arity?" 0 one two))
-  (unless (procedure-arity? two)
-    (raise-argument-error 'arity-includes? "procedure-arity?" 1 one two))
-  (unchecked-arity-includes? one two))
-
-(define (arity=? one two)
-  (unless (procedure-arity? one)
-    (raise-argument-error 'arity=? "procedure-arity?" 0 one two))
-  (unless (procedure-arity? two)
-    (raise-argument-error 'arity=? "procedure-arity?" 1 one two))
-  (and
-    (unchecked-arity-includes? one two)
-    (unchecked-arity-includes? two one)))

racket/collects/racket/private/arity.rkt

@@ -0,0 +1,107 @@
+#lang racket/base
+
+(require racket/private/norm-arity)
+
+(provide normalize-arity normalized-arity? arity=? arity-includes?)
+
+(define (normalized-arity? a)
+  (or (null? a)
+      (arity? a)
+      (and (list? a)
+           ((length a) . >= . 2)
+           (andmap arity? a)
+           (if (ormap arity-at-least? a)
+               (non-empty-non-singleton-sorted-list-ending-with-arity? a)
+               (non-singleton-non-empty-sorted-list? a)))))
+
+(define (arity? a)
+  (or (exact-nonnegative-integer? a)
+      (and (arity-at-least? a)
+           (exact-nonnegative-integer? (arity-at-least-value a)))))
+
+;; non-empty-non-singleton-sorted-list-ending-with-arity? : xx -> boolean
+;; know that 'a' is a list of at least 2 elements
+(define (non-empty-non-singleton-sorted-list-ending-with-arity? a)
+  (let loop ([bound (car a)]
+             [lst (cdr a)])
+    (cond
+      [(null? (cdr lst))
+       (and (arity-at-least? (car lst))
+            (> (arity-at-least-value (car lst)) (+ 1 bound)))]
+      [else
+       (and (exact-nonnegative-integer? (car lst))
+            ((car lst) . > . bound)
+            (loop (car lst)
+                  (cdr lst)))])))
+
+(define (non-empty-sorted-list? a)
+  (and (pair? a)
+       (sorted-list? a)))
+
+(define (non-singleton-non-empty-sorted-list? a)
+  (and (pair? a)
+       (pair? (cdr a))
+       (sorted-list? a)))
+
+(define (sorted-list? a)
+  (or (null? a)
+      (sorted/bounded-list? (cdr a) (car a))))
+
+(define (sorted/bounded-list? a bound)
+  (or (null? a)
+      (and (number? (car a))
+           (< bound (car a))
+           (sorted/bounded-list? (cdr a) (car a)))))
+
+(define (arity-supports-number? arity n)
+  (cond
+    [(exact-nonnegative-integer? arity) (= arity n)]
+    [(arity-at-least? arity) (<= (arity-at-least-value arity) n)]
+    [(list? arity)
+     (for/or {[elem (in-list arity)]}
+       (arity-supports-number? elem n))]))
+
+(define (arity-supports-at-least? arity n)
+  (cond
+    [(exact-nonnegative-integer? arity) #f]
+    [(arity-at-least? arity) (<= (arity-at-least-value arity) n)]
+    [(list? arity)
+     (define min-at-least
+       (for/fold {[min-at-least #f]} {[elem (in-list arity)]}
+         (cond
+           [(exact-nonnegative-integer? elem) min-at-least]
+           [(arity-at-least? elem)
+            (cond
+              [(not min-at-least) (arity-at-least-value elem)]
+              [else (min min-at-least (arity-at-least-value elem))])])))
+     (cond
+       [(not min-at-least) #f]
+       [else
+        (for/and {[i (in-range n min-at-least)]}
+          (arity-supports-number? arity i))])]))
+
+(define (unchecked-arity-includes? one two)
+  (cond
+    [(exact-nonnegative-integer? two)
+     (arity-supports-number? one two)]
+    [(arity-at-least? two)
+     (arity-supports-at-least? one (arity-at-least-value two))]
+    [(list? two)
+     (for/and {[elem (in-list two)]}
+       (unchecked-arity-includes? one elem))]))
+
+(define (arity-includes? one two)
+  (unless (procedure-arity? one)
+    (raise-argument-error 'arity-includes? "procedure-arity?" 0 one two))
+  (unless (procedure-arity? two)
+    (raise-argument-error 'arity-includes? "procedure-arity?" 1 one two))
+  (unchecked-arity-includes? one two))
+
+(define (arity=? one two)
+  (unless (procedure-arity? one)
+    (raise-argument-error 'arity=? "procedure-arity?" 0 one two))
+  (unless (procedure-arity? two)
+    (raise-argument-error 'arity=? "procedure-arity?" 1 one two))
+  (and
+    (unchecked-arity-includes? one two)
+    (unchecked-arity-includes? two one)))

racket/collects/racket/private/generic.rkt

@@ -5,7 +5,7 @@
                      syntax/stx
                      syntax/boundmap)
          "generic-methods.rkt"
-         (only-in racket/function arity-includes?))
+         (only-in racket/private/arity arity-includes?))
 
 (provide define-primitive-generics
          define-primitive-generics/derived