allow a static info key to have specific union and intersect operations

Default operations merge the same as `#%call-result`, and that default is useful for the shortcut of using selector identifiers as static-info keys for the selector's result. Otherwise, though, a static info key should be bound to a compile-time record that supplies union and intersection operations on values associated with the key.
racket · Mar 22, 2024 · ef71819 · ef71819
1 parent 1643409
commit ef71819
Show file tree

Hide file tree

Showing 29 changed files with 511 additions and 93 deletions.
diff --git a/info.rkt b/info.rkt
@@ -29,4 +29,4 @@
     "gui-easy"
     "compatibility"))
 
-(define version "0.24")
+(define version "0.25")
diff --git a/rhombus/private/append-key.rkt b/rhombus/private/append-key.rkt
@@ -1,5 +1,7 @@
 #lang racket/base
+(require (for-syntax racket/base)
+         "static-info.rkt")
 
-(provide #%append)
-
-(define #%append #f)
+(define-static-info-key-syntax/provide #%append
+  (static-info-key static-info-identifier-union
+                   static-info-identifier-intersect))
diff --git a/rhombus/private/call-result-key.rkt b/rhombus/private/call-result-key.rkt
@@ -1,7 +1,7 @@
 #lang racket/base
+(require (for-syntax racket/base)
+         "static-info.rkt")
 
-(provide #%call-result
-         #%call-results-at-arities)
-
-(define #%call-result #f)
-(define #%call-results-at-arities #f)
+(define-static-info-key-syntax/provide #%call-result
+  (static-info-key static-infos-result-union
+                   static-infos-result-intersect))
diff --git a/rhombus/private/class-annotation.rkt b/rhombus/private/class-annotation.rkt
@@ -6,6 +6,7 @@
          (submod "annot-macro.rkt" for-class)
          (for-syntax "class-transformer.rkt")
          (submod "dot.rkt" for-dot-provider)
+         "dot-provider-key.rkt"
          "dotted-sequence-parse.rkt")
 
 (provide (for-syntax build-class-annotation-form

diff --git a/rhombus/private/class-binding.rkt b/rhombus/private/class-binding.rkt
@@ -6,6 +6,7 @@
                      (only-in enforest/operator operator-proc)
                      "srcloc.rkt")
          "binding.rkt"
+         "dot-provider-key.rkt"
          (submod "bind-macro.rkt" for-class)
          "composite.rkt"
          "parens.rkt"

diff --git a/rhombus/private/class-method-result.rkt b/rhombus/private/class-method-result.rkt
@@ -126,7 +126,7 @@
            (define all-static-infos
              (if all-count
                  (for/foldr ([all-static-infoss (for/list ([_ (in-range all-count)])
-                                                  '())]
+                                                  #'())]
                              #:result (if (eqv? all-count 1)
                                           #`#,(car all-static-infoss)
                                           #`((#%values #,all-static-infoss))))
@@ -146,9 +146,10 @@
      (define (gen id [de-method? #f])
        (if (syntax-e id)
            (list #`(define-static-info-syntax #,id
-                     #,(if (eq? (syntax-e #'kind) 'property)
-                           #`(#%call-results-at-arities ((#,(if de-method? 0 1) #,all-static-infos)))
-                           #`(#%call-result #,all-static-infos))
+                     (#%call-result
+                      #,(if (eq? (syntax-e #'kind) 'property)
+                            #`(#:at_arities ((#,(arithmetic-shift 1 (if de-method? 0 1)) #,all-static-infos)))
+                            all-static-infos))
                      #,@(if (syntax-e #'arity)
                             (list #`(#%function-arity #,(if de-method?
                                                             (de-method-arity #'arity)

diff --git a/rhombus/private/class-method.rkt b/rhombus/private/class-method.rkt
@@ -20,6 +20,7 @@
          "static-info.rkt"
          "indirect-static-info-key.rkt"
          (submod "dot.rkt" for-dot-provider)
+         "dot-provider-key.rkt"
          (submod "assign.rkt" for-assign)
          "parens.rkt"
          (submod "function-parse.rkt" for-call)

diff --git a/rhombus/private/class-primitive.rkt b/rhombus/private/class-primitive.rkt
@@ -13,6 +13,7 @@
          "dot-parse.rkt"
          "function-arity-key.rkt"
          "call-result-key.rkt"
+         "dot-provider-key.rkt"
          "composite.rkt"
          "class-desc.rkt"
          "define-arity.rkt"

diff --git a/rhombus/private/class-static-info.rkt b/rhombus/private/class-static-info.rkt
@@ -11,6 +11,7 @@
          "call-result-key.rkt"
          "function-arity-key.rkt"
          "function-arity.rkt"
+         "dot-provider-key.rkt"
          "static-info.rkt"
          "class-able.rkt")
 
@@ -154,7 +155,7 @@
                                               [si (syntax->list #'(public-field-static-infos ...))])
                                      (append
                                       (if (syntax-e maybe-set)
-                                          (list #`(#%call-results-at-arities ((1 #,si)))
+                                          (list #`(#%call-result (#:at_arities ((2 #,si))))
                                                 #'(#%function-arity 6))
                                           (list #`(#%call-result #,si)
                                                 #'(#%function-arity 2)))

diff --git a/rhombus/private/dot-provider-key.rkt b/rhombus/private/dot-provider-key.rkt
@@ -1,5 +1,7 @@
 #lang racket/base
+(require (for-syntax racket/base)
+         "static-info.rkt")
 
-(provide #%dot-provider)
-
-(define #%dot-provider #f)
+(define-static-info-key-syntax/provide #%dot-provider
+  (static-info-key static-info-identifier-union
+                   static-info-identifier-intersect))
diff --git a/rhombus/private/dot.rkt b/rhombus/private/dot.rkt
@@ -31,7 +31,6 @@
 
              in-dot-provider-space))
   (provide define-dot-provider-syntax
-           #%dot-provider
            prop:field-name->accessor
            prop:field-name->mutator
            curry-method))

diff --git a/rhombus/private/function-arity-key.rkt b/rhombus/private/function-arity-key.rkt
@@ -1,5 +1,10 @@
 #lang racket/base
+(require (for-syntax racket/base)
+         "static-info.rkt"
+         "function-arity.rkt")
 
-(provide #%function-arity)
-
-(define #%function-arity #f)
+(define-static-info-key-syntax/provide #%function-arity
+  (static-info-key (lambda (a b)
+                     (union-arity-summaries (list (syntax->datum a) (syntax->datum b))))
+                   (lambda (a b)
+                     (intersect-arity-summaries (list (syntax->datum a) (syntax->datum b))))))
diff --git a/rhombus/private/function-arity.rkt b/rhombus/private/function-arity.rkt
@@ -8,8 +8,14 @@
 (provide (for-syntax summarize-arity
                      shift-arity
                      union-arity-summaries
+                     intersect-arity-summaries
                      check-arity))
 
+;; A function arity description is one of
+;;  <mask>
+;;  (<mask> (<required-kw> ...) (<allowed-kw> ...))
+;;  (<mask> (<required-kw> ...) #f) ; = all allowed
+
 (define-for-syntax (summarize-arity kws defaults rest? kw-rest?)
   (define (syntax->list/maybe stx)
     (if (syntax? stx) (syntax->list stx) stx))
@@ -74,7 +80,7 @@
     (for/fold ([a a]) ([k (in-immutable-hash-keys b)])
       (hash-set a k #t))))
 
-(define-for-syntax (union-arity-summaries as)
+(define-for-syntax (combine-arity-summaries as combine)
   (cond
     [(null? as) #f]
     [(null? (cdr as)) (car as)]
@@ -85,17 +91,30 @@
            (list a #hasheq() #hasheq())))
      (define norm-a
        (for/fold ([new-a (normalize (car as))]) ([a (in-list (cdr as))])
-         (let ([a (normalize a)])
-           (list (bitwise-ior (car new-a) (car a))
-                 (hash-intersect (cadr new-a) (cadr a))
-                 (and (caddr new-a) (caddr a) (hash-union (caddr new-a) (caddr a)))))))
+         (combine new-a (normalize a))))
      (define required-kws (hash->list (cadr norm-a)))
      (define allowed-kws (and (caddr norm-a) (hash->list (caddr norm-a))))
      (if (and (null? required-kws)
               (null? allowed-kws))
          (car norm-a)
          (list (car norm-a) required-kws allowed-kws))]))
 
+(define-for-syntax (union-arity-summaries as)
+  (combine-arity-summaries
+   as
+   (lambda (new-a a)
+     (list (bitwise-ior (car new-a) (car a))
+           (hash-intersect (cadr new-a) (cadr a))
+           (and (caddr new-a) (caddr a) (hash-union (caddr new-a) (caddr a)))))))
+
+(define-for-syntax (intersect-arity-summaries as)
+  (combine-arity-summaries
+   as
+   (lambda (new-a a)
+     (list (bitwise-and (car new-a) (car a))
+           (hash-union (cadr new-a) (cadr a))
+           (and (caddr new-a) (caddr a) (hash-intersect (caddr new-a) (caddr a)))))))
+
 (define-for-syntax (check-arity stx fallback-stx a n kws rsts kwrsts kind)
   (define orig-needed (if (pair? a)
                           (list->hash (cadr a))

diff --git a/rhombus/private/function-parse.rkt b/rhombus/private/function-parse.rkt
@@ -1032,18 +1032,20 @@
          (define e (relocate+reraw (or srcloc
                                        (respan (datum->syntax #f (list (or rator-stx rator-in) args-stx))))
                                    (datum->syntax #'here (map discard-static-infos es) #f props-stx)))
-         (define result-static-infos (or (rator-static-info #'#%call-result)
+         (define result-static-infos (or (let ([results (rator-static-info #'#%call-result)])
+                                           (and results
+                                                (syntax-parse results
+                                                  [(#:at_arities r)
+                                                   (let loop ([r #'r])
+                                                     (syntax-parse r
+                                                       [((mask results) . rest)
+                                                        (if (bitwise-bit-set? (syntax-e #'mask) (+ num-rands (length extra-rands)))
+                                                            #'results
+                                                            (loop #'rest))]
+                                                       [_ #f]))]
+                                                  [results #'results])))
                                          #'()))
-         (define all-result-static-infos (or (let ([r (rator-static-info #'#%call-results-at-arities)])
-                                               (let loop ([r r])
-                                                 (syntax-parse r
-                                                   [((n (result ...)) . rest)
-                                                    (if (equal? (syntax-e #'n) (+ num-rands (length extra-rands)))
-                                                        #`(result ... . #,result-static-infos)
-                                                        (loop #'rest))]
-                                                   [_ #f])))
-                                             result-static-infos))
-         (values e all-result-static-infos)))])
+         (values e result-static-infos)))])
    tail))
 
 (define-for-syntax (handle-repetition repetition?

diff --git a/rhombus/private/function.rkt b/rhombus/private/function.rkt
@@ -8,6 +8,7 @@
          "provide.rkt"
          (submod "function-parse.rkt" for-build)
          (submod "list.rkt" for-compound-repetition)
+         (only-in "implicit.rkt" #%literal)
          "parens.rkt"
          "expression.rkt"
          "definition.rkt"
@@ -198,7 +199,15 @@
                                                     (raise-syntax-error #f "duplicate keyword" kw #f))
                                                   (hash-set ht kw #t))
                                                 #`(#t (accepts-keywords? v '#,(sort (map syntax-e kws) keyword<?)))]))]
-                        [(n ...) (generate-temporaries #'(g ...))])
+                        [(n ...) (generate-temporaries #'(g ...))]
+                        [(function-arity-static ...) (syntax-parse #'(g ...)
+                                                       #:datum-literals (group)
+                                                       [((group n:exact-nonnegative-integer))
+                                                        #:when (free-identifier=? #'#%literal (datum->syntax #'n '#%literal))
+                                                        #`((#%function-arity (#,(arithmetic-shift 1 (syntax-e #'n))
+                                                                              ()
+                                                                              (kw ...))))]
+                                                       [_ #'()])])
             (values (annotation-predicate-form
                      #'(let ([n (rhombus-expression g)]
                              ...)
@@ -209,7 +218,7 @@
                                 (procedure-arity-includes? v n kw-ok?)
                                 ...
                                 kw-check)))
-                     function-static-infos)
+                     #`(function-arity-static ... . #,function-static-infos))
                     #'tail)))]))))
 
 (define (check-nonneg-int who v)

diff --git a/rhombus/private/index-key.rkt b/rhombus/private/index-key.rkt
@@ -1,7 +1,11 @@
 #lang racket/base
+(require (for-syntax racket/base)
+         "static-info.rkt")
 
-(provide #%index-get
-         #%index-set)
+(define-static-info-key-syntax/provide #%index-get
+  (static-info-key static-info-identifier-union
+                   static-info-identifier-intersect))
 
-(define #%index-get #f)
-(define #%index-set #f)
+(define-static-info-key-syntax/provide #%index-set
+  (static-info-key static-info-identifier-union
+                   static-info-identifier-intersect))
diff --git a/rhombus/private/index-result-key.rkt b/rhombus/private/index-result-key.rkt
@@ -1,5 +1,7 @@
 #lang racket/base
+(require (for-syntax racket/base)
+         "static-info.rkt")
 
-(provide #%index-result)
-
-(define #%index-result #f)
+(define-static-info-key-syntax/provide #%index-result
+  (static-info-key static-infos-union
+                   static-infos-intersect))
diff --git a/rhombus/private/indirect-static-info-key.rkt b/rhombus/private/indirect-static-info-key.rkt
@@ -1,5 +1,5 @@
 #lang racket/base
+(require "static-info.rkt")
 
 (provide #%indirect-static-info)
 
-(define #%indirect-static-info #f)
diff --git a/rhombus/private/interface.rkt b/rhombus/private/interface.rkt
@@ -23,6 +23,7 @@
          "class-step.rkt"
          "class-static-info.rkt"
          "dotted-sequence-parse.rkt"
+         "dot-provider-key.rkt"
          (for-syntax "class-transformer.rkt")
          (only-meta-in 1
                        "class-method.rkt")

diff --git a/rhombus/private/sequence-constructor-key.rkt b/rhombus/private/sequence-constructor-key.rkt
@@ -1,5 +1,7 @@
 #lang racket/base
+(require (for-syntax racket/base)
+         "static-info.rkt")
 
-(provide #%sequence-constructor)
-
-(define #%sequence-constructor #f)
+(define-static-info-key-syntax/provide #%sequence-constructor
+  (static-info-key static-info-identifier-union
+                   static-info-identifier-intersect))
diff --git a/rhombus/private/sequence-element-key.rkt b/rhombus/private/sequence-element-key.rkt
@@ -1,5 +1,7 @@
 #lang racket/base
+(require (for-syntax racket/base)
+         "static-info.rkt")
 
-(provide #%sequence-element)
-
-(define #%sequence-element #f)
+(define-static-info-key-syntax/provide #%sequence-element
+  (static-info-key static-infos-union
+                   static-infos-intersect))