diff --git a/pkgs/racket-doc/scribblings/reference/contract-util.rkt b/pkgs/racket-doc/scribblings/reference/contract-util.rkt deleted file mode 100644 index ba361b2aba..0000000000 --- a/pkgs/racket-doc/scribblings/reference/contract-util.rkt +++ /dev/null @@ -1,27 +0,0 @@ -#lang racket/base -(require scribble/manual) - -(provide add-use-sources declare-exporting-ctc) - -(define-syntax-rule - (add-use-sources (x y ...)) - (x y ... - #:use-sources - (racket/contract/private/base - racket/contract/private/misc - racket/contract/private/provide - racket/contract/private/guts - racket/contract/private/prop - racket/contract/private/blame - racket/contract/private/ds - racket/contract/private/opt - racket/contract/private/basic-opters - - racket/contract/private/box - racket/contract/private/hash - racket/contract/private/vector - racket/contract/private/struct-dc))) - -(define-syntax-rule - (declare-exporting-ctc mod) - (add-use-sources (declare-exporting mod racket/contract racket))) diff --git a/racket/collects/racket/contract/private/application-arity-checking.rkt b/racket/collects/racket/contract/private/application-arity-checking.rkt index bc6e651230..f8cf5ec8a9 100644 --- a/racket/collects/racket/contract/private/application-arity-checking.rkt +++ b/racket/collects/racket/contract/private/application-arity-checking.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require (for-template racket/base)) + #| Used to check an application site of a well-known @@ -13,8 +13,7 @@ a valid-app-shape. |# (provide (struct-out valid-app-shapes) - valid-argument-list? - generate-medium-speed-wrapper) + valid-argument-list?) ;; valid-arities : (or/c (listof nat) (improper-listof nat)) ;; -- if improper, then the last nat indicates that any number @@ -64,42 +63,6 @@ a valid-app-shape. ans?] [else #t])) -;; called in the case that the identifier isn't used directly in an -;; application. Try to generate a case-lambda that can still avoid -;; the chaperone creation -(define (generate-medium-speed-wrapper the-valid-app-shape - chaperone-expr - extra-arg-function - neg-party-id - add-medium-speed-kwd-wrapper-id - expected-name) - (cond - [(and the-valid-app-shape - (null? (valid-app-shapes-mandatory-kwds the-valid-app-shape)) - (null? (valid-app-shapes-optional-kwds the-valid-app-shape))) - (define chaperone-expr-id (car (generate-temporaries '(medium-speed-wrapper)))) - (define (mk-n-ids n) (generate-temporaries (build-list n (λ (x) 'medium-speed-wrapper-arg)))) - (define case-lambda-clauses - (let loop ([valid-arities (valid-app-shapes-valid-arities the-valid-app-shape)]) - (cond - [(null? valid-arities) - (list #`[args (apply #,chaperone-expr-id args)])] - [(number? valid-arities) - (with-syntax ([(x ...) (mk-n-ids valid-arities)] - [(rest-arg) (generate-temporaries '(medium-speed-wrapper-dot-arg))]) - (list - #`[(x ... . rest-arg) (apply #,extra-arg-function #,neg-party-id x ... rest-arg)]))] - [else - (with-syntax ([(x ...) (mk-n-ids (car valid-arities))]) - (cons #`[(x ...) (#,extra-arg-function #,neg-party-id x ...)] - (loop (cdr valid-arities))))]))) - #`(let ([#,chaperone-expr-id #,chaperone-expr]) - (#,add-medium-speed-kwd-wrapper-id - #,chaperone-expr-id - (let ([#,expected-name (case-lambda #,@case-lambda-clauses)]) - #,expected-name)))] - [else chaperone-expr])) - (define-logger optimizer) (define (log-problem stx) (log-optimizer-warning diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt index 1469936117..066c37d0f9 100644 --- a/racket/collects/racket/contract/private/provide.rkt +++ b/racket/collects/racket/contract/private/provide.rkt @@ -88,8 +88,7 @@ (saved-ho-id-table partially-applied-id extra-neg-party-argument-fn - valid-argument-lists - ex-id) + valid-argument-lists) #:property prop:set!-transformer (λ (self stx) @@ -97,9 +96,8 @@ [saved-ho-id-table (provide/contract-arrow-transformer-saved-ho-id-table self)] [extra-neg-party-argument-fn (provide/contract-arrow-transformer-extra-neg-party-argument-fn self)] - [the-valid-arg-shapes (provide/contract-arrow-transformer-valid-argument-lists self)] - [rename-id (provide/contract-info-rename-id self)] - [ex-id (provide/contract-arrow-transformer-ex-id self)]) + [valid-arg-lists (provide/contract-arrow-transformer-valid-argument-lists self)] + [rename-id (provide/contract-info-rename-id self)]) (with-syntax ([partially-applied-id partially-applied-id] [extra-neg-party-argument-fn extra-neg-party-argument-fn]) (if (eq? 'expression (syntax-local-context)) @@ -126,15 +124,7 @@ (add-rename-id rename-id (syntax-local-lift-expression (add-lifted-property - (generate-medium-speed-wrapper - the-valid-arg-shapes - #'(partially-applied-id lifted-neg-party) - (add-neg-party (add-rename-id - rename-id - #'extra-neg-party-argument-fn)) - #'lifted-neg-party - #'add-medium-speed-kwd-wrapper - ex-id)))))))) + #'(partially-applied-id lifted-neg-party)))))))) (when key (hash-set! saved-ho-id-table key lifted-ctc-val)) (adjust-location (syntax-local-introduce lifted-ctc-val))) (syntax-case stx (set!) @@ -148,7 +138,7 @@ stx #'id)] [(name more ...) (with-syntax ([app (datum->syntax stx '#%app)]) - (if (valid-argument-list? stx the-valid-arg-shapes) + (if (valid-argument-list? stx valid-arg-lists) (with-syntax ([lifted-neg-party (syntax-local-introduce lifted-neg-party)]) (adjust-location #`(app #,(add-neg-party (add-rename-id @@ -219,27 +209,12 @@ #`(app #,id args ...))] [x (identifier? #'x) id]))))) - (define (make-provide/contract-arrow-transformer rename-id contract-id id pai enpfn val ex-id) + (define (make-provide/contract-arrow-transformer rename-id contract-id id pai enpfn val) (provide/contract-arrow-transformer rename-id contract-id id (make-hasheq) - pai enpfn val ex-id))) + pai enpfn val))) -(define (add-medium-speed-kwd-wrapper chapone-contracted-proc no-keywords-path) - (make-keyword-procedure - (λ (kwds kwd-args . args) - (keyword-apply chapone-contracted-proc kwds kwd-args args)) - no-keywords-path)) - -(define-syntax (maybe-add-name stx) - (syntax-case stx () - [(_ expr) - (let () - (define name (syntax-local-name)) - (printf "name! ~s\n" name) - (if (symbol? name) - #`(let ([#,name expr]) #,name) - #'expr))])) ;; tl-code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax) ;; given the syntax for an identifier and a contract, @@ -342,8 +317,7 @@ (quote-syntax contract-id) (quote-syntax id) (quote-syntax partially-applied-id) (quote-syntax extra-neg-party-argument-fn) - #,the-valid-app-shapes - '#,ex-id) + #,the-valid-app-shapes) #`(make-provide/contract-transformer (quote-syntax #,id-rename) (quote-syntax contract-id) (quote-syntax id)