From e3b5ba8ef80c6212282c45598a88f5ba82feddbd Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 29 Jun 2005 23:33:51 +0000 Subject: [PATCH] moved contract library to private, in order to export a few more names to special places svn: r272 --- collects/mzlib/contract.ss | 3239 +-------------------------- collects/mzlib/private/contract.ss | 3240 ++++++++++++++++++++++++++++ 2 files changed, 3246 insertions(+), 3233 deletions(-) create mode 100644 collects/mzlib/private/contract.ss diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 0ecd64b65b..7ade2523d6 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -1,3234 +1,7 @@ -#| - -improve method arity mismatch contract violation error messages? - (abstract out -> and friends even more?) - -add struct contracts for immutable structs? - -|# - (module contract mzscheme - - (provide (rename -contract contract) - any - recursive-contract - -> - ->d - ->* - ->d* - ->r - ->pp - ->pp-rest - case-> - opt-> - opt->* - object-contract - provide/contract - define/contract - contract? - contract-name - flat-contract? - flat-contract - flat-contract-predicate - flat-named-contract - - contract-proc) - - (require-for-syntax mzscheme - "list.ss" - (lib "stx.ss" "syntax") - (lib "name.ss" "syntax")) - - (require "private/class-internal.ss" - "etc.ss" - "list.ss" - "pretty.ss") - - (require (lib "contract-helpers.scm" "mzlib" "private")) - (require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private"))) - - - -; -; -; -; ; ;;; ; ; -; ; ; ; -; ; ; ; ; ; -; ;; ; ;;; ;;;; ; ; ;; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; -; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;; ; ;;;; ; ; ; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; -; ; -; ; -; - - - ;; (define/contract id contract expr) - ;; defines `id' with `contract'; initially binding - ;; it to the result of `expr'. These variables may not be set!'d. - (define-syntax (define/contract define-stx) - (syntax-case define-stx () - [(_ name contract-expr expr) - (identifier? (syntax name)) - (with-syntax ([pos-blame-stx (datum->syntax-object define-stx 'here)] - [contract-id - (a:mangle-id define-stx - "define/contract-contract-id" - (syntax name))] - [id (a:mangle-id define-stx - "define/contract-id" - (syntax name))]) - (syntax/loc define-stx - (begin - (define contract-id contract-expr) - (define-syntax name - (make-set!-transformer - (lambda (stx) - (with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")]) - (syntax-case stx (set!) - [(set! _ arg) - (raise-syntax-error 'define/contract - "cannot set! a define/contract variable" - stx - (syntax _))] - [(_ arg (... ...)) - (syntax/loc stx - ((-contract contract-id - id - (syntax-object->datum (quote-syntax _)) - (string->symbol neg-blame-str) - (quote-syntax _)) - arg - (... ...)))] - [_ - (identifier? (syntax _)) - (syntax/loc stx - (-contract contract-id - id - (syntax-object->datum (quote-syntax _)) - (string->symbol neg-blame-str) - (quote-syntax _)))]))))) - (define id (let ([name expr]) name)) ;; let for procedure naming - )))] - [(_ name contract-expr expr) - (raise-syntax-error 'define/contract "expected identifier in first position" - define-stx - (syntax name))])) - - -; -; -; -; ; ; ; -; ; ; -; ; ; ; ; -; ; ;; ; ; ;;; ; ; ; ;; ; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; -; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ;; ; ;;; ; ; ;; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; -; ; ; -; ; ; -; ; - - - ;; (provide/contract p/c-ele ...) - ;; p/c-ele = (id expr) | (rename id id expr) | (struct (id expr) ...) - ;; provides each `id' with the contract `expr'. - (define-syntax (provide/contract provide-stx) - (syntax-case provide-stx (struct) - [(_ p/c-ele ...) - (let () - - ;; code-for-each-clause : (listof syntax) -> (listof syntax) - ;; constructs code for each clause of a provide/contract - (define (code-for-each-clause clauses) - (cond - [(null? clauses) null] - [else - (let ([clause (car clauses)]) - (syntax-case clause (struct rename) - [(rename this-name new-name contract) - (and (identifier? (syntax this-name)) - (identifier? (syntax new-name))) - (cons (code-for-one-id provide-stx (syntax this-name) (syntax contract) (syntax new-name)) - (code-for-each-clause (cdr clauses)))] - [(rename this-name new-name contract) - (identifier? (syntax this-name)) - (raise-syntax-error 'provide/contract - "malformed rename clause, expected an identifier" - provide-stx - (syntax new-name))] - [(rename this-name new-name contract) - (identifier? (syntax new-name)) - (raise-syntax-error 'provide/contract - "malformed rename clause, expected an identifier" - provide-stx - (syntax this-name))] - [(rename . _) - (raise-syntax-error 'provide/contract "malformed rename clause" provide-stx clause)] - [(struct struct-name ((field-name contract) ...)) - (and (well-formed-struct-name? (syntax struct-name)) - (andmap identifier? (syntax->list (syntax (field-name ...))))) - (let ([sc (build-struct-code provide-stx - (syntax struct-name) - (syntax->list (syntax (field-name ...))) - (syntax->list (syntax (contract ...))))]) - (cons sc (code-for-each-clause (cdr clauses))))] - [(struct name) - (identifier? (syntax name)) - (raise-syntax-error 'provide/contract - "missing fields" - provide-stx - clause)] - [(struct name . rest) - (not (well-formed-struct-name? (syntax name))) - (raise-syntax-error 'provide/contract "name must be an identifier or two identifiers with parens around them" - provide-stx - (syntax name))] - [(struct name (fields ...)) - (for-each (lambda (field) - (syntax-case field () - [(x y) - (identifier? (syntax x)) - (void)] - [(x y) - (raise-syntax-error 'provide/contract - "malformed struct field, expected identifier" - provide-stx - (syntax x))] - [else - (raise-syntax-error 'provide/contract - "malformed struct field" - provide-stx - field)])) - (syntax->list (syntax (fields ...)))) - - ;; if we didn't find a bad field something is wrong! - (raise-syntax-error 'provide/contract "internal error" provide-stx clause)] - [(struct name . fields) - (raise-syntax-error 'provide/contract - "malformed struct fields" - provide-stx - clause)] - [(name contract) - (identifier? (syntax name)) - (cons (code-for-one-id provide-stx (syntax name) (syntax contract) #f) - (code-for-each-clause (cdr clauses)))] - [(name contract) - (raise-syntax-error 'provide/contract - "expected identifier" - provide-stx - (syntax name))] - [unk - (raise-syntax-error 'provide/contract - "malformed clause" - provide-stx - (syntax unk))]))])) - - ;; well-formed-struct-name? : syntax -> bool - (define (well-formed-struct-name? stx) - (or (identifier? stx) - (syntax-case stx () - [(name super) - (and (identifier? (syntax name)) - (identifier? (syntax super))) - #t] - [else #f]))) - - ;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax - ;; constructs the code for a struct clause - ;; first arg is the original syntax object, for source locations - (define (build-struct-code stx struct-name-position field-names field-contracts) - (let* ([struct-name (syntax-case struct-name-position () - [(a b) (syntax a)] - [else struct-name-position])] - [parent-struct-count (let ([parent-info (extract-parent-struct-info struct-name-position)]) - (and parent-info - (let ([fields (cadddr parent-info)]) - (cond - [(null? fields) 0] - [(not (car (last-pair fields))) - (raise-syntax-error - 'provide/contract - "cannot determine the number of fields in super struct" - provide-stx - struct-name)] - [else (length fields)]))))] - [field-contract-ids (map (lambda (field-name) - (a:mangle-id provide-stx - "provide/contract-field-contract" - field-name - struct-name)) - field-names)] - [selector-ids (map (lambda (field-name) - (build-selector-id struct-name field-name)) - field-names)] - [mutator-ids (map (lambda (field-name) - (build-mutator-id struct-name field-name)) - field-names)] - [predicate-id (build-predicate-id struct-name)] - [constructor-id (build-constructor-id struct-name)]) - (with-syntax ([(selector-codes ...) - (filter - (lambda (x) x) - (map/count (lambda (selector-id field-contract-id index) - (if (or (not parent-struct-count) - (parent-struct-count . <= . index)) - (code-for-one-id stx - selector-id - (build-selector-contract struct-name - predicate-id - field-contract-id) - #f) - #f)) - selector-ids - field-contract-ids))] - [(mutator-codes ...) - (filter - (lambda (x) x) - (map/count (lambda (mutator-id field-contract-id index) - (if (or (not parent-struct-count) - (parent-struct-count . <= . index)) - (code-for-one-id stx - mutator-id - (build-mutator-contract struct-name - predicate-id - field-contract-id) - #f) - #f)) - mutator-ids - field-contract-ids))] - [predicate-code (code-for-one-id stx predicate-id (syntax (-> any/c boolean?)) #f)] - [constructor-code (code-for-one-id - stx - constructor-id - (build-constructor-contract stx - field-contract-ids - predicate-id) - #f)] - [(field-contracts ...) field-contracts] - [(field-contract-ids ...) field-contract-ids] - [struct-name struct-name] - [struct:struct-name (datum->syntax-object - struct-name - (string->symbol - (string-append - "struct:" - (symbol->string (syntax-e struct-name)))))]) - (syntax/loc stx - (begin - (define field-contract-ids field-contracts) ... - selector-codes ... - mutator-codes ... - predicate-code - constructor-code - (provide struct-name struct:struct-name)))))) - - ;; map/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z) - (define (map/count f l1 l2) - (let loop ([l1 l1] - [l2 l2] - [i 0]) - (cond - [(and (null? l1) (null? l2)) '()] - [(or (null? l1) (null? l2)) (error 'map/count "mismatched lists")] - [else (cons (f (car l1) (car l2) i) - (loop (cdr l1) - (cdr l2) - (+ i 1)))]))) - - ;; extract-parent-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) - (define (extract-parent-struct-info stx) - (syntax-case stx () - [(a b) - (syntax-local-value - (syntax b) - (lambda () - (raise-syntax-error 'provide/contract - "expected a struct name" - provide-stx - (syntax b))))] - [a #f])) - - ;; build-constructor-contract : syntax (listof syntax) syntax -> syntax - (define (build-constructor-contract stx field-contract-ids predicate-id) - (with-syntax ([(field-contract-ids ...) field-contract-ids] - [predicate-id predicate-id]) - (syntax/loc stx - (field-contract-ids - ... - . -> . - (let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id))))) - - ;; build-selector-contract : syntax syntax -> syntax - ;; constructs the contract for a selector - (define (build-selector-contract struct-name predicate-id field-contract-id) - (with-syntax ([field-contract-id field-contract-id] - [predicate-id predicate-id]) - (syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id) - . -> . - field-contract-id)))) - - ;; build-mutator-contract : syntax syntax -> syntax - ;; constructs the contract for a selector - (define (build-mutator-contract struct-name predicate-id field-contract-id) - (with-syntax ([field-contract-id field-contract-id] - [predicate-id predicate-id]) - (syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id) - field-contract-id - . -> . - void?)))) - - ;; build-constructor-id : syntax -> syntax - ;; constructs the name of the selector for a particular field of a struct - (define (build-constructor-id struct-name) - (datum->syntax-object - struct-name - (string->symbol - (string-append - "make-" - (symbol->string (syntax-object->datum struct-name)))))) - - ;; build-predicate-id : syntax -> syntax - ;; constructs the name of the selector for a particular field of a struct - (define (build-predicate-id struct-name) - (datum->syntax-object - struct-name - (string->symbol - (string-append - (symbol->string (syntax-object->datum struct-name)) - "?")))) - - ;; build-selector-id : syntax syntax -> syntax - ;; constructs the name of the selector for a particular field of a struct - (define (build-selector-id struct-name field-name) - (datum->syntax-object - struct-name - (string->symbol - (string-append - (symbol->string (syntax-object->datum struct-name)) - "-" - (symbol->string (syntax-object->datum field-name)))))) - - ;; build-mutator-id : syntax syntax -> syntax - ;; constructs the name of the selector for a particular field of a struct - (define (build-mutator-id struct-name field-name) - (datum->syntax-object - struct-name - (string->symbol - (string-append - "set-" - (symbol->string (syntax-object->datum struct-name)) - "-" - (symbol->string (syntax-object->datum field-name)) - "!")))) - - ;; code-for-one-id : syntax syntax syntax (union syntax #f) -> syntax - ;; given the syntax for an identifier and a contract, - ;; builds a begin expression for the entire contract and provide - ;; the first syntax object is used for source locations - (define (code-for-one-id stx id ctrct user-rename-id) - (with-syntax ([id-rename (a:mangle-id provide-stx "provide/contract-id" id)] - [contract-id (a:mangle-id provide-stx "provide/contract-contract-id" id)] - [pos-module-source (a:mangle-id provide-stx "provide/contract-pos-module-source" id)] - [pos-stx (datum->syntax-object provide-stx 'here)] - [id id] - [ctrct ctrct]) - (with-syntax ([provide-clause (if user-rename-id - (with-syntax ([user-rename-id user-rename-id]) - (syntax (provide (rename id-rename user-rename-id)))) - (syntax (provide (rename id-rename id))))]) - (syntax/loc stx - (begin - provide-clause - - ;; unbound id check - (if #f id) - - (define pos-module-source (module-source-as-symbol #'pos-stx)) - (define contract-id (let ([id ctrct]) id)) - (define-syntax id-rename - (make-set!-transformer - (lambda (stx) - (with-syntax ([neg-stx (datum->syntax-object stx 'here)]) - (syntax-case stx (set!) - [(set! _ body) (raise-syntax-error - #f - "cannot set! provide/contract identifier" - stx - (syntax _))] - [(_ arg (... ...)) - (syntax - ((begin-lifted - (-contract contract-id - id - pos-module-source - (module-source-as-symbol #'neg-stx) - (quote-syntax _))) - arg - (... ...)))] - [_ - (identifier? (syntax _)) - (syntax - (begin-lifted - (-contract contract-id - id - pos-module-source - (module-source-as-symbol #'neg-stx) - (quote-syntax _))))])))))))))) - - (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))]) - (syntax - (begin - bodies ...))))])) - - - ; - ; - ; - ; - ; - ; ; ; - ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; - ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ;;;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; - ; - ; - ; - - ;; contract = (make-contract sexp - ;; (sym - ;; sym - ;; (union syntax #f) - ;; string - ;; -> - ;; (alpha -> alpha))) - ;; the first arg to make-contract builds the name of the contract. The - ;; path records how the violation occurs - ;; - ;; generic contract container; - ;; the first arg to proc is a symbol representing the name of the positive blame - ;; the second arg to proc is the symbol representing the name of the negative blame - ;; the third argument to proc is the src-info. - ;; the fourth argumet is a textual representation of the original contract - ;; - ;; the argument to the result function is the value to test. - ;; (the result function is the projection) - ;; - (define-values (make-flat-contract - flat-contract-predicate - flat-contract? - - make-contract - contract-name - contract-proc - contract?) - (let () - (define-struct contract (name proc)) - (define-struct (flat-contract contract) (predicate)) - (values make-flat-contract - flat-contract-predicate - flat-contract? - - make-contract - contract-name - contract-proc - contract?))) - - (define (test-proc/flat-contract f x) - (if (flat-contract? f) - ((flat-contract-predicate f) x) - (f x))) - - (define (proc/ctc->ctc f) - (if (contract? f) - f - (flat-named-contract - (or (object-name f) - (string->symbol (format "contract:~e" f))) - f))) - - - - ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) - (define (build-compound-type-name . fs) - (let loop ([subs fs] - [i 0]) - (cond - [(null? subs) - '()] - [else (let ([sub (car subs)]) - (cond - [(contract? sub) - (let ([mk-sub-name (contract-name sub)]) - `(,mk-sub-name ,@(loop (cdr subs) (+ i 1))))] - [else `(,sub ,@(loop (cdr subs) i))]))]))) - - (define (flat-contract predicate) - (unless (and (procedure? predicate) - (procedure-arity-includes? predicate 1)) - (error 'flat-contract - "expected procedure of one argument as argument, given ~e" - predicate)) - (let ([pname (object-name predicate)]) - (if pname - (flat-named-contract pname predicate) - (flat-named-contract '??? predicate)))) - - (define (flat-named-contract name predicate) - (unless (and (procedure? predicate) - (procedure-arity-includes? predicate 1)) - (error 'flat-named-contract - "expected procedure of one argument as second argument, given: ~e, fst arg ~e" - predicate name)) - (build-flat-contract name predicate)) - - (define (build-flat-contract name predicate) - (make-flat-contract - name - (lambda (pos neg src-info orig-str) - (lambda (val) - (if (predicate val) - val - (raise-contract-error - src-info - pos - neg - orig-str - "expected <~a>, given: ~e" - name - val)))) - predicate)) - - (define-syntax (-contract stx) - (syntax-case stx () - [(_ a-contract to-check pos-blame-e neg-blame-e) - (with-syntax ([src-loc (syntax/loc stx here)]) - (syntax/loc stx - (contract/proc a-contract to-check pos-blame-e neg-blame-e (quote-syntax src-loc))))] - [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) - (syntax/loc stx - (contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e))])) - - (define (contract/proc a-contract-raw name pos-blame neg-blame src-info) - (unless (or (contract? a-contract-raw) - (and (procedure? a-contract-raw) - (procedure-arity-includes? a-contract-raw 1))) - (error 'contract "expected a contract or a procedure of arity 1 as first argument, given: ~e, other args ~e ~e ~e ~e" - a-contract-raw - name - pos-blame - neg-blame - src-info)) - (let ([a-contract (if (contract? a-contract-raw) - a-contract-raw - (flat-contract a-contract-raw))]) - (unless (and (symbol? neg-blame) - (symbol? pos-blame)) - (error 'contract - "expected symbols as names for assigning blame, given: ~e and ~e, other args ~e ~e ~e" - neg-blame pos-blame - a-contract-raw - name - src-info)) - (unless (syntax? src-info) - (error 'contract "expected syntax as last argument, given: ~e, other args ~e ~e ~e ~e" - src-info - neg-blame - pos-blame - a-contract-raw - name)) - (((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract)) - name))) - - (define-values (make-exn:fail:contract2 - exn:fail:contract2? - exn:fail:contract2-srclocs) - (let-values ([(exn:fail:contract2 - make-exn:fail:contract2 - exn:fail:contract2? - get - set) - (parameterize ([current-inspector (make-inspector)]) - (make-struct-type 'exn:fail:contract2 - struct:exn:fail - 1 - 0 - #f - (list (cons prop:exn:srclocs (lambda (x) (exn:fail:contract2-srclocs x))))))]) - (values - make-exn:fail:contract2 - exn:fail:contract2? - (lambda (x) (get x 0))))) - - ;; raise-contract-error : (union syntax #f) symbol symbol string string args ... -> alpha - ;; doesn't return - (define (raise-contract-error src-info to-blame other-party contract-sexp fmt . args) - (let ([blame-src (src-info-as-string src-info)] - [formatted-contract-sexp - (let ([one-line (format "~s" contract-sexp)]) - (if (< (string-length one-line) 30) - (string-append one-line " ") - (let ([sp (open-output-string)]) - (newline sp) - (parameterize ([pretty-print-print-line print-contract-liner] - [pretty-print-columns 50]) - (pretty-print contract-sexp sp)) - (get-output-string sp))))] - [specific-blame - (let ([datum (syntax-object->datum src-info)]) - (if (symbol? datum) - (format " on ~a" datum) - ""))]) - (raise - (make-exn:fail:contract2 - (string->immutable-string - (string-append (format "~a~a broke the contract ~ait had with ~a~a; " - blame-src - to-blame - formatted-contract-sexp - other-party - specific-blame) - (apply format fmt args))) - (current-continuation-marks) - (if src-info - (list (make-srcloc - (syntax-source src-info) - (syntax-line src-info) - (syntax-column src-info) - (syntax-position src-info) - (syntax-span src-info))) - '()))))) - - (define print-contract-liner - (let ([default (pretty-print-print-line)]) - (λ (line port ol cols) - (+ (default line port ol cols) - (if line - (begin (display " " port) - 2) - 0))))) - - ;; src-info-as-string : (union syntax #f) -> string - (define (src-info-as-string src-info) - (if (syntax? src-info) - (let ([src-loc-str (build-src-loc-string src-info)]) - (if src-loc-str - (string-append src-loc-str ": ") - "")) - "")) - - (define-syntax (recursive-contract stx) - (syntax-case stx () - [(_ arg) - (syntax (recursive-contract/proc '(recursive-contract arg) (delay (check-contract arg))))])) - - (define (recursive-contract/proc name delayed-contract) - (make-contract name - (λ (pos neg src str) - (let ([proc (contract-proc (force delayed-contract))]) - (λ (val) - ((proc pos neg src str) val)))))) - - (define (check-contract ctc) - (unless (contract? ctc) - (error 'recursive-contract "expected a contract, got ~e" ctc)) - ctc) - -; -; -; -; -; -; ; ; ; -; ;; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; ;;; -; ;; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; -; ;; ; ; ; ; ; ; ; ; ; ; ;; -; ;;;;;; ;; ; ; ; ; ; ; ; ;;;; ; ; ;; -; ;; ; ; ; ; ; ; ; ; ; ; ; ; -; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; ;;; -; -; -; - - - (define-syntax (any stx) - (raise-syntax-error 'any "Use any out of an arrow contract" stx)) - - (define-syntax-set (-> ->* ->d ->d* ->r ->pp ->pp-rest case-> object-contract opt-> opt->*) - - (define (->/proc stx) (make-/proc #f ->/h stx)) - (define (->*/proc stx) (make-/proc #f ->*/h stx)) - (define (->d/proc stx) (make-/proc #f ->d/h stx)) - (define (->d*/proc stx) (make-/proc #f ->d*/h stx)) - (define (->r/proc stx) (make-/proc #f ->r/h stx)) - (define (->pp/proc stx) (make-/proc #f ->pp/h stx)) - (define (->pp-rest/proc stx) (make-/proc #f ->pp-rest/h stx)) - - (define (obj->/proc stx) (make-/proc #t ->/h stx)) - (define (obj->*/proc stx) (make-/proc #t ->*/h stx)) - (define (obj->d/proc stx) (make-/proc #t ->d/h stx)) - (define (obj->d*/proc stx) (make-/proc #t ->d*/h stx)) - (define (obj->r/proc stx) (make-/proc #t ->r/h stx)) - (define (obj->pp/proc stx) (make-/proc #t ->pp/h stx)) - (define (obj->pp-rest/proc stx) (make-/proc #t ->pp-rest/h stx)) - - (define (case->/proc stx) (make-case->/proc #f stx)) - (define (obj-case->/proc stx) (make-case->/proc #t stx)) - - (define (obj-opt->/proc stx) (make-opt->/proc #t stx)) - (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx)) - (define (opt->/proc stx) (make-opt->/proc #f stx)) - (define (opt->*/proc stx) (make-opt->*/proc #f stx)) - - ;; make-/proc : boolean - ;; (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) - ;; syntax - ;; -> (syntax -> syntax) - (define (make-/proc method-proc? /h stx) - (let-values ([(arguments-check build-proj check-val wrapper) (/h method-proc? stx)]) - (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]) - (with-syntax ([inner-check (check-val outer-args)] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(val-args body) (wrapper outer-args)]) - (with-syntax ([inner-lambda - (set-inferred-name-from - stx - (syntax/loc stx (lambda val-args body)))]) - (let ([inner-lambda-w/err-check - (syntax - (lambda (val) - inner-check - inner-lambda))]) - (with-syntax ([proj-code (build-proj outer-args inner-lambda-w/err-check)]) - (arguments-check - outer-args - (syntax/loc stx - (make-contract - name-id - (lambda (pos-blame neg-blame src-info orig-str) - proj-code))))))))))) - - (define (make-case->/proc method-proc? stx) - (syntax-case stx () - [(_ cases ...) - (let-values ([(arguments-check build-projs check-val wrapper) - (case->/h method-proc? stx (syntax->list (syntax (cases ...))))]) - (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]) - (with-syntax ([(inner-check ...) (check-val outer-args)] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(body ...) (wrapper outer-args)]) - (with-syntax ([inner-lambda - (set-inferred-name-from - stx - (syntax/loc stx (case-lambda body ...)))]) - (let ([inner-lambda-w/err-check - (syntax - (lambda (val) - inner-check ... - inner-lambda))]) - (with-syntax ([proj-code (build-projs outer-args inner-lambda-w/err-check)]) - (arguments-check - outer-args - (syntax/loc stx - (make-contract - (apply build-compound-type-name 'case-> name-id) - (lambda (pos-blame neg-blame src-info orig-str) - proj-code))))))))))])) - - (define (make-opt->/proc method-proc? stx) - (syntax-case stx (any) - [(_ (reqs ...) (opts ...) any) - (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)))] - [(_ (reqs ...) (opts ...) res) - (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))))])) - - (define (make-opt->*/proc method-proc? stx) - (syntax-case stx (any) - [(_ (reqs ...) (opts ...) any) - (let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))] - [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))] - [cses - (reverse - (let loop ([opt-vs (reverse opt-vs)]) - (cond - [(null? opt-vs) (list req-vs)] - [else (cons (append req-vs (reverse opt-vs)) - (loop (cdr opt-vs)))])))]) - (with-syntax ([(req-vs ...) req-vs] - [(opt-vs ...) opt-vs] - [((case-doms ...) ...) cses]) - (with-syntax ([expanded-case-> - (make-case->/proc - method-proc? - (syntax (case-> (-> case-doms ... any) ...)))]) - (syntax/loc stx - (let ([req-vs reqs] ... - [opt-vs opts] ...) - expanded-case->)))))] - [(_ (reqs ...) (opts ...) (ress ...)) - (let* ([res-vs (generate-temporaries (syntax->list (syntax (ress ...))))] - [req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))] - [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))] - [cses - (reverse - (let loop ([opt-vs (reverse opt-vs)]) - (cond - [(null? opt-vs) (list req-vs)] - [else (cons (append req-vs (reverse opt-vs)) - (loop (cdr opt-vs)))])))]) - (with-syntax ([(res-vs ...) res-vs] - [(req-vs ...) req-vs] - [(opt-vs ...) opt-vs] - [((case-doms ...) ...) cses]) - (with-syntax ([(single-case-result ...) - (let* ([ress-lst (syntax->list (syntax (ress ...)))] - [only-one? - (and (pair? ress-lst) - (null? (cdr ress-lst)))]) - (map - (if only-one? - (lambda (x) (car (syntax->list (syntax (res-vs ...))))) - (lambda (x) (syntax (values res-vs ...)))) - cses))]) - (with-syntax ([expanded-case-> - (make-case->/proc - method-proc? - (syntax (case-> (-> case-doms ... single-case-result) ...)))]) - (set-inferred-name-from - stx - (syntax/loc stx - (let ([res-vs ress] - ... - [req-vs reqs] - ... - [opt-vs opts] - ...) - expanded-case->)))))))])) - - ;; exactract-argument-lists : syntax -> (listof syntax) - (define (extract-argument-lists stx) - (map (lambda (x) - (syntax-case x () - [(arg-list body) (syntax arg-list)])) - (syntax->list stx))) - - ;; ensure-cases-disjoint : syntax syntax[list] -> void - (define (ensure-cases-disjoint stx cases) - (let ([individual-cases null] - [dot-min #f]) - (for-each (lambda (case) - (let ([this-case (get-case case)]) - (cond - [(number? this-case) - (cond - [(member this-case individual-cases) - (raise-syntax-error - 'case-> - (format "found multiple cases with ~a arguments" this-case) - stx)] - [(and dot-min (dot-min . <= . this-case)) - (raise-syntax-error - 'case-> - (format "found overlapping cases (~a+ followed by ~a)" dot-min this-case) - stx)] - [else (set! individual-cases (cons this-case individual-cases))])] - [(pair? this-case) - (let ([new-dot-min (car this-case)]) - (cond - [dot-min - (if (dot-min . <= . new-dot-min) - (raise-syntax-error - 'case-> - (format "found overlapping cases (~a+ followed by ~a+)" dot-min new-dot-min) - stx) - (set! dot-min new-dot-min))] - [else - (set! dot-min new-dot-min)]))]))) - cases))) - - ;; get-case : syntax -> (union number (cons number 'more)) - (define (get-case stx) - (let ([ilist (syntax-object->datum stx)]) - (if (list? ilist) - (length ilist) - (cons - (let loop ([i ilist]) - (cond - [(pair? i) (+ 1 (loop (cdr i)))] - [else 0])) - 'more)))) - - - ;; case->/h : boolean - ;; syntax - ;; (listof syntax) - ;; -> (values (syntax -> syntax) - ;; (syntax -> syntax) - ;; (syntax syntax -> syntax) - ;; (syntax -> syntax)) - ;; like the other /h functions, but composes the wrapper functions - ;; together and combines the cases of the case-lambda into a single list. - (define (case->/h method-proc? orig-stx cases) - (let loop ([cases cases] - [name-ids '()]) - (cond - [(null? cases) (values (lambda (outer-args body) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [body body] - [(name-ids ...) (reverse name-ids)]) - (syntax - (let ([name-id (list name-ids ...)]) - body)))) - (lambda (x y) y) - (lambda (args) (syntax ())) - (lambda (args) (syntax ())))] - [else - (let ([/h (select/h (car cases) 'case-> orig-stx)] - [new-id (car (generate-temporaries (syntax (case->name-id))))]) - (let-values ([(arguments-checks build-projs check-vals wrappers) - (loop (cdr cases) (cons new-id name-ids))] - [(arguments-check build-proj check-val wrapper) - (/h method-proc? (car cases))]) - (values - (lambda (outer-args x) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [new-id new-id]) - (arguments-check - (syntax (val pos-blame neg-blame src-info orig-str new-id)) - (arguments-checks - outer-args - x)))) - (lambda (args inner) - (build-projs - args - (build-proj - args - inner))) - (lambda (args) - (with-syntax ([checks (check-vals args)] - [check (check-val args)]) - (syntax (check . checks)))) - (lambda (args) - (with-syntax ([case (wrapper args)] - [cases (wrappers args)]) - (syntax (case . cases)))))))]))) - - (define (object-contract/proc stx) - - ;; name : syntax - ;; ctc-stx : syntax[evals to a contract] - ;; mtd-arg-stx : syntax[list of arg-specs] (ie, for use in a case-lambda) - (define-struct mtd (name ctc-stx mtd-arg-stx)) - - ;; name : syntax - ;; ctc-stx : syntax[evals to a contract] - (define-struct fld (name ctc-stx)) - - ;; expand-field/mtd-spec : stx -> (union mtd fld) - (define (expand-field/mtd-spec f/m-stx) - (syntax-case f/m-stx (field) - [(field field-name ctc) - (identifier? (syntax field-name)) - (make-fld (syntax field-name) (syntax ctc))] - [(field field-name ctc) - (raise-syntax-error 'object-contract "expected name of field" stx (syntax field-name))] - [(mtd-name ctc) - (identifier? (syntax mtd-name)) - (let-values ([(ctc-stx proc-stx) (expand-mtd-contract (syntax ctc))]) - (make-mtd (syntax mtd-name) - ctc-stx - proc-stx))] - [(mtd-name ctc) - (raise-syntax-error 'object-contract "expected name of method" stx (syntax mtd-name))] - [_ (raise-syntax-error 'object-contract "expected field or method clause" stx f/m-stx)])) - - ;; expand-mtd-contract : syntax -> (values syntax[expanded ctc] syntax[mtd-arg]) - (define (expand-mtd-contract mtd-stx) - (syntax-case mtd-stx (case-> opt-> opt->*) - [(case-> cases ...) - (let loop ([cases (syntax->list (syntax (cases ...)))] - [ctc-stxs null] - [args-stxs null]) - (cond - [(null? cases) - (values - (with-syntax ([(x ...) (reverse ctc-stxs)]) - (obj-case->/proc (syntax (case-> x ...)))) - (with-syntax ([(x ...) (apply append (map syntax->list (reverse args-stxs)))]) - (syntax (x ...))))] - [else - (let-values ([(trans ctc-stx mtd-args) (expand-mtd-arrow (car cases))]) - (loop (cdr cases) - (cons ctc-stx ctc-stxs) - (cons mtd-args args-stxs)))]))] - [(opt->* (req-contracts ...) (opt-contracts ...) (res-contracts ...)) - (values - (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) (res-contracts ...)))) - (generate-opt->vars (syntax (req-contracts ...)) - (syntax (opt-contracts ...))))] - [(opt->* (req-contracts ...) (opt-contracts ...) any) - (values - (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) any))) - (generate-opt->vars (syntax (req-contracts ...)) - (syntax (opt-contracts ...))))] - [(opt-> (req-contracts ...) (opt-contracts ...) res-contract) - (values - (obj-opt->/proc (syntax (opt-> (any/c req-contracts ...) (opt-contracts ...) res-contract))) - (generate-opt->vars (syntax (req-contracts ...)) - (syntax (opt-contracts ...))))] - [else (let-values ([(x y z) (expand-mtd-arrow mtd-stx)]) - (values (x y) z))])) - - ;; generate-opt->vars : syntax[requried contracts] syntax[optional contracts] -> syntax[list of arg specs] - (define (generate-opt->vars req-stx opt-stx) - (with-syntax ([(req-vars ...) (generate-temporaries req-stx)] - [(ths) (generate-temporaries (syntax (ths)))]) - (let loop ([opt-vars (generate-temporaries opt-stx)]) - (cond - [(null? opt-vars) (list (syntax (ths req-vars ...)))] - [else (with-syntax ([(opt-vars ...) opt-vars] - [(rests ...) (loop (cdr opt-vars))]) - (syntax ((ths req-vars ... opt-vars ...) - rests ...)))])))) - - ;; expand-mtd-arrow : stx -> (values (syntax[ctc] -> syntax[expanded ctc]) syntax[ctc] syntax[mtd-arg]) - (define (expand-mtd-arrow mtd-stx) - (syntax-case mtd-stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) - [(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)] - [(-> args ...) - (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))]) - (values obj->/proc - (syntax (-> any/c args ...)) - (syntax ((arg-vars ...)))))] - [(->* (doms ...) (rngs ...)) - (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] - [(this-var) (generate-temporaries (syntax (this-var)))]) - (values obj->*/proc - (syntax (->* (any/c doms ...) (rngs ...))) - (syntax ((this-var args-vars ...)))))] - [(->* (doms ...) rst (rngs ...)) - (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] - [(rst-var) (generate-temporaries (syntax (rst)))] - [(this-var) (generate-temporaries (syntax (this-var)))]) - (values obj->*/proc - (syntax (->* (any/c doms ...) rst (rngs ...))) - (syntax ((this-var args-vars ... . rst-var)))))] - [(->* x ...) - (raise-syntax-error 'object-contract "malformed ->*" stx mtd-stx)] - [(->d) (raise-syntax-error 'object-contract "->d must have arguments" stx mtd-stx)] - [(->d doms ... rng-proc) - (let ([doms-val (syntax->list (syntax (doms ...)))]) - (values - obj->d/proc - (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] - [arity-count (length doms-val)]) - (syntax - (->d any/c doms ... - (let ([f rng-proc]) - (check->* f arity-count) - (lambda (_this-var arg-vars ...) - (f arg-vars ...)))))) - (with-syntax ([(args-vars ...) (generate-temporaries doms-val)]) - (syntax ((this-var args-vars ...))))))] - [(->d* (doms ...) rng-proc) - (values - obj->d*/proc - (let ([doms-val (syntax->list (syntax (doms ...)))]) - (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] - [arity-count (length doms-val)]) - (syntax (->d* (any/c doms ...) - (let ([f rng-proc]) - (check->* f arity-count) - (lambda (_this-var arg-vars ...) - (f arg-vars ...))))))) - (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] - [(this-var) (generate-temporaries (syntax (this-var)))]) - (syntax ((this-var args-vars ...)))))] - [(->d* (doms ...) rst-ctc rng-proc) - (let ([doms-val (syntax->list (syntax (doms ...)))]) - (values - obj->d*/proc - (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] - [(rest-var) (generate-temporaries (syntax (rst-ctc)))] - [arity-count (length doms-val)]) - (syntax (->d* (any/c doms ...) - rst-ctc - (let ([f rng-proc]) - (check->*/more f arity-count) - (lambda (_this-var arg-vars ... . rest-var) - (apply f arg-vars ... rest-var)))))) - (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] - [(rst-var) (generate-temporaries (syntax (rst-ctc)))] - [(this-var) (generate-temporaries (syntax (this-var)))]) - (syntax ((this-var args-vars ... . rst-var))))))] - [(->d* x ...) - (raise-syntax-error 'object-contract "malformed ->d* method contract" stx mtd-stx)] - - [(->r ([x dom] ...) rng) - (andmap identifier? (syntax->list (syntax (x ...)))) - (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]) - (values - obj->r/proc - (syntax (->r ([_this any/c] [x dom] ...) rng)) - (syntax ((_this arg-vars ...)))))] - - [(->r ([x dom] ...) rest-x rest-dom rng) - (andmap identifier? (syntax->list (syntax (x ...)))) - (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]) - (values - obj->r/proc - (syntax (->r ([_this any/c] [x dom] ...) rest-x rest-dom rng)) - (syntax ((_this arg-vars ... . rest-var)))))] - - [(->r . x) - (raise-syntax-error 'object-contract "malformed ->r declaration")] - [(->pp ([x dom] ...) . other-stuff) - (andmap identifier? (syntax->list (syntax (x ...)))) - (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]) - (values - obj->pp/proc - (syntax (->pp ([_this any/c] [x dom] ...) . other-stuff)) - (syntax ((_this arg-vars ...)))))] - [(->pp . x) - (raise-syntax-error 'object-contract "malformed ->pp declaration")] - [(->pp-rest ([x dom] ...) rest-id . other-stuff) - (and (identifier? (syntax id)) - (andmap identifier? (syntax->list (syntax (x ...))))) - (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]) - (values - obj->pp-rest/proc - (syntax (->pp ([_this any/c] [x dom] ...) rest-id . other-stuff)) - (syntax ((_this arg-vars ... . rest-id)))))] - [(->pp-rest . x) - (raise-syntax-error 'object-contract "malformed ->pp-rest declaration")] - [else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)])) - - ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc] - (define (build-methods-stx mtds) - (let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)] - [names (map mtd-name mtds)] - [i 0]) - (cond - [(null? arg-spec-stxss) null] - [else (let ([arg-spec-stxs (car arg-spec-stxss)]) - (with-syntax ([(cases ...) - (map (lambda (arg-spec-stx) - (with-syntax ([i i]) - (syntax-case arg-spec-stx () - [(this rest-ids ...) - (syntax - ((this rest-ids ...) - ((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))] - [else - (let-values ([(this rest-ids last-var) - (let ([lst (syntax->improper-list arg-spec-stx)]) - (values (car lst) - (all-but-last (cdr lst)) - (cdr (last-pair lst))))]) - (with-syntax ([this this] - [(rest-ids ...) rest-ids] - [last-var last-var]) - (syntax - ((this rest-ids ... . last-var) - (apply (field-ref this i) - (wrapper-object-wrapped this) - rest-ids ... - last-var)))))]))) - (syntax->list arg-spec-stxs))] - [name (string->symbol (format "~a method" (syntax-object->datum (car names))))]) - (with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)]) - (cons (syntax (lambda (field-ref) (let ([name proc]) name))) - (loop (cdr arg-spec-stxss) - (cdr names) - (+ i 1))))))]))) - - (define (syntax->improper-list stx) - (define (se->il se) - (cond - [(pair? se) (sp->il se)] - [else se])) - (define (stx->il stx) - (se->il (syntax-e stx))) - (define (sp->il p) - (cond - [(null? (cdr p)) p] - [(pair? (cdr p)) (cons (car p) (sp->il (cdr p)))] - [(syntax? (cdr p)) - (let ([un (syntax-e (cdr p))]) - (if (pair? un) - (cons (car p) (sp->il un)) - p))])) - (stx->il stx)) - - (syntax-case stx () - [(_ field/mtd-specs ...) - (let* ([mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (field/mtd-specs ...))))] - [mtds (filter mtd? mtd/flds)] - [flds (filter fld? mtd/flds)]) - (with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)] - [(method-name ...) (map mtd-name mtds)] - [(method-ctc-var ...) (generate-temporaries mtds)] - [(method-var ...) (generate-temporaries mtds)] - [(method/app-var ...) (generate-temporaries mtds)] - [(methods ...) (build-methods-stx mtds)] - - [(field-ctc-stx ...) (map fld-ctc-stx flds)] - [(field-name ...) (map fld-name flds)] - [(field-ctc-var ...) (generate-temporaries flds)] - [(field-var ...) (generate-temporaries flds)] - [(field/app-var ...) (generate-temporaries flds)]) - (syntax - (let ([method-ctc-var method-ctc-stx] - ... - [field-ctc-var (coerce-contract object-contract field-ctc-stx)] - ...) - (let ([method-var (contract-proc method-ctc-var)] - ... - [field-var (contract-proc field-ctc-var)] - ...) - (make-contract - `(object-contract - ,(build-compound-type-name 'method-name method-ctc-var) ... - ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) - (lambda (pos-blame neg-blame src-info orig-str) - (let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)] - ... - [field/app-var (field-var pos-blame neg-blame src-info orig-str)] - ...) - (let ([cls (make-wrapper-class 'wrapper-class - '(method-name ...) - (list methods ...) - '(field-name ...))] - [field-names-list '(field-name ...)]) - (lambda (val) - (check-object val src-info pos-blame neg-blame orig-str) - (let ([val-mtd-names - (interface->method-names - (object-interface - val))]) - (void) - (check-method 'method-name val-mtd-names src-info pos-blame neg-blame orig-str) - ...) - - (unless (field-bound? field-name val) - (field-error 'field-name src-info pos-blame neg-blame orig-str)) ... - - (let ([vtable (extract-vtable val)] - [method-ht (extract-method-ht val)]) - (make-object cls - val - (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ... - (field/app-var (get-field field-name val)) ... - ))))))))))))])) - - ;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void - (define (ensure-no-duplicates stx form-name names) - (let ([ht (make-hash-table)]) - (for-each (lambda (name) - (let ([key (syntax-e name)]) - (when (hash-table-get ht key (lambda () #f)) - (raise-syntax-error form-name - "duplicate method name" - stx - name)) - (hash-table-put! ht key #t))) - names))) - - ;; method-specifier? : syntax -> boolean - ;; returns #t if x is the syntax for a valid method specifier - (define (method-specifier? x) - (or (eq? 'public (syntax-e x)) - (eq? 'override (syntax-e x)))) - - ;; make-object-wrapper-method : syntax syntax[identifier] syntax[identifier] syntax -> syntax - ;; constructs a wrapper method that checks the pre and post-condition, and - ;; calls the original object's method - (define (make-object-wrapper-method outer-args method-name contract-var contract-stx) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [method-name method-name] - [method-name-string (symbol->string (syntax-e method-name))] - [contract-var contract-var]) - (syntax/loc contract-stx - (define/public (method-name . args) - (let ([other-method (lambda x (send/apply val method-name x))] - [method-specific-src-info - (if (identifier? src-info) - (datum->syntax-object - src-info - (string->symbol - (string-append - (symbol->string (syntax-e src-info)) - " method " - method-name-string))) - src-info)]) - (apply (contract-var - other-method - pos-blame - neg-blame - method-specific-src-info) - args)))))) - - ;; make-class-wrapper-method : syntax syntax[identifier] syntax[identifier] syntax -> syntax - ;; constructs a wrapper method that checks the pre and post-condition, and - ;; calls the super method inbetween. - (define (make-class-wrapper-method outer-args method-name contract-var contract-stx) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [super-method-name (prefix-super method-name)] - [method-name method-name] - [method-name-string (symbol->string (syntax-e method-name))] - [contract-var contract-var]) - (syntax/loc contract-stx - (define/override method-name - (lambda args - (let* ([super-method (lambda x (super-method-name . x))] - [method-specific-src-info - (if (identifier? src-info) - (datum->syntax-object - src-info - (string->symbol - (string-append - (symbol->string (syntax-e src-info)) - " method " - method-name-string))) - src-info)] - [super-contract (and super-contracts-ht - (hash-table-get super-contracts-ht - 'method-name - (lambda () #f)))] - [wrapped-method (contract-var - super-method - pos-blame - neg-blame - method-specific-src-info)]) - (apply wrapped-method args))))))) - - ;; prefix-super : syntax[identifier] -> syntax[identifier] - ;; adds super- to the front of the identifier - (define (prefix-super stx) - (datum->syntax-object - #'here - (string->symbol - (format - "super-~a" - (syntax-object->datum - stx))))) - - ;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier] - ;; given the syntax for a method name, constructs the name of a method - ;; that returns the super's contract for the original method. - (define (method-name->contract-method-name stx) - (datum->syntax-object - #'here - (string->symbol - (format - "ACK_DONT_GUESS_ME-super-contract-~a" - (syntax-object->datum - stx))))) - - ;; Each of the /h functions builds four pieces of syntax: - ;; - [arguments-check] - ;; code that binds the contract values to names and - ;; does error checking for the contract specs - ;; (were the arguments all contracts?) - ;; - [build-proj] - ;; code that partially applies the input contracts to build projections - ;; - [check-val] - ;; code that does error checking on the contract'd value itself - ;; (is it a function of the right arity?) - ;; - [wrapper] - ;; a piece of syntax that has the arguments to the wrapper - ;; and the body of the wrapper. - ;; the first function accepts a body expression and wraps - ;; the body expression with checks. In addition, it - ;; adds a let that binds the contract exprssions to names - ;; the results of the other functions mention these names. - ;; the second and third function's input syntax should be four - ;; names: val, pos-blame, neg-blame, src-info, orig-str, name-id - ;; the fourth function returns a syntax list with two elements, - ;; the argument list (to be used as the first arg to lambda, - ;; or as a case-lambda clause) and the body of the function. - ;; They are combined into a lambda for the -> ->* ->d ->d* macros, - ;; and combined into a case-lambda for the case-> macro. - - ;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->/h method-proc? stx) - (syntax-case stx () - [(_) (raise-syntax-error '-> "expected at least one argument" stx)] - [(_ dom ... rng) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) - (with-syntax ([(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax-case* (syntax rng) (any values) module-or-top-identifier=? - [any - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([dom-contract-x (coerce-contract -> dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] ...) - (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)]) - body)))))) - - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (val (dom-projection-x arg-x) ...))))))] - [(values rng ...) - (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] - [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] - [(res-x ...) (generate-temporaries (syntax (rng ...)))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([dom-contract-x (coerce-contract -> dom)] ... - [rng-contract-x (coerce-contract -> rng)] ...) - (let ([dom-x (contract-proc dom-contract-x)] ... - [rng-x (contract-proc rng-contract-x)] ...) - (let ([name-id - (build-compound-type-name - '-> - name-dom-contract-x ... - (build-compound-type-name 'values rng-contract-x ...))]) - body)))))) - - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)]) - (values (rng-projection-x - res-x) - ...))))))))] - [rng - (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))] - [(rng-contact-x) (generate-temporaries (syntax (rng)))] - [(rng-projection-x) (generate-temporaries (syntax (rng)))] - [(rng-ant-x) (generate-temporaries (syntax (rng)))] - [(res-x) (generate-temporaries (syntax (rng)))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([dom-contract-x (coerce-contract -> dom)] ... - [rng-contract-x (coerce-contract -> rng)]) - (let ([dom-x (contract-proc dom-contract-x)] ... - [rng-x (contract-proc rng-contract-x)]) - (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)]) - body)))))) - - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)]) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (let ([res-x (val (dom-projection-x arg-x) ...)]) - (rng-projection-x res-x))))))))])))])) - - ;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->*/h method-proc? stx) - (syntax-case stx (any) - [(_ (dom ...) (rng ...)) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - - [(rng-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] - [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] - [(res-x ...) (generate-temporaries (syntax (rng ...)))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract ->* dom)] ... - [rng-contract-x (coerce-contract ->* rng)] ...) - (let ([dom-x (contract-proc dom-contract-x)] ... - [rng-x (contract-proc rng-contract-x)] ...) - (let ([name-id (build-compound-type-name - '->* - (build-compound-type-name name-dom-contract-x ...) - (build-compound-type-name rng-contract-x ...))]) - body)))))) - - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)]) - (values (rng-projection-x - res-x) - ...))))))))] - [(_ (dom ...) any) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract ->* dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] ...) - (let ([name-id (build-compound-type-name - '->* - (build-compound-type-name name-dom-contract-x ...) - 'any)]) - body)))))) - - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (val (dom-projection-x arg-x) ...)))))))] - [(_ (dom ...) rest (rng ...)) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [dom-rest-x (car (generate-temporaries (list (syntax rest))))] - [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] - [dom-rest-projection-x (car (generate-temporaries (list (syntax rest))))] - [arg-rest-x (car (generate-temporaries (list (syntax rest))))] - - [(rng-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] - [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] - [(res-x ...) (generate-temporaries (syntax (rng ...)))] - [arity (length (syntax->list (syntax (dom ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [body body] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract ->* dom)] ... - [dom-rest-contract-x (coerce-contract ->* rest)] - [rng-contract-x (coerce-contract ->* rng)] ...) - (let ([dom-x (contract-proc dom-contract-x)] ... - [dom-rest-x (contract-proc dom-rest-contract-x)] - [rng-x (contract-proc rng-contract-x)] ...) - (let ([name-id - (build-compound-type-name - '->* - (build-compound-type-name dom-contract-x ...) - dom-rest-contract-x - (build-compound-type-name rng-contract-x ...))]) - body)))))) - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... - [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)] - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) - inner-lambda)))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure/more val dom-length src-info pos-blame neg-blame orig-str)))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ... . arg-rest-x) - (let-values ([(res-x ...) - (apply - val - (dom-projection-x arg-x) - ... - (dom-rest-projection-x arg-rest-x))]) - (values (rng-projection-x res-x) ...))))))))] - [(_ (dom ...) rest any) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [dom-rest-x (car (generate-temporaries (list (syntax rest))))] - [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] - [dom-projection-rest-x (car (generate-temporaries (list (syntax rest))))] - [arg-rest-x (car (generate-temporaries (list (syntax rest))))] - - [arity (length (syntax->list (syntax (dom ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract ->* dom)] ... - [dom-rest-contract-x (coerce-contract ->* rest)]) - (let ([dom-x (contract-proc dom-contract-x)] ... - [dom-rest-x (contract-proc dom-rest-contract-x)]) - (let ([name-id (build-compound-type-name - '->* - (build-compound-type-name name-dom-contract-x ...) - dom-rest-contract-x - 'any)]) - body)))))) - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... - [dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) - inner-lambda)))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ;; CHECK: previously, this test didn't use `procedure-arity' and compare to `dom-length' - (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ... . arg-rest-x) - (apply - val - (dom-projection-x arg-x) - ... - (dom-projection-rest-x arg-rest-x))))))))])) - - ;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->d/h method-proc? stx) - (syntax-case stx () - [(_) (raise-syntax-error '->d "expected at least one argument" stx)] - [(_ dom ... rng) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [arity (length (syntax->list (syntax (dom ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract ->d dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] ... - [rng-x rng]) - (check-rng-procedure '->d rng-x arity) - (let ([name-id (build-compound-type-name '->d name-dom-contract-x ... '(... ...))]) - - body)))))) - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) - inner-lambda)))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val arity src-info pos-blame neg-blame orig-str)))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (let ([rng-contract (rng-x arg-x ...)]) - (((coerce/select-contract ->d rng-contract) - pos-blame - neg-blame - src-info - orig-str) - (val (dom-projection-x arg-x) ...)))))))))])) - - ;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->d*/h method-proc? stx) - (syntax-case stx () - [(_ (dom ...) rng-mk) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract ->d* dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] ... - [rng-mk-x rng-mk]) - (check-rng-procedure '->d* rng-mk-x dom-length) - (let ([name-id (build-compound-type-name - '->d* - (build-compound-type-name name-dom-contract-x ...) - '(... ...))]) - body)))))) - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) - inner-lambda)))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (call-with-values - (lambda () (rng-mk-x arg-x ...)) - (lambda rng-contracts - (call-with-values - (lambda () - (val (dom-projection-x arg-x) ...)) - (lambda results - (check-rng-lengths results rng-contracts) - (apply - values - (map (lambda (rng-contract result) - (((coerce/select-contract ->d* rng-contract) - pos-blame - neg-blame - src-info - orig-str) - result)) - rng-contracts - results))))))))))))] - [(_ (dom ...) rest rng-mk) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-rest-x) (generate-temporaries (syntax (rest)))] - [(dom-rest-contract-x) (generate-temporaries (syntax (rest)))] - [(dom-rest-projection-x) (generate-temporaries (syntax (rest)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [arity (length (syntax->list (syntax (dom ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract ->d* dom)] ... - [dom-rest-contract-x (coerce-contract ->d* rest)]) - (let ([dom-x (contract-proc dom-contract-x)] ... - [dom-rest-x (contract-proc dom-rest-contract-x)] - [rng-mk-x rng-mk]) - (check-rng-procedure/more rng-mk-x arity) - (let ([name-id (build-compound-type-name - '->d* - (build-compound-type-name name-dom-contract-x ...) - dom-rest-contract-x - '(... ...))]) - body)))))) - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... - [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) - inner-lambda)))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ;; CHECK: old check use "and more", but error message didn't - (check-procedure/more val arity src-info pos-blame neg-blame orig-str)))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ... . rest-arg-x) - (call-with-values - (lambda () - (apply rng-mk-x arg-x ... rest-arg-x)) - (lambda rng-contracts - (call-with-values - (lambda () - (apply - val - (dom-projection-x arg-x) - ... - (dom-rest-projection-x rest-arg-x))) - (lambda results - (check-rng-lengths results rng-contracts) - (apply - values - (map (lambda (rng-contract result) - (((coerce/select-contract ->d* rng-contract) - pos-blame - neg-blame - src-info - orig-str) - result)) - rng-contracts - results))))))))))))])) - - ;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->r/h method-proc? stx) - (syntax-case stx () - [(_ ([x dom] ...) rng) - (syntax-case* (syntax rng) (any values) module-or-top-identifier=? - [any - (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t any)))] - [(values . args) - (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng #t)))] - [rng - (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng unused-id #t)))] - [_ - (raise-syntax-error '->r "unknown result contract spec" stx (syntax rng))])] - - [(_ ([x dom] ...) rest-x rest-dom rng) - (syntax-case* (syntax rng) (values any) module-or-top-identifier=? - [any - (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t any)))] - [(values . whatever) - (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng #t)))] - [_ - (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng unused-id #t)))])])) - - ;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->pp/h method-proc? stx) (->r-pp/h method-proc? '->pp stx)) - - ;; ->pp/h : boolean symbol stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->r-pp/h method-proc? name stx) - (syntax-case stx () - [(_ ([x dom] ...) pre-expr . result-stuff) - (and (andmap identifier? (syntax->list (syntax (x ...)))) - (not (check-duplicate-identifier (syntax->list (syntax (x ...)))))) - (with-syntax ([stx-name name]) - (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))] - [arity (length (syntax->list (syntax (dom ...))))] - [name-stx - (with-syntax ([(name-xs ...) (if method-proc? - (cdr (syntax->list (syntax (x ...)))) - (syntax (x ...)))]) - (syntax - (build-compound-type-name 'stx-name - (build-compound-type-name - (build-compound-type-name 'name-xs '(... ...)) - ...) - '(... ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([name-id name-stx]) - body)))) - (lambda (outer-args inner-lambda) inner-lambda) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [kind-of-thing (if method-proc? 'method 'procedure)]) - (syntax - (begin - (check-procedure/kind val arity 'kind-of-thing src-info pos-blame neg-blame orig-str))))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=? - [(any) - (syntax - ((x ...) - (begin - (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) - (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] - ...) - (val (dom-id x) ...)))))] - [((values (rng-ids rng-ctc) ...) post-expr) - (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) - (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) - (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))]) - (syntax - ((x ...) - (begin - (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) - (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] - ...) - (let-values ([(rng-ids ...) (val (dom-id x) ...)]) - (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) - (let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc) - pos-blame neg-blame src-info orig-str)] ...) - (values (rng-ids-x rng-ids) ...))))))))] - [((values (rng-ids rng-ctc) ...) post-expr) - (andmap identifier? (syntax->list (syntax (rng-ids ...)))) - (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))]) - (raise-syntax-error name "duplicate identifier" stx dup))] - [((values (rng-ids rng-ctc) ...) post-expr) - (for-each (lambda (rng-id) - (unless (identifier? rng-id) - (raise-syntax-error name "expected identifier" stx rng-id))) - (syntax->list (syntax (rng-ids ...))))] - [((values . x) . junk) - (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))] - [(rng res-id post-expr) - (syntax - ((x ...) - (begin - (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) - (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] - ... - [rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)]) - (let ([res-id (rng-id (val (dom-id x) ...))]) - (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) - res-id)))))] - [_ - (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))] - [(_ ([x dom] ...) pre-expr . result-stuff) - (andmap identifier? (syntax->list (syntax (x ...)))) - (raise-syntax-error - name - "duplicate identifier" - stx - (check-duplicate-identifier (syntax->list (syntax (x ...)))))] - [(_ ([x dom] ...) pre-expr . result-stuff) - (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x))) - (syntax->list (syntax (x ...))))] - [(_ (x ...) pre-expr . result-stuff) - (for-each (lambda (x) - (syntax-case x () - [(x y) (identifier? (syntax x)) (void)] - [bad (raise-syntax-error name "expected identifier and contract" stx (syntax bad))])) - (syntax->list (syntax (x ...))))] - [(_ x dom pre-expr . result-stuff) - (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))])) - - ;; ->pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->pp-rest/h method-proc? stx) (->r-pp-rest/h method-proc? '->pp-rest stx)) - - ;; ->r-pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->r-pp-rest/h method-proc? name stx) - (syntax-case stx () - [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff) - (and (identifier? (syntax rest-x)) - (andmap identifier? (syntax->list (syntax (x ...)))) - (not (check-duplicate-identifier (cons (syntax rest-x) (syntax->list (syntax (x ...))))))) - (with-syntax ([stx-name name]) - (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))] - [arity (length (syntax->list (syntax (dom ...))))] - [name-stx - (with-syntax ([(name-xs ...) (if method-proc? - (cdr (syntax->list (syntax (x ...)))) - (syntax (x ...)))]) - (syntax - (build-compound-type-name 'stx-name - `(,(build-compound-type-name 'name-xs '(... ...)) ...) - 'rest-x - '(... ...) - '(... ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([name-id name-stx]) - body)))) - (lambda (outer-args inner-lambda) inner-lambda) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [kind-of-thing (if method-proc? 'method 'procedure)]) - (syntax - (begin - (check-procedure/more/kind val arity 'kind-of-thing src-info pos-blame neg-blame orig-str))))) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax-case* (syntax result-stuff) (values any) module-or-top-identifier=? - [(any) - (syntax - ((x ... . rest-x) - (begin - (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) - (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] - ... - [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)]) - (apply val (dom-id x) ... (rest-id rest-x))))))] - [(any . x) - (raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))] - [((values (rng-ids rng-ctc) ...) post-expr) - (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) - (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) - (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))]) - (syntax - ((x ... . rest-x) - (begin - (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) - (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] - ... - [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)]) - (let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))]) - (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) - (let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc) - pos-blame neg-blame src-info orig-str)] ...) - (values (rng-ids-x rng-ids) ...))))))))] - [((values (rng-ids rng-ctc) ...) . whatever) - (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) - (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) - (raise-syntax-error name "expected exactly on post-expression at the end" stx)] - [((values (rng-ids rng-ctc) ...) . whatever) - (andmap identifier? (syntax->list (syntax (rng-ids ...)))) - (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))]) - (raise-syntax-error name "duplicate identifier" stx dup))] - [((values (rng-ids rng-ctc) ...) . whatever) - (for-each (lambda (rng-id) - (unless (identifier? rng-id) - (raise-syntax-error name "expected identifier" stx rng-id))) - (syntax->list (syntax (rng-ids ...))))] - [((values . x) . whatever) - (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))] - [(rng res-id post-expr) - (identifier? (syntax res-id)) - (syntax - ((x ... . rest-x) - (begin - (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) - (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] - ... - [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)] - [rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)]) - (let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))]) - (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) - res-id)))))] - [(rng res-id post-expr) - (not (identifier? (syntax res-id))) - (raise-syntax-error name "expected an identifier" stx (syntax res-id))] - [_ - (raise-syntax-error name "malformed result sepecification" stx (syntax result-stuff))]))))))] - [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff) - (not (identifier? (syntax rest-x))) - (raise-syntax-error name "expected identifier" stx (syntax rest-x))] - [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff) - (and (identifier? (syntax rest-x)) - (andmap identifier? (cons (syntax rest-x) (syntax->list (syntax (x ...)))))) - (raise-syntax-error - name - "duplicate identifier" - stx - (check-duplicate-identifier (syntax->list (syntax (x ...)))))] - - [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff) - (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x))) - (cons - (syntax rest-x) - (syntax->list (syntax (x ...)))))] - [(_ x dom rest-x rest-dom rng . result-stuff) - (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))])) - - ;; select/h : syntax -> /h-function - (define (select/h stx err-name ctxt-stx) - (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) - [(-> . args) ->/h] - [(->* . args) ->*/h] - [(->d . args) ->d/h] - [(->d* . args) ->d*/h] - [(->r . args) ->r/h] - [(->pp . args) ->pp/h] - [(->pp-rest . args) ->pp-rest/h] - [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))] - [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)])) - - - ;; set-inferred-name-from : syntax syntax -> syntax - (define (set-inferred-name-from with-name to-be-named) - (let ([name (syntax-local-infer-name with-name)]) - (cond - [(identifier? name) - (with-syntax ([rhs (syntax-property to-be-named 'inferred-name (syntax-e name))] - [name (syntax-e name)]) - (syntax (let ([name rhs]) name)))] - [(symbol? name) - (with-syntax ([rhs (syntax-property to-be-named 'inferred-name name)] - [name name]) - (syntax (let ([name rhs]) name)))] - [else to-be-named]))) - - ;; (cons X (listof X)) -> (listof X) - ;; returns the elements of `l', minus the last element - ;; special case: if l is an improper list, it leaves off - ;; the contents of the last cdr (ie, making a proper list - ;; out of the input), so (all-but-last '(1 2 . 3)) = '(1 2) - (define (all-but-last l) - (cond - [(null? l) (error 'all-but-last "bad input")] - [(not (pair? l)) '()] - [(null? (cdr l)) null] - [(pair? (cdr l)) (cons (car l) (all-but-last (cdr l)))] - [else (list (car l))])) - - ;; generate-indicies : syntax[list] -> (cons number (listof number)) - ;; given a syntax list of length `n', returns a list containing - ;; the number n followed by th numbers from 0 to n-1 - (define (generate-indicies stx) - (let ([n (length (syntax->list stx))]) - (cons n - (let loop ([i n]) - (cond - [(zero? i) null] - [else (cons (- n i) - (loop (- i 1)))])))))) - - ;; procedure-accepts-and-more? : procedure number -> boolean - ;; returns #t if val accepts dom-length arguments and - ;; any number of arguments more than dom-length. - ;; returns #f otherwise. - (define (procedure-accepts-and-more? val dom-length) - (let ([arity (procedure-arity val)]) - (cond - [(number? arity) #f] - [(arity-at-least? arity) - (<= (arity-at-least-value arity) dom-length)] - [else - (let ([min-at-least (let loop ([ars arity] - [acc #f]) - (cond - [(null? ars) acc] - [else (let ([ar (car ars)]) - (cond - [(arity-at-least? ar) - (if (and acc - (< acc (arity-at-least-value ar))) - (loop (cdr ars) acc) - (loop (cdr ars) (arity-at-least-value ar)))] - [(number? ar) - (loop (cdr ars) acc)]))]))]) - (and min-at-least - (begin - (let loop ([counts (quicksort (filter number? arity) >=)]) - (unless (null? counts) - (let ([count (car counts)]) - (cond - [(= (+ count 1) min-at-least) - (set! min-at-least count) - (loop (cdr counts))] - [(< count min-at-least) - (void)] - [else (loop (cdr counts))])))) - (<= min-at-least dom-length))))]))) - - ;; ---------------------------------------- - ;; Checks and error functions used in macro expansions - - (define (check->* f arity-count) - (unless (procedure? f) - (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) - (unless (procedure-arity-includes? f arity-count) - (error 'object-contract - "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e" - arity-count - f))) - - (define (check->*/more f arity-count) - (unless (procedure? f) - (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) - (unless (procedure-accepts-and-more? f arity-count) - (error 'object-contract - "expected last argument of ->d* to be a procedure that accepts ~a arguments and arbitrarily many more, got ~e" - arity-count - f))) - - - (define (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) - (unless pre-expr - (raise-contract-error src-info - neg-blame - pos-blame - orig-str - "pre-condition expression failure"))) - - (define (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) - (unless post-expr - (raise-contract-error src-info - pos-blame - neg-blame - orig-str - "post-condition expression failure"))) - - (define (check-procedure val dom-length src-info pos-blame neg-blame orig-str) - (unless (and (procedure? val) - (procedure-arity-includes? val dom-length)) - (raise-contract-error - src-info - pos-blame - neg-blame - orig-str - "expected a procedure that accepts ~a arguments, given: ~e" - dom-length - val))) - - (define (check-procedure/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str) - (unless (procedure? val) - (raise-contract-error src-info - pos-blame - neg-blame - orig-str - "expected a procedure, got ~e" - val)) - (unless (procedure-arity-includes? val arity) - (raise-contract-error src-info - pos-blame - neg-blame - orig-str - "expected a ~a of arity ~a (not arity ~a), got ~e" - kind-of-thing - arity - (procedure-arity val) - val))) - - (define (check-procedure/more/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str) - (unless (procedure? val) - (raise-contract-error src-info - pos-blame - neg-blame - orig-str - "expected a procedure, got ~e" - val)) - (unless (procedure-accepts-and-more? val arity) - (raise-contract-error src-info - pos-blame - neg-blame - orig-str - "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e" - kind-of-thing - arity - (procedure-arity val) - val))) - - (define (check-procedure/more val dom-length src-info pos-blame neg-blame orig-str) - (unless (and (procedure? val) - (procedure-accepts-and-more? val dom-length)) - (raise-contract-error - src-info - pos-blame - neg-blame - orig-str - "expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e" - dom-length - dom-length - val))) - - - (define (check-rng-procedure who rng-x arity) - (unless (and (procedure? rng-x) - (procedure-arity-includes? rng-x arity)) - (error who "expected range position to be a procedure that accepts ~a arguments, given: ~e" - arity - rng-x))) - - (define (check-rng-procedure/more rng-mk-x arity) - (unless (and (procedure? rng-mk-x) - (procedure-accepts-and-more? rng-mk-x arity)) - (error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e" - arity - rng-mk-x))) - - (define (check-rng-lengths results rng-contracts) - (unless (= (length results) (length rng-contracts)) - (error '->d* - "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" - (length results) (length rng-contracts)))) - - (define (check-object val src-info pos-blame neg-blame orig-str) - (unless (object? val) - (raise-contract-error src-info - pos-blame - neg-blame - orig-str - "expected an object, got ~e" - val))) - - (define (check-method method-name val-mtd-names src-info pos-blame neg-blame orig-str) - (unless (memq method-name val-mtd-names) - (raise-contract-error src-info - pos-blame - neg-blame - orig-str - "expected an object with method ~s" - method-name))) - - (define (field-error field-name src-info pos-blame neg-blame orig-str) - (raise-contract-error src-info - pos-blame - neg-blame - orig-str - "expected an object with field ~s" - field-name)) - - #| - - test cases for procedure-accepts-and-more? - - (and (procedure-accepts-and-more? (lambda (x . y) 1) 3) - (procedure-accepts-and-more? (lambda (x . y) 1) 2) - (procedure-accepts-and-more? (lambda (x . y) 1) 1) - (not (procedure-accepts-and-more? (lambda (x . y) 1) 0)) - - (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3) - (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2) - (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1) - (not (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0)) - - (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2) - (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1) - (not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0))) - - |# - - - ;; coerce/select-contract : id (union contract? procedure-arity-1) -> contract-proc - ;; contract-proc = sym sym stx -> alpha -> alpha - ;; returns the procedure for the contract after extracting it from the - ;; struct. Coerces the argument to a flat contract if it is procedure, but first. - (define-syntax (coerce/select-contract stx) - (syntax-case stx () - [(_ name val) - (syntax (coerce/select-contract/proc 'name val))])) - - (define (coerce/select-contract/proc name x) - (cond - [(contract? x) - (contract-proc x)] - [(and (procedure? x) (procedure-arity-includes? x 1)) - (contract-proc (flat-contract x))] - [else - (error name - "expected contract or procedure of arity 1, got ~e" - x)])) - - ;; coerce-contract : id (union contract? procedure-arity-1) -> contract - ;; contract-proc = sym sym stx -> alpha -> alpha - ;; returns the procedure for the contract after extracting it from the - ;; struct. Coerces the argument to a flat contract if it is procedure, but first. - (define-syntax (coerce-contract stx) - (syntax-case stx () - [(_ name val) - (syntax (coerce-contract/proc 'name val))])) - - (define (coerce-contract/proc name x) - (cond - [(contract? x) x] - [(and (procedure? x) (procedure-arity-includes? x 1)) - (flat-contract x)] - [else - (error name - "expected contract or procedure of arity 1, got ~e" - x)])) - -; -; -; -; ; -; -; ; ; -; ; ;; ;; ; ;;; ;;; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; ;;; -; ;; ;; ; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; -; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; -; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;;;; ; ; ;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ;;; ;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; ;;; -; -; -; - - - - (provide any/c - anaphoric-contracts - flat-rec-contract - flat-murec-contract - union - and/c - not/c - =/c >=/c <=/c /c - integer-in - exact-integer-in - real-in - natural-number/c - string/len - false/c - printable/c - symbols - is-a?/c subclass?/c implementation?/c - listof list-immutableof - vectorof vector-immutableof vector/c vector-immutable/c - cons-immutable/c cons/c list-immutable/c list/c - box-immutable/c box/c - promise/c - struct/c - mixin-contract make-mixin-contract - syntax/c) - - (define-syntax (flat-rec-contract stx) - (syntax-case stx () - [(_ name ctc ...) - (identifier? (syntax name)) - (with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))] - [(pred-id ...) (generate-temporaries (syntax (ctc ...)))]) - (syntax - (let* ([pred (lambda (x) (error 'flat-rec-contract "applied too soon"))] - [name (flat-contract (let ([name (lambda (x) (pred x))]) name))]) - (let ([ctc-id (coerce-contract flat-rec-contract ctc)] ...) - (unless (flat-contract? ctc-id) - (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id)) - ... - (set! pred - (let ([pred-id (flat-contract-predicate ctc-id)] ...) - (lambda (x) - (or (pred-id x) ...)))) - name))))] - [(_ name ctc ...) - (raise-syntax-error 'flat-rec-contract "expected first argument to be an identifier" stx (syntax name))])) - - (define-syntax (flat-murec-contract stx) - (syntax-case stx () - [(_ ([name ctc ...] ...) body1 body ...) - (andmap identifier? (syntax->list (syntax (name ...)))) - (with-syntax ([((ctc-id ...) ...) (map generate-temporaries - (syntax->list (syntax ((ctc ...) ...))))] - [(pred-id ...) (generate-temporaries (syntax (name ...)))] - [((pred-arm-id ...) ...) (map generate-temporaries - (syntax->list (syntax ((ctc ...) ...))))]) - (syntax - (let* ([pred-id (lambda (x) (error 'flat-murec-contract "applied too soon"))] ... - [name (flat-contract (let ([name (lambda (x) (pred-id x))]) name))] ...) - (let-values ([(ctc-id ...) (values (coerce-contract flat-rec-contract ctc) ...)] ...) - (begin - (void) - (unless (flat-contract? ctc-id) - (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id)) - ...) ... - (set! pred-id - (let ([pred-arm-id (flat-contract-predicate ctc-id)] ...) - (lambda (x) - (or (pred-arm-id x) ...)))) ... - body1 - body ...))))] - [(_ ([name ctc ...] ...) body1 body ...) - (for-each (lambda (name) - (unless (identifier? name) - (raise-syntax-error 'flat-rec-contract - "expected an identifier" stx name))) - (syntax->list (syntax (name ...))))] - [(_ ([name ctc ...] ...)) - (raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)])) - - - (define anaphoric-contracts - (case-lambda - [() (make-anaphoric-contracts (make-hash-table 'weak))] - [(x) - (unless (eq? x 'equal) - (error 'anaphoric-contracts "expected either no arguments, or 'equal as first argument, got ~e" x)) - (make-anaphoric-contracts (make-hash-table 'equal 'weak))])) - - (define (make-anaphoric-contracts ht) - (values - (flat-named-contract - "(anaphoric-contracts,from)" - (lambda (v) - (hash-table-put! ht v #t) - v)) - (flat-named-contract - "(anaphoric-contracts,to)" - (lambda (v) - (hash-table-get ht v (lambda () #f)))))) - - (define (union . args) - (for-each - (lambda (x) - (unless (or (contract? x) - (and (procedure? x) - (procedure-arity-includes? x 1))) - (error 'union "expected procedures of arity 1 or contracts, given: ~e" x))) - args) - (let-values ([(contract fc/predicates) - (let loop ([contract #f] - [fc/predicates null] - [args args]) - (cond - [(null? args) (values contract (reverse fc/predicates))] - [else - (let ([arg (car args)]) - (cond - [(or (flat-contract? arg) - (not (contract? arg))) - (loop contract (cons arg fc/predicates) (cdr args))] - [contract - (error 'union "expected at most one non-flat contract, given ~e and ~e" - contract - arg)] - [else (loop arg fc/predicates (cdr args))]))]))]) - (let* ([flat-contracts (map (lambda (x) (if (flat-contract? x) - x - (flat-contract x))) - fc/predicates)] - [predicates (map flat-contract-predicate flat-contracts)]) - (cond - [contract - (let ([c-proc (contract-proc contract)]) - (make-contract - (apply build-compound-type-name 'union contract flat-contracts) - (lambda (pos neg src-info orig-str) - (let ([partial-contract (c-proc pos neg src-info orig-str)]) - (lambda (val) - (cond - [(ormap (lambda (pred) (pred val)) predicates) - val] - [else - (partial-contract val)]))))))] - [else - (build-flat-contract - (apply build-compound-type-name 'union flat-contracts) - (lambda (x) - (ormap (lambda (pred) (pred x)) predicates)))])))) - - (define false/c - (flat-named-contract - 'false/c - (lambda (x) (not x)))) - - (define any/c - (make-flat-contract - 'any/c - (lambda (pos neg src-info orig-str) (lambda (val) val)) - (lambda (x) #t))) - - (define (string/len n) - (unless (number? n) - (error 'string/len "expected a number as argument, got ~e" n)) - (flat-named-contract - `(string/len ,n) - (lambda (x) - (and (string? x) - ((string-length x) . < . n))))) - - (define (symbols . ss) - (unless ((length ss) . >= . 1) - (error 'symbols "expected at least one argument")) - (unless (andmap symbol? ss) - (error 'symbols "expected symbols as arguments, given: ~a" - (apply string-append (map (lambda (x) (format "~e " x)) ss)))) - (flat-named-contract - `(symbols ,@(map (lambda (x) `',x) ss)) - (lambda (x) - (memq x ss)))) - - (define printable/c - (flat-named-contract - 'printable/c - (lambda (x) - (let printable? ([x x]) - (or (symbol? x) - (string? x) - (bytes? x) - (boolean? x) - (char? x) - (null? x) - (number? x) - (regexp? x) - (and (pair? x) - (printable? (car x)) - (printable? (cdr x))) - (and (vector? x) - (andmap printable? (vector->list x))) - (and (box? x) - (printable? (unbox x)))))))) - - (define (=/c x) - (flat-named-contract - `(=/c ,x) - (lambda (y) (and (number? y) (= y x))))) - (define (>=/c x) - (flat-named-contract - `(>=/c ,x) - (lambda (y) (and (number? y) (>= y x))))) - (define (<=/c x) - (flat-named-contract - `(<=/c ,x) - (lambda (y) (and (number? y) (<= y x))))) - (define (/c x) - (flat-named-contract - `(>/c ,x) - (lambda (y) (and (number? y) (> y x))))) - - (define natural-number/c - (flat-named-contract - 'natural-number/c - (lambda (x) - (and (number? x) - (integer? x) - (x . >= . 0))))) - - (define (integer-in start end) - (unless (and (integer? start) - (integer? end)) - (error 'integer-in "expected two integers as arguments, got ~e and ~e" start end)) - (flat-named-contract - `(integer-in ,start ,end) - (lambda (x) - (and (integer? x) - (<= start x end))))) - - (define (exact-integer-in start end) - (unless (and (integer? start) - (exact? start) - (integer? end) - (exact? end)) - (error 'integer-in "expected two exact integers as arguments, got ~e and ~e" start end)) - (flat-named-contract - `(exact-integer-in ,start ,end) - (lambda (x) - (and (integer? x) - (exact? x) - (<= start x end))))) - - (define (real-in start end) - (unless (and (real? start) - (real? end)) - (error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end)) - (flat-named-contract - `(real-in ,start ,end) - (lambda (x) - (and (real? x) - (<= start x end))))) - - (define (and/c . fs) - (for-each - (lambda (x) - (unless (or (contract? x) - (and (procedure? x) - (procedure-arity-includes? x 1))) - (error 'and/c "expected procedures of arity 1 or s, given: ~e" x))) - fs) - (cond - [(null? fs) any/c] - [(andmap flat-contract/predicate? fs) - (let* ([to-predicate - (lambda (x) - (if (flat-contract? x) - (flat-contract-predicate x) - x))] - [contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)] - [pred - (let loop ([pred (to-predicate (car fs))] - [preds (cdr fs)]) - (cond - [(null? preds) pred] - [else - (let* ([fst (to-predicate (car preds))]) - (loop (let ([and/c-contract? (lambda (x) (and (pred x) (fst x)))]) - and/c-contract?) - (cdr preds)))]))]) - (flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))] - [else - (let* ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)] - [contract/procs (map contract-proc contracts)]) - (make-contract - (apply build-compound-type-name 'and/c contracts) - (lambda (pos neg src-info orig-str) - (let ([partial-contracts (map (lambda (contract/proc) (contract/proc pos neg src-info orig-str)) - contract/procs)]) - (let loop ([ctct (car partial-contracts)] - [rest (cdr partial-contracts)]) - (cond - [(null? rest) ctct] - [else - (let ([fst (car rest)]) - (loop (lambda (x) (fst (ctct x))) - (cdr rest)))]))))))])) - - (define (not/c f) - (unless (flat-contract/predicate? f) - (error 'not/c "expected a procedure of arity 1 or , given: ~e" f)) - (build-flat-contract - (build-compound-type-name 'not/c (proc/ctc->ctc f)) - (lambda (x) (not (test-proc/flat-contract f x))))) - - (define (is-a?/c <%>) - (unless (or (interface? <%>) - (class? <%>)) - (error 'is-a?/c "expected or , given: ~e" <%>)) - (let ([name (object-name <%>)]) - (flat-named-contract - (cond - [name - `(is-a?/c ,name)] - [(class? <%>) - `(is-a?/c unknown%)] - [else `(is-a?/c unknown<%>)]) - (lambda (x) (is-a? x <%>))))) - - (define (listof p) - (unless (flat-contract/predicate? p) - (error 'listof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p)) - (build-flat-contract - (build-compound-type-name 'listof (proc/ctc->ctc p)) - (lambda (v) - (and (list? v) - (andmap (lambda (ele) (test-proc/flat-contract p ele)) - v))))) - - (define-syntax (*-immutableof stx) - (syntax-case stx () - [(_ predicate? fill type-name name) - (syntax - (let ([predicate?-name predicate?] - [fill-name fill]) - (lambda (input) - (let* ([ctc (coerce-contract name input)] - [p (contract-proc ctc)]) - (make-contract - (build-compound-type-name 'name ctc) - (lambda (pos neg src-info orig-str) - (let ([p-app (p pos neg src-info orig-str)]) - (lambda (val) - (unless (predicate?-name val) - (raise-contract-error - src-info - pos - neg - orig-str - "expected <~a>, given: ~e" - 'type-name - val)) - (fill-name p-app val)))))))))])) - - (define (map-immutable f lst) - (let loop ([lst lst]) - (cond - [(pair? lst) - (cons-immutable (f (car lst)) - (loop (cdr lst)))] - [(null? lst) null]))) - - (define (immutable-list? lst) - (cond - [(and (pair? lst) - (immutable? lst)) - (immutable-list? (cdr lst))] - [(null? lst) #t] - [else #f])) - - (define list-immutableof - (*-immutableof immutable-list? map-immutable immutable-list list-immutableof)) - - (define vector-immutableof - (*-immutableof (lambda (x) (and (vector? x) (immutable? x))) - (lambda (f v) (apply vector-immutable (map f (vector->list v)))) - immutable-vector - vector-immutableof)) - - (define (vectorof p) - (unless (flat-contract/predicate? p) - (error 'vectorof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p)) - (build-flat-contract - (build-compound-type-name 'vectorof (proc/ctc->ctc p)) - (lambda (v) - (and (vector? v) - (andmap (lambda (ele) (test-proc/flat-contract p ele)) - (vector->list v)))))) - - (define (vector/c . args) - (unless (andmap flat-contract/predicate? args) - (error 'vector/c "expected flat contracts as arguments, got: ~a" - (let loop ([args args]) - (cond - [(null? args) ""] - [(null? (cdr args)) (format "~e" (car args))] - [else (string-append - (format "~e " (car args)) - (loop (cdr args)))])))) - (let ([largs (length args)]) - (build-flat-contract - (apply build-compound-type-name 'vector/c (map proc/ctc->ctc args)) - (lambda (v) - (and (vector? v) - (= (vector-length v) largs) - (andmap test-proc/flat-contract - args - (vector->list v))))))) - - (define (box/c pred) - (unless (flat-contract/predicate? pred) - (error 'box/c "expected a flat contract or a procedure of arity 1, got: ~e" pred)) - (build-flat-contract - (build-compound-type-name 'box/c (proc/ctc->ctc pred)) - (lambda (x) - (and (box? x) - (test-proc/flat-contract pred (unbox x)))))) - - (define (cons/c hdp tlp) - (unless (and (flat-contract/predicate? hdp) - (flat-contract/predicate? tlp)) - (error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e" hdp tlp)) - (build-flat-contract - (build-compound-type-name 'cons/c (proc/ctc->ctc hdp) (proc/ctc->ctc tlp)) - (lambda (x) - (and (pair? x) - (test-proc/flat-contract hdp (car x)) - (test-proc/flat-contract tlp (cdr x)))))) - - (define-syntax (*-immutable/c stx) - (syntax-case stx () - [(_ predicate? constructor (arb? selectors ...) type-name name) - (eq? #f (syntax-object->datum (syntax arb?))) - (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))] - [(p-apps ...) (generate-temporaries (syntax (selectors ...)))] - [(procs ...) (generate-temporaries (syntax (selectors ...)))] - [(selector-names ...) (generate-temporaries (syntax (selectors ...)))]) - (syntax - (let ([predicate?-name predicate?] - [constructor-name constructor] - [selector-names selectors] ...) - (lambda (params ...) - (let ([procs (coerce/select-contract name params)] ...) - (make-contract - (build-compound-type-name 'name (proc/ctc->ctc params) ...) - (lambda (pos neg src-info orig-str) - (let ([p-apps (procs pos neg src-info orig-str)] ...) - (lambda (v) - (if (and (immutable? v) - (predicate?-name v)) - (constructor-name (p-apps (selector-names v)) ...) - (raise-contract-error - src-info - pos - neg - orig-str - "expected <~a>, given: ~e" - 'type-name - v)))))))))))] - [(_ predicate? constructor (arb? selector) correct-size type-name name) - (eq? #t (syntax-object->datum (syntax arb?))) - (syntax - (let ([predicate?-name predicate?] - [constructor-name constructor] - [selector-name selector]) - (lambda params - (let ([procs (map (lambda (param) (coerce/select-contract name param)) params)]) - (make-contract - (apply build-compound-type-name 'name (map proc/ctc->ctc params)) - (lambda (pos neg src-info orig-str) - (let ([p-apps (map (lambda (proc) (proc pos neg src-info orig-str)) procs)] - [count (length params)]) - (lambda (v) - (if (and (immutable? v) - (predicate?-name v) - (correct-size count v)) - (apply constructor-name - (let loop ([p-apps p-apps] - [i 0]) - (cond - [(null? p-apps) null] - [else (let ([p-app (car p-apps)]) - (cons (p-app (selector-name v i)) - (loop (cdr p-apps) (+ i 1))))]))) - (raise-contract-error - src-info - pos - neg - orig-str - "expected <~a>, given: ~e" - 'type-name - v))))))))))])) - - (define cons-immutable/c (*-immutable/c pair? cons-immutable (#f car cdr) immutable-cons cons-immutable/c)) - (define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c)) - (define vector-immutable/c (*-immutable/c vector? - vector-immutable - (#t (lambda (v i) (vector-ref v i))) - (lambda (n v) (= n (vector-length v))) - immutable-vector - vector-immutable/c)) - - (define (list/c . args) - (unless (andmap flat-contract/predicate? args) - (error 'list/c "expected flat contracts, got: ~a" - (let loop ([args args]) - (cond - [(null? args) ""] - [(null? (cdr args)) (format "~e" (car args))] - [else (string-append - (format "~e " (car args)) - (loop (cdr args)))])))) - (let loop ([args args]) - (cond - [(null? args) (flat-contract null?)] - [else (cons/c (car args) (loop (cdr args)))]))) - - (define (list-immutable/c . args) - (unless (andmap (lambda (x) (or (contract? x) - (and (procedure? x) - (procedure-arity-includes? x 1)))) - args) - (error 'list/c "expected flat contracts or procedures of arity 1, got: ~a" - (let loop ([args args]) - (cond - [(null? args) ""] - [(null? (cdr args)) (format "~e" (car args))] - [else (string-append - (format "~e " (car args)) - (loop (cdr args)))])))) - (let loop ([args args]) - (cond - [(null? args) (flat-contract null?)] - [else (cons-immutable/c (car args) (loop (cdr args)))]))) - - (define (syntax/c ctc-in) - (let ([ctc (coerce-contract syntax/c ctc-in)]) - (build-flat-contract - (build-compound-type-name 'syntax/c ctc) - (let ([pred (flat-contract-predicate ctc)]) - (lambda (val) - (and (syntax? val) - (pred (syntax-e val)))))))) - - (define promise/c - (lambda (ctc-in) - (let* ([ctc (coerce-contract promise/c ctc-in)] - [ctc-proc (contract-proc ctc)]) - (make-contract - (build-compound-type-name 'promise/c ctc) - (lambda (pos neg src-info orig-str) - (let ([p-app (ctc-proc pos neg src-info orig-str)]) - (lambda (val) - (unless (promise? val) - (raise-contract-error - src-info - pos - neg - orig-str - "expected , given: ~e" - val)) - (delay (p-app (force val)))))))))) - - #| - as with copy-struct in struct.ss, this first begin0 - expansion "declares" that struct/c is an expression. - It prevents further expansion until the internal definition - context is sorted out. - |# - (define-syntax (struct/c stx) - (syntax-case stx () - [(_ . args) (syntax (begin0 (do-struct/c . args)))])) - - (define-syntax (do-struct/c stx) - (syntax-case stx () - [(_ struct-name args ...) - (and (identifier? (syntax struct-name)) - (syntax-local-value (syntax struct-name) (lambda () #f))) - (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))] - [(ctc-proc-x ...) (generate-temporaries (syntax (args ...)))] - [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))] - [(type-desc-id - constructor-id - predicate-id - (selector-id ...) - (mutator-id ...) - super-id) - (syntax-local-value (syntax struct-name))]) - (syntax - (let ([ctc-x (coerce-contract struct/c args)] ...) - - (unless predicate-id - (error 'struct/c "could not determine predicate for ~s" 'struct-name)) - (unless (and selector-id ...) - (error 'struct/c "could not determine selectors for ~s" 'struct-name)) - - (unless (flat-contract? ctc-x) - (error 'struct/c "expected flat contracts as arguments, got ~e" ctc-x)) - ... - - (let ([ctc-proc-x (contract-proc ctc-x)] ...) - (make-contract - (build-compound-type-name 'struct/c 'struct-name ctc-x ...) - (lambda (pos neg src-info orig-str) - (let ([ctc-app-x (ctc-proc-x pos neg src-info orig-str)] ...) - (lambda (val) - (unless (predicate-id val) - (raise-contract-error - src-info - pos - neg - orig-str - "expected <~a>, given: ~e" - 'struct-name - val)) - (ctc-app-x (selector-id val)) ... - val))))))))] - [(_ struct-name anything ...) - (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])) - - (define (flat-contract/predicate? pred) - (or (flat-contract? pred) - (and (procedure? pred) - (procedure-arity-includes? pred 1)))) - - (define (subclass?/c %) - (unless (class? %) - (error 'subclass?/c "expected , given: ~e" %)) - (let ([name (object-name %)]) - (flat-named-contract - `(subclass?/c ,(or name 'unknown%)) - (lambda (x) (subclass? x %))))) - - (define (implementation?/c <%>) - (unless (interface? <%>) - (error 'implementation?/c "expected , given: ~e" <%>)) - (let ([name (object-name <%>)]) - (flat-named-contract - `(implementation?/c ,(or name 'unknown<%>)) - (lambda (x) (implementation? x <%>))))) - - (define mixin-contract (class? . ->d . subclass?/c)) - - (define (make-mixin-contract . %/<%>s) - ((and/c (flat-contract class?) - (apply and/c (map sub/impl?/c %/<%>s))) - . ->d . - subclass?/c)) - - (define (sub/impl?/c %/<%>) - (cond - [(interface? %/<%>) (implementation?/c %/<%>)] - [(class? %/<%>) (subclass?/c %/<%>)] - [else (error 'make-mixin-contract "unknown input ~e" %/<%>)]))) + (require "private/contract.ss") + (provide (all-from-except "private/contract.ss" + make-contract + contract-proc + raise-contract-error + build-compound-type-name))) diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss new file mode 100644 index 0000000000..8a5251aa86 --- /dev/null +++ b/collects/mzlib/private/contract.ss @@ -0,0 +1,3240 @@ +#| + +improve method arity mismatch contract violation error messages? + (abstract out -> and friends even more?) + +add struct contracts for immutable structs? + +|# + +(module contract mzscheme + + ;; these are only used for building other (presumably experimental) + ;; contract combinators outside this library. They are not provided + ;; from ../contract.ss + (provide make-contract + contract-proc + raise-contract-error + build-compound-type-name) + + (provide (rename -contract contract) + any + recursive-contract + -> + ->d + ->* + ->d* + ->r + ->pp + ->pp-rest + case-> + opt-> + opt->* + object-contract + provide/contract + define/contract + contract? + contract-name + flat-contract? + flat-contract + flat-contract-predicate + flat-named-contract) + + (require-for-syntax mzscheme + "../list.ss" + (lib "stx.ss" "syntax") + (lib "name.ss" "syntax")) + + (require "class-internal.ss" + "../etc.ss" + "../list.ss" + "../pretty.ss") + + (require "contract-helpers.scm") + (require-for-syntax (prefix a: "contract-helpers.scm")) + + + +; +; +; +; ; ;;; ; ; +; ; ; ; +; ; ; ; ; ; +; ;; ; ;;; ;;;; ; ; ;; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; +; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;; ; ;;;; ; ; ; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; +; ; +; ; +; + + + ;; (define/contract id contract expr) + ;; defines `id' with `contract'; initially binding + ;; it to the result of `expr'. These variables may not be set!'d. + (define-syntax (define/contract define-stx) + (syntax-case define-stx () + [(_ name contract-expr expr) + (identifier? (syntax name)) + (with-syntax ([pos-blame-stx (datum->syntax-object define-stx 'here)] + [contract-id + (a:mangle-id define-stx + "define/contract-contract-id" + (syntax name))] + [id (a:mangle-id define-stx + "define/contract-id" + (syntax name))]) + (syntax/loc define-stx + (begin + (define contract-id contract-expr) + (define-syntax name + (make-set!-transformer + (lambda (stx) + (with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")]) + (syntax-case stx (set!) + [(set! _ arg) + (raise-syntax-error 'define/contract + "cannot set! a define/contract variable" + stx + (syntax _))] + [(_ arg (... ...)) + (syntax/loc stx + ((-contract contract-id + id + (syntax-object->datum (quote-syntax _)) + (string->symbol neg-blame-str) + (quote-syntax _)) + arg + (... ...)))] + [_ + (identifier? (syntax _)) + (syntax/loc stx + (-contract contract-id + id + (syntax-object->datum (quote-syntax _)) + (string->symbol neg-blame-str) + (quote-syntax _)))]))))) + (define id (let ([name expr]) name)) ;; let for procedure naming + )))] + [(_ name contract-expr expr) + (raise-syntax-error 'define/contract "expected identifier in first position" + define-stx + (syntax name))])) + + +; +; +; +; ; ; ; +; ; ; +; ; ; ; ; +; ; ;; ; ; ;;; ; ; ; ;; ; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; +; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;; ; ;;; ; ; ;; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; +; ; ; +; ; ; +; ; + + + ;; (provide/contract p/c-ele ...) + ;; p/c-ele = (id expr) | (rename id id expr) | (struct (id expr) ...) + ;; provides each `id' with the contract `expr'. + (define-syntax (provide/contract provide-stx) + (syntax-case provide-stx (struct) + [(_ p/c-ele ...) + (let () + + ;; code-for-each-clause : (listof syntax) -> (listof syntax) + ;; constructs code for each clause of a provide/contract + (define (code-for-each-clause clauses) + (cond + [(null? clauses) null] + [else + (let ([clause (car clauses)]) + (syntax-case clause (struct rename) + [(rename this-name new-name contract) + (and (identifier? (syntax this-name)) + (identifier? (syntax new-name))) + (cons (code-for-one-id provide-stx (syntax this-name) (syntax contract) (syntax new-name)) + (code-for-each-clause (cdr clauses)))] + [(rename this-name new-name contract) + (identifier? (syntax this-name)) + (raise-syntax-error 'provide/contract + "malformed rename clause, expected an identifier" + provide-stx + (syntax new-name))] + [(rename this-name new-name contract) + (identifier? (syntax new-name)) + (raise-syntax-error 'provide/contract + "malformed rename clause, expected an identifier" + provide-stx + (syntax this-name))] + [(rename . _) + (raise-syntax-error 'provide/contract "malformed rename clause" provide-stx clause)] + [(struct struct-name ((field-name contract) ...)) + (and (well-formed-struct-name? (syntax struct-name)) + (andmap identifier? (syntax->list (syntax (field-name ...))))) + (let ([sc (build-struct-code provide-stx + (syntax struct-name) + (syntax->list (syntax (field-name ...))) + (syntax->list (syntax (contract ...))))]) + (cons sc (code-for-each-clause (cdr clauses))))] + [(struct name) + (identifier? (syntax name)) + (raise-syntax-error 'provide/contract + "missing fields" + provide-stx + clause)] + [(struct name . rest) + (not (well-formed-struct-name? (syntax name))) + (raise-syntax-error 'provide/contract "name must be an identifier or two identifiers with parens around them" + provide-stx + (syntax name))] + [(struct name (fields ...)) + (for-each (lambda (field) + (syntax-case field () + [(x y) + (identifier? (syntax x)) + (void)] + [(x y) + (raise-syntax-error 'provide/contract + "malformed struct field, expected identifier" + provide-stx + (syntax x))] + [else + (raise-syntax-error 'provide/contract + "malformed struct field" + provide-stx + field)])) + (syntax->list (syntax (fields ...)))) + + ;; if we didn't find a bad field something is wrong! + (raise-syntax-error 'provide/contract "internal error" provide-stx clause)] + [(struct name . fields) + (raise-syntax-error 'provide/contract + "malformed struct fields" + provide-stx + clause)] + [(name contract) + (identifier? (syntax name)) + (cons (code-for-one-id provide-stx (syntax name) (syntax contract) #f) + (code-for-each-clause (cdr clauses)))] + [(name contract) + (raise-syntax-error 'provide/contract + "expected identifier" + provide-stx + (syntax name))] + [unk + (raise-syntax-error 'provide/contract + "malformed clause" + provide-stx + (syntax unk))]))])) + + ;; well-formed-struct-name? : syntax -> bool + (define (well-formed-struct-name? stx) + (or (identifier? stx) + (syntax-case stx () + [(name super) + (and (identifier? (syntax name)) + (identifier? (syntax super))) + #t] + [else #f]))) + + ;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax + ;; constructs the code for a struct clause + ;; first arg is the original syntax object, for source locations + (define (build-struct-code stx struct-name-position field-names field-contracts) + (let* ([struct-name (syntax-case struct-name-position () + [(a b) (syntax a)] + [else struct-name-position])] + [parent-struct-count (let ([parent-info (extract-parent-struct-info struct-name-position)]) + (and parent-info + (let ([fields (cadddr parent-info)]) + (cond + [(null? fields) 0] + [(not (car (last-pair fields))) + (raise-syntax-error + 'provide/contract + "cannot determine the number of fields in super struct" + provide-stx + struct-name)] + [else (length fields)]))))] + [field-contract-ids (map (lambda (field-name) + (a:mangle-id provide-stx + "provide/contract-field-contract" + field-name + struct-name)) + field-names)] + [selector-ids (map (lambda (field-name) + (build-selector-id struct-name field-name)) + field-names)] + [mutator-ids (map (lambda (field-name) + (build-mutator-id struct-name field-name)) + field-names)] + [predicate-id (build-predicate-id struct-name)] + [constructor-id (build-constructor-id struct-name)]) + (with-syntax ([(selector-codes ...) + (filter + (lambda (x) x) + (map/count (lambda (selector-id field-contract-id index) + (if (or (not parent-struct-count) + (parent-struct-count . <= . index)) + (code-for-one-id stx + selector-id + (build-selector-contract struct-name + predicate-id + field-contract-id) + #f) + #f)) + selector-ids + field-contract-ids))] + [(mutator-codes ...) + (filter + (lambda (x) x) + (map/count (lambda (mutator-id field-contract-id index) + (if (or (not parent-struct-count) + (parent-struct-count . <= . index)) + (code-for-one-id stx + mutator-id + (build-mutator-contract struct-name + predicate-id + field-contract-id) + #f) + #f)) + mutator-ids + field-contract-ids))] + [predicate-code (code-for-one-id stx predicate-id (syntax (-> any/c boolean?)) #f)] + [constructor-code (code-for-one-id + stx + constructor-id + (build-constructor-contract stx + field-contract-ids + predicate-id) + #f)] + [(field-contracts ...) field-contracts] + [(field-contract-ids ...) field-contract-ids] + [struct-name struct-name] + [struct:struct-name (datum->syntax-object + struct-name + (string->symbol + (string-append + "struct:" + (symbol->string (syntax-e struct-name)))))]) + (syntax/loc stx + (begin + (define field-contract-ids field-contracts) ... + selector-codes ... + mutator-codes ... + predicate-code + constructor-code + (provide struct-name struct:struct-name)))))) + + ;; map/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z) + (define (map/count f l1 l2) + (let loop ([l1 l1] + [l2 l2] + [i 0]) + (cond + [(and (null? l1) (null? l2)) '()] + [(or (null? l1) (null? l2)) (error 'map/count "mismatched lists")] + [else (cons (f (car l1) (car l2) i) + (loop (cdr l1) + (cdr l2) + (+ i 1)))]))) + + ;; extract-parent-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) + (define (extract-parent-struct-info stx) + (syntax-case stx () + [(a b) + (syntax-local-value + (syntax b) + (lambda () + (raise-syntax-error 'provide/contract + "expected a struct name" + provide-stx + (syntax b))))] + [a #f])) + + ;; build-constructor-contract : syntax (listof syntax) syntax -> syntax + (define (build-constructor-contract stx field-contract-ids predicate-id) + (with-syntax ([(field-contract-ids ...) field-contract-ids] + [predicate-id predicate-id]) + (syntax/loc stx + (field-contract-ids + ... + . -> . + (let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id))))) + + ;; build-selector-contract : syntax syntax -> syntax + ;; constructs the contract for a selector + (define (build-selector-contract struct-name predicate-id field-contract-id) + (with-syntax ([field-contract-id field-contract-id] + [predicate-id predicate-id]) + (syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id) + . -> . + field-contract-id)))) + + ;; build-mutator-contract : syntax syntax -> syntax + ;; constructs the contract for a selector + (define (build-mutator-contract struct-name predicate-id field-contract-id) + (with-syntax ([field-contract-id field-contract-id] + [predicate-id predicate-id]) + (syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id) + field-contract-id + . -> . + void?)))) + + ;; build-constructor-id : syntax -> syntax + ;; constructs the name of the selector for a particular field of a struct + (define (build-constructor-id struct-name) + (datum->syntax-object + struct-name + (string->symbol + (string-append + "make-" + (symbol->string (syntax-object->datum struct-name)))))) + + ;; build-predicate-id : syntax -> syntax + ;; constructs the name of the selector for a particular field of a struct + (define (build-predicate-id struct-name) + (datum->syntax-object + struct-name + (string->symbol + (string-append + (symbol->string (syntax-object->datum struct-name)) + "?")))) + + ;; build-selector-id : syntax syntax -> syntax + ;; constructs the name of the selector for a particular field of a struct + (define (build-selector-id struct-name field-name) + (datum->syntax-object + struct-name + (string->symbol + (string-append + (symbol->string (syntax-object->datum struct-name)) + "-" + (symbol->string (syntax-object->datum field-name)))))) + + ;; build-mutator-id : syntax syntax -> syntax + ;; constructs the name of the selector for a particular field of a struct + (define (build-mutator-id struct-name field-name) + (datum->syntax-object + struct-name + (string->symbol + (string-append + "set-" + (symbol->string (syntax-object->datum struct-name)) + "-" + (symbol->string (syntax-object->datum field-name)) + "!")))) + + ;; code-for-one-id : syntax syntax syntax (union syntax #f) -> syntax + ;; given the syntax for an identifier and a contract, + ;; builds a begin expression for the entire contract and provide + ;; the first syntax object is used for source locations + (define (code-for-one-id stx id ctrct user-rename-id) + (with-syntax ([id-rename (a:mangle-id provide-stx "provide/contract-id" id)] + [contract-id (a:mangle-id provide-stx "provide/contract-contract-id" id)] + [pos-module-source (a:mangle-id provide-stx "provide/contract-pos-module-source" id)] + [pos-stx (datum->syntax-object provide-stx 'here)] + [id id] + [ctrct ctrct]) + (with-syntax ([provide-clause (if user-rename-id + (with-syntax ([user-rename-id user-rename-id]) + (syntax (provide (rename id-rename user-rename-id)))) + (syntax (provide (rename id-rename id))))]) + (syntax/loc stx + (begin + provide-clause + + ;; unbound id check + (if #f id) + + (define pos-module-source (module-source-as-symbol #'pos-stx)) + (define contract-id (let ([id ctrct]) id)) + (define-syntax id-rename + (make-set!-transformer + (lambda (stx) + (with-syntax ([neg-stx (datum->syntax-object stx 'here)]) + (syntax-case stx (set!) + [(set! _ body) (raise-syntax-error + #f + "cannot set! provide/contract identifier" + stx + (syntax _))] + [(_ arg (... ...)) + (syntax + ((begin-lifted + (-contract contract-id + id + pos-module-source + (module-source-as-symbol #'neg-stx) + (quote-syntax _))) + arg + (... ...)))] + [_ + (identifier? (syntax _)) + (syntax + (begin-lifted + (-contract contract-id + id + pos-module-source + (module-source-as-symbol #'neg-stx) + (quote-syntax _))))])))))))))) + + (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))]) + (syntax + (begin + bodies ...))))])) + + + ; + ; + ; + ; + ; + ; ; ; + ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; + ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ;;;; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; + ; + ; + ; + + ;; contract = (make-contract sexp + ;; (sym + ;; sym + ;; (union syntax #f) + ;; string + ;; -> + ;; (alpha -> alpha))) + ;; the first arg to make-contract builds the name of the contract. The + ;; path records how the violation occurs + ;; + ;; generic contract container; + ;; the first arg to proc is a symbol representing the name of the positive blame + ;; the second arg to proc is the symbol representing the name of the negative blame + ;; the third argument to proc is the src-info. + ;; the fourth argumet is a textual representation of the original contract + ;; + ;; the argument to the result function is the value to test. + ;; (the result function is the projection) + ;; + (define-values (make-flat-contract + flat-contract-predicate + flat-contract? + + make-contract + contract-name + contract-proc + contract?) + (let () + (define-struct contract (name proc)) + (define-struct (flat-contract contract) (predicate)) + (values make-flat-contract + flat-contract-predicate + flat-contract? + + make-contract + contract-name + contract-proc + contract?))) + + (define (test-proc/flat-contract f x) + (if (flat-contract? f) + ((flat-contract-predicate f) x) + (f x))) + + (define (proc/ctc->ctc f) + (if (contract? f) + f + (flat-named-contract + (or (object-name f) + (string->symbol (format "contract:~e" f))) + f))) + + + + ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) + (define (build-compound-type-name . fs) + (let loop ([subs fs] + [i 0]) + (cond + [(null? subs) + '()] + [else (let ([sub (car subs)]) + (cond + [(contract? sub) + (let ([mk-sub-name (contract-name sub)]) + `(,mk-sub-name ,@(loop (cdr subs) (+ i 1))))] + [else `(,sub ,@(loop (cdr subs) i))]))]))) + + (define (flat-contract predicate) + (unless (and (procedure? predicate) + (procedure-arity-includes? predicate 1)) + (error 'flat-contract + "expected procedure of one argument as argument, given ~e" + predicate)) + (let ([pname (object-name predicate)]) + (if pname + (flat-named-contract pname predicate) + (flat-named-contract '??? predicate)))) + + (define (flat-named-contract name predicate) + (unless (and (procedure? predicate) + (procedure-arity-includes? predicate 1)) + (error 'flat-named-contract + "expected procedure of one argument as second argument, given: ~e, fst arg ~e" + predicate name)) + (build-flat-contract name predicate)) + + (define (build-flat-contract name predicate) + (make-flat-contract + name + (lambda (pos neg src-info orig-str) + (lambda (val) + (if (predicate val) + val + (raise-contract-error + src-info + pos + neg + orig-str + "expected <~a>, given: ~e" + name + val)))) + predicate)) + + (define-syntax (-contract stx) + (syntax-case stx () + [(_ a-contract to-check pos-blame-e neg-blame-e) + (with-syntax ([src-loc (syntax/loc stx here)]) + (syntax/loc stx + (contract/proc a-contract to-check pos-blame-e neg-blame-e (quote-syntax src-loc))))] + [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) + (syntax/loc stx + (contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e))])) + + (define (contract/proc a-contract-raw name pos-blame neg-blame src-info) + (unless (or (contract? a-contract-raw) + (and (procedure? a-contract-raw) + (procedure-arity-includes? a-contract-raw 1))) + (error 'contract "expected a contract or a procedure of arity 1 as first argument, given: ~e, other args ~e ~e ~e ~e" + a-contract-raw + name + pos-blame + neg-blame + src-info)) + (let ([a-contract (if (contract? a-contract-raw) + a-contract-raw + (flat-contract a-contract-raw))]) + (unless (and (symbol? neg-blame) + (symbol? pos-blame)) + (error 'contract + "expected symbols as names for assigning blame, given: ~e and ~e, other args ~e ~e ~e" + neg-blame pos-blame + a-contract-raw + name + src-info)) + (unless (syntax? src-info) + (error 'contract "expected syntax as last argument, given: ~e, other args ~e ~e ~e ~e" + src-info + neg-blame + pos-blame + a-contract-raw + name)) + (((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract)) + name))) + + (define-values (make-exn:fail:contract2 + exn:fail:contract2? + exn:fail:contract2-srclocs) + (let-values ([(exn:fail:contract2 + make-exn:fail:contract2 + exn:fail:contract2? + get + set) + (parameterize ([current-inspector (make-inspector)]) + (make-struct-type 'exn:fail:contract2 + struct:exn:fail + 1 + 0 + #f + (list (cons prop:exn:srclocs (lambda (x) (exn:fail:contract2-srclocs x))))))]) + (values + make-exn:fail:contract2 + exn:fail:contract2? + (lambda (x) (get x 0))))) + + ;; raise-contract-error : (union syntax #f) symbol symbol string string args ... -> alpha + ;; doesn't return + (define (raise-contract-error src-info to-blame other-party contract-sexp fmt . args) + (let ([blame-src (src-info-as-string src-info)] + [formatted-contract-sexp + (let ([one-line (format "~s" contract-sexp)]) + (if (< (string-length one-line) 30) + (string-append one-line " ") + (let ([sp (open-output-string)]) + (newline sp) + (parameterize ([pretty-print-print-line print-contract-liner] + [pretty-print-columns 50]) + (pretty-print contract-sexp sp)) + (get-output-string sp))))] + [specific-blame + (let ([datum (syntax-object->datum src-info)]) + (if (symbol? datum) + (format " on ~a" datum) + ""))]) + (raise + (make-exn:fail:contract2 + (string->immutable-string + (string-append (format "~a~a broke the contract ~ait had with ~a~a; " + blame-src + to-blame + formatted-contract-sexp + other-party + specific-blame) + (apply format fmt args))) + (current-continuation-marks) + (if src-info + (list (make-srcloc + (syntax-source src-info) + (syntax-line src-info) + (syntax-column src-info) + (syntax-position src-info) + (syntax-span src-info))) + '()))))) + + (define print-contract-liner + (let ([default (pretty-print-print-line)]) + (λ (line port ol cols) + (+ (default line port ol cols) + (if line + (begin (display " " port) + 2) + 0))))) + + ;; src-info-as-string : (union syntax #f) -> string + (define (src-info-as-string src-info) + (if (syntax? src-info) + (let ([src-loc-str (build-src-loc-string src-info)]) + (if src-loc-str + (string-append src-loc-str ": ") + "")) + "")) + + (define-syntax (recursive-contract stx) + (syntax-case stx () + [(_ arg) + (syntax (recursive-contract/proc '(recursive-contract arg) (delay (check-contract arg))))])) + + (define (recursive-contract/proc name delayed-contract) + (make-contract name + (λ (pos neg src str) + (let ([proc (contract-proc (force delayed-contract))]) + (λ (val) + ((proc pos neg src str) val)))))) + + (define (check-contract ctc) + (unless (contract? ctc) + (error 'recursive-contract "expected a contract, got ~e" ctc)) + ctc) + +; +; +; +; +; +; ; ; ; +; ;; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; ;;; +; ;; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; +; ;; ; ; ; ; ; ; ; ; ; ; ;; +; ;;;;;; ;; ; ; ; ; ; ; ; ;;;; ; ; ;; +; ;; ; ; ; ; ; ; ; ; ; ; ; ; +; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; ;;; +; +; +; + + + (define-syntax (any stx) + (raise-syntax-error 'any "Use any out of an arrow contract" stx)) + + (define-syntax-set (-> ->* ->d ->d* ->r ->pp ->pp-rest case-> object-contract opt-> opt->*) + + (define (->/proc stx) (make-/proc #f ->/h stx)) + (define (->*/proc stx) (make-/proc #f ->*/h stx)) + (define (->d/proc stx) (make-/proc #f ->d/h stx)) + (define (->d*/proc stx) (make-/proc #f ->d*/h stx)) + (define (->r/proc stx) (make-/proc #f ->r/h stx)) + (define (->pp/proc stx) (make-/proc #f ->pp/h stx)) + (define (->pp-rest/proc stx) (make-/proc #f ->pp-rest/h stx)) + + (define (obj->/proc stx) (make-/proc #t ->/h stx)) + (define (obj->*/proc stx) (make-/proc #t ->*/h stx)) + (define (obj->d/proc stx) (make-/proc #t ->d/h stx)) + (define (obj->d*/proc stx) (make-/proc #t ->d*/h stx)) + (define (obj->r/proc stx) (make-/proc #t ->r/h stx)) + (define (obj->pp/proc stx) (make-/proc #t ->pp/h stx)) + (define (obj->pp-rest/proc stx) (make-/proc #t ->pp-rest/h stx)) + + (define (case->/proc stx) (make-case->/proc #f stx)) + (define (obj-case->/proc stx) (make-case->/proc #t stx)) + + (define (obj-opt->/proc stx) (make-opt->/proc #t stx)) + (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx)) + (define (opt->/proc stx) (make-opt->/proc #f stx)) + (define (opt->*/proc stx) (make-opt->*/proc #f stx)) + + ;; make-/proc : boolean + ;; (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) + ;; syntax + ;; -> (syntax -> syntax) + (define (make-/proc method-proc? /h stx) + (let-values ([(arguments-check build-proj check-val wrapper) (/h method-proc? stx)]) + (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]) + (with-syntax ([inner-check (check-val outer-args)] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(val-args body) (wrapper outer-args)]) + (with-syntax ([inner-lambda + (set-inferred-name-from + stx + (syntax/loc stx (lambda val-args body)))]) + (let ([inner-lambda-w/err-check + (syntax + (lambda (val) + inner-check + inner-lambda))]) + (with-syntax ([proj-code (build-proj outer-args inner-lambda-w/err-check)]) + (arguments-check + outer-args + (syntax/loc stx + (make-contract + name-id + (lambda (pos-blame neg-blame src-info orig-str) + proj-code))))))))))) + + (define (make-case->/proc method-proc? stx) + (syntax-case stx () + [(_ cases ...) + (let-values ([(arguments-check build-projs check-val wrapper) + (case->/h method-proc? stx (syntax->list (syntax (cases ...))))]) + (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]) + (with-syntax ([(inner-check ...) (check-val outer-args)] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(body ...) (wrapper outer-args)]) + (with-syntax ([inner-lambda + (set-inferred-name-from + stx + (syntax/loc stx (case-lambda body ...)))]) + (let ([inner-lambda-w/err-check + (syntax + (lambda (val) + inner-check ... + inner-lambda))]) + (with-syntax ([proj-code (build-projs outer-args inner-lambda-w/err-check)]) + (arguments-check + outer-args + (syntax/loc stx + (make-contract + (apply build-compound-type-name 'case-> name-id) + (lambda (pos-blame neg-blame src-info orig-str) + proj-code))))))))))])) + + (define (make-opt->/proc method-proc? stx) + (syntax-case stx (any) + [(_ (reqs ...) (opts ...) any) + (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)))] + [(_ (reqs ...) (opts ...) res) + (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))))])) + + (define (make-opt->*/proc method-proc? stx) + (syntax-case stx (any) + [(_ (reqs ...) (opts ...) any) + (let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))] + [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))] + [cses + (reverse + (let loop ([opt-vs (reverse opt-vs)]) + (cond + [(null? opt-vs) (list req-vs)] + [else (cons (append req-vs (reverse opt-vs)) + (loop (cdr opt-vs)))])))]) + (with-syntax ([(req-vs ...) req-vs] + [(opt-vs ...) opt-vs] + [((case-doms ...) ...) cses]) + (with-syntax ([expanded-case-> + (make-case->/proc + method-proc? + (syntax (case-> (-> case-doms ... any) ...)))]) + (syntax/loc stx + (let ([req-vs reqs] ... + [opt-vs opts] ...) + expanded-case->)))))] + [(_ (reqs ...) (opts ...) (ress ...)) + (let* ([res-vs (generate-temporaries (syntax->list (syntax (ress ...))))] + [req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))] + [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))] + [cses + (reverse + (let loop ([opt-vs (reverse opt-vs)]) + (cond + [(null? opt-vs) (list req-vs)] + [else (cons (append req-vs (reverse opt-vs)) + (loop (cdr opt-vs)))])))]) + (with-syntax ([(res-vs ...) res-vs] + [(req-vs ...) req-vs] + [(opt-vs ...) opt-vs] + [((case-doms ...) ...) cses]) + (with-syntax ([(single-case-result ...) + (let* ([ress-lst (syntax->list (syntax (ress ...)))] + [only-one? + (and (pair? ress-lst) + (null? (cdr ress-lst)))]) + (map + (if only-one? + (lambda (x) (car (syntax->list (syntax (res-vs ...))))) + (lambda (x) (syntax (values res-vs ...)))) + cses))]) + (with-syntax ([expanded-case-> + (make-case->/proc + method-proc? + (syntax (case-> (-> case-doms ... single-case-result) ...)))]) + (set-inferred-name-from + stx + (syntax/loc stx + (let ([res-vs ress] + ... + [req-vs reqs] + ... + [opt-vs opts] + ...) + expanded-case->)))))))])) + + ;; exactract-argument-lists : syntax -> (listof syntax) + (define (extract-argument-lists stx) + (map (lambda (x) + (syntax-case x () + [(arg-list body) (syntax arg-list)])) + (syntax->list stx))) + + ;; ensure-cases-disjoint : syntax syntax[list] -> void + (define (ensure-cases-disjoint stx cases) + (let ([individual-cases null] + [dot-min #f]) + (for-each (lambda (case) + (let ([this-case (get-case case)]) + (cond + [(number? this-case) + (cond + [(member this-case individual-cases) + (raise-syntax-error + 'case-> + (format "found multiple cases with ~a arguments" this-case) + stx)] + [(and dot-min (dot-min . <= . this-case)) + (raise-syntax-error + 'case-> + (format "found overlapping cases (~a+ followed by ~a)" dot-min this-case) + stx)] + [else (set! individual-cases (cons this-case individual-cases))])] + [(pair? this-case) + (let ([new-dot-min (car this-case)]) + (cond + [dot-min + (if (dot-min . <= . new-dot-min) + (raise-syntax-error + 'case-> + (format "found overlapping cases (~a+ followed by ~a+)" dot-min new-dot-min) + stx) + (set! dot-min new-dot-min))] + [else + (set! dot-min new-dot-min)]))]))) + cases))) + + ;; get-case : syntax -> (union number (cons number 'more)) + (define (get-case stx) + (let ([ilist (syntax-object->datum stx)]) + (if (list? ilist) + (length ilist) + (cons + (let loop ([i ilist]) + (cond + [(pair? i) (+ 1 (loop (cdr i)))] + [else 0])) + 'more)))) + + + ;; case->/h : boolean + ;; syntax + ;; (listof syntax) + ;; -> (values (syntax -> syntax) + ;; (syntax -> syntax) + ;; (syntax syntax -> syntax) + ;; (syntax -> syntax)) + ;; like the other /h functions, but composes the wrapper functions + ;; together and combines the cases of the case-lambda into a single list. + (define (case->/h method-proc? orig-stx cases) + (let loop ([cases cases] + [name-ids '()]) + (cond + [(null? cases) (values (lambda (outer-args body) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [body body] + [(name-ids ...) (reverse name-ids)]) + (syntax + (let ([name-id (list name-ids ...)]) + body)))) + (lambda (x y) y) + (lambda (args) (syntax ())) + (lambda (args) (syntax ())))] + [else + (let ([/h (select/h (car cases) 'case-> orig-stx)] + [new-id (car (generate-temporaries (syntax (case->name-id))))]) + (let-values ([(arguments-checks build-projs check-vals wrappers) + (loop (cdr cases) (cons new-id name-ids))] + [(arguments-check build-proj check-val wrapper) + (/h method-proc? (car cases))]) + (values + (lambda (outer-args x) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [new-id new-id]) + (arguments-check + (syntax (val pos-blame neg-blame src-info orig-str new-id)) + (arguments-checks + outer-args + x)))) + (lambda (args inner) + (build-projs + args + (build-proj + args + inner))) + (lambda (args) + (with-syntax ([checks (check-vals args)] + [check (check-val args)]) + (syntax (check . checks)))) + (lambda (args) + (with-syntax ([case (wrapper args)] + [cases (wrappers args)]) + (syntax (case . cases)))))))]))) + + (define (object-contract/proc stx) + + ;; name : syntax + ;; ctc-stx : syntax[evals to a contract] + ;; mtd-arg-stx : syntax[list of arg-specs] (ie, for use in a case-lambda) + (define-struct mtd (name ctc-stx mtd-arg-stx)) + + ;; name : syntax + ;; ctc-stx : syntax[evals to a contract] + (define-struct fld (name ctc-stx)) + + ;; expand-field/mtd-spec : stx -> (union mtd fld) + (define (expand-field/mtd-spec f/m-stx) + (syntax-case f/m-stx (field) + [(field field-name ctc) + (identifier? (syntax field-name)) + (make-fld (syntax field-name) (syntax ctc))] + [(field field-name ctc) + (raise-syntax-error 'object-contract "expected name of field" stx (syntax field-name))] + [(mtd-name ctc) + (identifier? (syntax mtd-name)) + (let-values ([(ctc-stx proc-stx) (expand-mtd-contract (syntax ctc))]) + (make-mtd (syntax mtd-name) + ctc-stx + proc-stx))] + [(mtd-name ctc) + (raise-syntax-error 'object-contract "expected name of method" stx (syntax mtd-name))] + [_ (raise-syntax-error 'object-contract "expected field or method clause" stx f/m-stx)])) + + ;; expand-mtd-contract : syntax -> (values syntax[expanded ctc] syntax[mtd-arg]) + (define (expand-mtd-contract mtd-stx) + (syntax-case mtd-stx (case-> opt-> opt->*) + [(case-> cases ...) + (let loop ([cases (syntax->list (syntax (cases ...)))] + [ctc-stxs null] + [args-stxs null]) + (cond + [(null? cases) + (values + (with-syntax ([(x ...) (reverse ctc-stxs)]) + (obj-case->/proc (syntax (case-> x ...)))) + (with-syntax ([(x ...) (apply append (map syntax->list (reverse args-stxs)))]) + (syntax (x ...))))] + [else + (let-values ([(trans ctc-stx mtd-args) (expand-mtd-arrow (car cases))]) + (loop (cdr cases) + (cons ctc-stx ctc-stxs) + (cons mtd-args args-stxs)))]))] + [(opt->* (req-contracts ...) (opt-contracts ...) (res-contracts ...)) + (values + (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) (res-contracts ...)))) + (generate-opt->vars (syntax (req-contracts ...)) + (syntax (opt-contracts ...))))] + [(opt->* (req-contracts ...) (opt-contracts ...) any) + (values + (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) any))) + (generate-opt->vars (syntax (req-contracts ...)) + (syntax (opt-contracts ...))))] + [(opt-> (req-contracts ...) (opt-contracts ...) res-contract) + (values + (obj-opt->/proc (syntax (opt-> (any/c req-contracts ...) (opt-contracts ...) res-contract))) + (generate-opt->vars (syntax (req-contracts ...)) + (syntax (opt-contracts ...))))] + [else (let-values ([(x y z) (expand-mtd-arrow mtd-stx)]) + (values (x y) z))])) + + ;; generate-opt->vars : syntax[requried contracts] syntax[optional contracts] -> syntax[list of arg specs] + (define (generate-opt->vars req-stx opt-stx) + (with-syntax ([(req-vars ...) (generate-temporaries req-stx)] + [(ths) (generate-temporaries (syntax (ths)))]) + (let loop ([opt-vars (generate-temporaries opt-stx)]) + (cond + [(null? opt-vars) (list (syntax (ths req-vars ...)))] + [else (with-syntax ([(opt-vars ...) opt-vars] + [(rests ...) (loop (cdr opt-vars))]) + (syntax ((ths req-vars ... opt-vars ...) + rests ...)))])))) + + ;; expand-mtd-arrow : stx -> (values (syntax[ctc] -> syntax[expanded ctc]) syntax[ctc] syntax[mtd-arg]) + (define (expand-mtd-arrow mtd-stx) + (syntax-case mtd-stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) + [(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)] + [(-> args ...) + (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))]) + (values obj->/proc + (syntax (-> any/c args ...)) + (syntax ((arg-vars ...)))))] + [(->* (doms ...) (rngs ...)) + (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))]) + (values obj->*/proc + (syntax (->* (any/c doms ...) (rngs ...))) + (syntax ((this-var args-vars ...)))))] + [(->* (doms ...) rst (rngs ...)) + (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] + [(rst-var) (generate-temporaries (syntax (rst)))] + [(this-var) (generate-temporaries (syntax (this-var)))]) + (values obj->*/proc + (syntax (->* (any/c doms ...) rst (rngs ...))) + (syntax ((this-var args-vars ... . rst-var)))))] + [(->* x ...) + (raise-syntax-error 'object-contract "malformed ->*" stx mtd-stx)] + [(->d) (raise-syntax-error 'object-contract "->d must have arguments" stx mtd-stx)] + [(->d doms ... rng-proc) + (let ([doms-val (syntax->list (syntax (doms ...)))]) + (values + obj->d/proc + (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] + [arity-count (length doms-val)]) + (syntax + (->d any/c doms ... + (let ([f rng-proc]) + (check->* f arity-count) + (lambda (_this-var arg-vars ...) + (f arg-vars ...)))))) + (with-syntax ([(args-vars ...) (generate-temporaries doms-val)]) + (syntax ((this-var args-vars ...))))))] + [(->d* (doms ...) rng-proc) + (values + obj->d*/proc + (let ([doms-val (syntax->list (syntax (doms ...)))]) + (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] + [arity-count (length doms-val)]) + (syntax (->d* (any/c doms ...) + (let ([f rng-proc]) + (check->* f arity-count) + (lambda (_this-var arg-vars ...) + (f arg-vars ...))))))) + (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))]) + (syntax ((this-var args-vars ...)))))] + [(->d* (doms ...) rst-ctc rng-proc) + (let ([doms-val (syntax->list (syntax (doms ...)))]) + (values + obj->d*/proc + (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] + [(rest-var) (generate-temporaries (syntax (rst-ctc)))] + [arity-count (length doms-val)]) + (syntax (->d* (any/c doms ...) + rst-ctc + (let ([f rng-proc]) + (check->*/more f arity-count) + (lambda (_this-var arg-vars ... . rest-var) + (apply f arg-vars ... rest-var)))))) + (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] + [(rst-var) (generate-temporaries (syntax (rst-ctc)))] + [(this-var) (generate-temporaries (syntax (this-var)))]) + (syntax ((this-var args-vars ... . rst-var))))))] + [(->d* x ...) + (raise-syntax-error 'object-contract "malformed ->d* method contract" stx mtd-stx)] + + [(->r ([x dom] ...) rng) + (andmap identifier? (syntax->list (syntax (x ...)))) + (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]) + (values + obj->r/proc + (syntax (->r ([_this any/c] [x dom] ...) rng)) + (syntax ((_this arg-vars ...)))))] + + [(->r ([x dom] ...) rest-x rest-dom rng) + (andmap identifier? (syntax->list (syntax (x ...)))) + (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]) + (values + obj->r/proc + (syntax (->r ([_this any/c] [x dom] ...) rest-x rest-dom rng)) + (syntax ((_this arg-vars ... . rest-var)))))] + + [(->r . x) + (raise-syntax-error 'object-contract "malformed ->r declaration")] + [(->pp ([x dom] ...) . other-stuff) + (andmap identifier? (syntax->list (syntax (x ...)))) + (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]) + (values + obj->pp/proc + (syntax (->pp ([_this any/c] [x dom] ...) . other-stuff)) + (syntax ((_this arg-vars ...)))))] + [(->pp . x) + (raise-syntax-error 'object-contract "malformed ->pp declaration")] + [(->pp-rest ([x dom] ...) rest-id . other-stuff) + (and (identifier? (syntax id)) + (andmap identifier? (syntax->list (syntax (x ...))))) + (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]) + (values + obj->pp-rest/proc + (syntax (->pp ([_this any/c] [x dom] ...) rest-id . other-stuff)) + (syntax ((_this arg-vars ... . rest-id)))))] + [(->pp-rest . x) + (raise-syntax-error 'object-contract "malformed ->pp-rest declaration")] + [else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)])) + + ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc] + (define (build-methods-stx mtds) + (let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)] + [names (map mtd-name mtds)] + [i 0]) + (cond + [(null? arg-spec-stxss) null] + [else (let ([arg-spec-stxs (car arg-spec-stxss)]) + (with-syntax ([(cases ...) + (map (lambda (arg-spec-stx) + (with-syntax ([i i]) + (syntax-case arg-spec-stx () + [(this rest-ids ...) + (syntax + ((this rest-ids ...) + ((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))] + [else + (let-values ([(this rest-ids last-var) + (let ([lst (syntax->improper-list arg-spec-stx)]) + (values (car lst) + (all-but-last (cdr lst)) + (cdr (last-pair lst))))]) + (with-syntax ([this this] + [(rest-ids ...) rest-ids] + [last-var last-var]) + (syntax + ((this rest-ids ... . last-var) + (apply (field-ref this i) + (wrapper-object-wrapped this) + rest-ids ... + last-var)))))]))) + (syntax->list arg-spec-stxs))] + [name (string->symbol (format "~a method" (syntax-object->datum (car names))))]) + (with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)]) + (cons (syntax (lambda (field-ref) (let ([name proc]) name))) + (loop (cdr arg-spec-stxss) + (cdr names) + (+ i 1))))))]))) + + (define (syntax->improper-list stx) + (define (se->il se) + (cond + [(pair? se) (sp->il se)] + [else se])) + (define (stx->il stx) + (se->il (syntax-e stx))) + (define (sp->il p) + (cond + [(null? (cdr p)) p] + [(pair? (cdr p)) (cons (car p) (sp->il (cdr p)))] + [(syntax? (cdr p)) + (let ([un (syntax-e (cdr p))]) + (if (pair? un) + (cons (car p) (sp->il un)) + p))])) + (stx->il stx)) + + (syntax-case stx () + [(_ field/mtd-specs ...) + (let* ([mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (field/mtd-specs ...))))] + [mtds (filter mtd? mtd/flds)] + [flds (filter fld? mtd/flds)]) + (with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)] + [(method-name ...) (map mtd-name mtds)] + [(method-ctc-var ...) (generate-temporaries mtds)] + [(method-var ...) (generate-temporaries mtds)] + [(method/app-var ...) (generate-temporaries mtds)] + [(methods ...) (build-methods-stx mtds)] + + [(field-ctc-stx ...) (map fld-ctc-stx flds)] + [(field-name ...) (map fld-name flds)] + [(field-ctc-var ...) (generate-temporaries flds)] + [(field-var ...) (generate-temporaries flds)] + [(field/app-var ...) (generate-temporaries flds)]) + (syntax + (let ([method-ctc-var method-ctc-stx] + ... + [field-ctc-var (coerce-contract object-contract field-ctc-stx)] + ...) + (let ([method-var (contract-proc method-ctc-var)] + ... + [field-var (contract-proc field-ctc-var)] + ...) + (make-contract + `(object-contract + ,(build-compound-type-name 'method-name method-ctc-var) ... + ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) + (lambda (pos-blame neg-blame src-info orig-str) + (let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)] + ... + [field/app-var (field-var pos-blame neg-blame src-info orig-str)] + ...) + (let ([cls (make-wrapper-class 'wrapper-class + '(method-name ...) + (list methods ...) + '(field-name ...))] + [field-names-list '(field-name ...)]) + (lambda (val) + (check-object val src-info pos-blame neg-blame orig-str) + (let ([val-mtd-names + (interface->method-names + (object-interface + val))]) + (void) + (check-method 'method-name val-mtd-names src-info pos-blame neg-blame orig-str) + ...) + + (unless (field-bound? field-name val) + (field-error 'field-name src-info pos-blame neg-blame orig-str)) ... + + (let ([vtable (extract-vtable val)] + [method-ht (extract-method-ht val)]) + (make-object cls + val + (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ... + (field/app-var (get-field field-name val)) ... + ))))))))))))])) + + ;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void + (define (ensure-no-duplicates stx form-name names) + (let ([ht (make-hash-table)]) + (for-each (lambda (name) + (let ([key (syntax-e name)]) + (when (hash-table-get ht key (lambda () #f)) + (raise-syntax-error form-name + "duplicate method name" + stx + name)) + (hash-table-put! ht key #t))) + names))) + + ;; method-specifier? : syntax -> boolean + ;; returns #t if x is the syntax for a valid method specifier + (define (method-specifier? x) + (or (eq? 'public (syntax-e x)) + (eq? 'override (syntax-e x)))) + + ;; make-object-wrapper-method : syntax syntax[identifier] syntax[identifier] syntax -> syntax + ;; constructs a wrapper method that checks the pre and post-condition, and + ;; calls the original object's method + (define (make-object-wrapper-method outer-args method-name contract-var contract-stx) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [method-name method-name] + [method-name-string (symbol->string (syntax-e method-name))] + [contract-var contract-var]) + (syntax/loc contract-stx + (define/public (method-name . args) + (let ([other-method (lambda x (send/apply val method-name x))] + [method-specific-src-info + (if (identifier? src-info) + (datum->syntax-object + src-info + (string->symbol + (string-append + (symbol->string (syntax-e src-info)) + " method " + method-name-string))) + src-info)]) + (apply (contract-var + other-method + pos-blame + neg-blame + method-specific-src-info) + args)))))) + + ;; make-class-wrapper-method : syntax syntax[identifier] syntax[identifier] syntax -> syntax + ;; constructs a wrapper method that checks the pre and post-condition, and + ;; calls the super method inbetween. + (define (make-class-wrapper-method outer-args method-name contract-var contract-stx) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [super-method-name (prefix-super method-name)] + [method-name method-name] + [method-name-string (symbol->string (syntax-e method-name))] + [contract-var contract-var]) + (syntax/loc contract-stx + (define/override method-name + (lambda args + (let* ([super-method (lambda x (super-method-name . x))] + [method-specific-src-info + (if (identifier? src-info) + (datum->syntax-object + src-info + (string->symbol + (string-append + (symbol->string (syntax-e src-info)) + " method " + method-name-string))) + src-info)] + [super-contract (and super-contracts-ht + (hash-table-get super-contracts-ht + 'method-name + (lambda () #f)))] + [wrapped-method (contract-var + super-method + pos-blame + neg-blame + method-specific-src-info)]) + (apply wrapped-method args))))))) + + ;; prefix-super : syntax[identifier] -> syntax[identifier] + ;; adds super- to the front of the identifier + (define (prefix-super stx) + (datum->syntax-object + #'here + (string->symbol + (format + "super-~a" + (syntax-object->datum + stx))))) + + ;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier] + ;; given the syntax for a method name, constructs the name of a method + ;; that returns the super's contract for the original method. + (define (method-name->contract-method-name stx) + (datum->syntax-object + #'here + (string->symbol + (format + "ACK_DONT_GUESS_ME-super-contract-~a" + (syntax-object->datum + stx))))) + + ;; Each of the /h functions builds four pieces of syntax: + ;; - [arguments-check] + ;; code that binds the contract values to names and + ;; does error checking for the contract specs + ;; (were the arguments all contracts?) + ;; - [build-proj] + ;; code that partially applies the input contracts to build projections + ;; - [check-val] + ;; code that does error checking on the contract'd value itself + ;; (is it a function of the right arity?) + ;; - [wrapper] + ;; a piece of syntax that has the arguments to the wrapper + ;; and the body of the wrapper. + ;; the first function accepts a body expression and wraps + ;; the body expression with checks. In addition, it + ;; adds a let that binds the contract exprssions to names + ;; the results of the other functions mention these names. + ;; the second and third function's input syntax should be four + ;; names: val, pos-blame, neg-blame, src-info, orig-str, name-id + ;; the fourth function returns a syntax list with two elements, + ;; the argument list (to be used as the first arg to lambda, + ;; or as a case-lambda clause) and the body of the function. + ;; They are combined into a lambda for the -> ->* ->d ->d* macros, + ;; and combined into a case-lambda for the case-> macro. + + ;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->/h method-proc? stx) + (syntax-case stx () + [(_) (raise-syntax-error '-> "expected at least one argument" stx)] + [(_ dom ... rng) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) + (with-syntax ([(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax-case* (syntax rng) (any values) module-or-top-identifier=? + [any + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (let ([dom-contract-x (coerce-contract -> dom)] ...) + (let ([dom-x (contract-proc dom-contract-x)] ...) + (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)]) + body)))))) + + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (val (dom-projection-x arg-x) ...))))))] + [(values rng ...) + (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] + [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] + [(res-x ...) (generate-temporaries (syntax (rng ...)))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (let ([dom-contract-x (coerce-contract -> dom)] ... + [rng-contract-x (coerce-contract -> rng)] ...) + (let ([dom-x (contract-proc dom-contract-x)] ... + [rng-x (contract-proc rng-contract-x)] ...) + (let ([name-id + (build-compound-type-name + '-> + name-dom-contract-x ... + (build-compound-type-name 'values rng-contract-x ...))]) + body)))))) + + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... + [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)]) + (values (rng-projection-x + res-x) + ...))))))))] + [rng + (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))] + [(rng-contact-x) (generate-temporaries (syntax (rng)))] + [(rng-projection-x) (generate-temporaries (syntax (rng)))] + [(rng-ant-x) (generate-temporaries (syntax (rng)))] + [(res-x) (generate-temporaries (syntax (rng)))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (let ([dom-contract-x (coerce-contract -> dom)] ... + [rng-contract-x (coerce-contract -> rng)]) + (let ([dom-x (contract-proc dom-contract-x)] ... + [rng-x (contract-proc rng-contract-x)]) + (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)]) + body)))))) + + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... + [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)]) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (let ([res-x (val (dom-projection-x arg-x) ...)]) + (rng-projection-x res-x))))))))])))])) + + ;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->*/h method-proc? stx) + (syntax-case stx (any) + [(_ (dom ...) (rng ...)) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + + [(rng-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] + [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] + [(res-x ...) (generate-temporaries (syntax (rng ...)))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract ->* dom)] ... + [rng-contract-x (coerce-contract ->* rng)] ...) + (let ([dom-x (contract-proc dom-contract-x)] ... + [rng-x (contract-proc rng-contract-x)] ...) + (let ([name-id (build-compound-type-name + '->* + (build-compound-type-name name-dom-contract-x ...) + (build-compound-type-name rng-contract-x ...))]) + body)))))) + + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... + [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)]) + (values (rng-projection-x + res-x) + ...))))))))] + [(_ (dom ...) any) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract ->* dom)] ...) + (let ([dom-x (contract-proc dom-contract-x)] ...) + (let ([name-id (build-compound-type-name + '->* + (build-compound-type-name name-dom-contract-x ...) + 'any)]) + body)))))) + + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (val (dom-projection-x arg-x) ...)))))))] + [(_ (dom ...) rest (rng ...)) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [dom-rest-x (car (generate-temporaries (list (syntax rest))))] + [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] + [dom-rest-projection-x (car (generate-temporaries (list (syntax rest))))] + [arg-rest-x (car (generate-temporaries (list (syntax rest))))] + + [(rng-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] + [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] + [(res-x ...) (generate-temporaries (syntax (rng ...)))] + [arity (length (syntax->list (syntax (dom ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [body body] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract ->* dom)] ... + [dom-rest-contract-x (coerce-contract ->* rest)] + [rng-contract-x (coerce-contract ->* rng)] ...) + (let ([dom-x (contract-proc dom-contract-x)] ... + [dom-rest-x (contract-proc dom-rest-contract-x)] + [rng-x (contract-proc rng-contract-x)] ...) + (let ([name-id + (build-compound-type-name + '->* + (build-compound-type-name dom-contract-x ...) + dom-rest-contract-x + (build-compound-type-name rng-contract-x ...))]) + body)))))) + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... + [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)] + [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) + inner-lambda)))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure/more val dom-length src-info pos-blame neg-blame orig-str)))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ... . arg-rest-x) + (let-values ([(res-x ...) + (apply + val + (dom-projection-x arg-x) + ... + (dom-rest-projection-x arg-rest-x))]) + (values (rng-projection-x res-x) ...))))))))] + [(_ (dom ...) rest any) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [dom-rest-x (car (generate-temporaries (list (syntax rest))))] + [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] + [dom-projection-rest-x (car (generate-temporaries (list (syntax rest))))] + [arg-rest-x (car (generate-temporaries (list (syntax rest))))] + + [arity (length (syntax->list (syntax (dom ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract ->* dom)] ... + [dom-rest-contract-x (coerce-contract ->* rest)]) + (let ([dom-x (contract-proc dom-contract-x)] ... + [dom-rest-x (contract-proc dom-rest-contract-x)]) + (let ([name-id (build-compound-type-name + '->* + (build-compound-type-name name-dom-contract-x ...) + dom-rest-contract-x + 'any)]) + body)))))) + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... + [dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) + inner-lambda)))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ;; CHECK: previously, this test didn't use `procedure-arity' and compare to `dom-length' + (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ... . arg-rest-x) + (apply + val + (dom-projection-x arg-x) + ... + (dom-projection-rest-x arg-rest-x))))))))])) + + ;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->d/h method-proc? stx) + (syntax-case stx () + [(_) (raise-syntax-error '->d "expected at least one argument" stx)] + [(_ dom ... rng) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [arity (length (syntax->list (syntax (dom ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract ->d dom)] ...) + (let ([dom-x (contract-proc dom-contract-x)] ... + [rng-x rng]) + (check-rng-procedure '->d rng-x arity) + (let ([name-id (build-compound-type-name '->d name-dom-contract-x ... '(... ...))]) + + body)))))) + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) + inner-lambda)))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val arity src-info pos-blame neg-blame orig-str)))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (let ([rng-contract (rng-x arg-x ...)]) + (((coerce/select-contract ->d rng-contract) + pos-blame + neg-blame + src-info + orig-str) + (val (dom-projection-x arg-x) ...)))))))))])) + + ;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->d*/h method-proc? stx) + (syntax-case stx () + [(_ (dom ...) rng-mk) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract ->d* dom)] ...) + (let ([dom-x (contract-proc dom-contract-x)] ... + [rng-mk-x rng-mk]) + (check-rng-procedure '->d* rng-mk-x dom-length) + (let ([name-id (build-compound-type-name + '->d* + (build-compound-type-name name-dom-contract-x ...) + '(... ...))]) + body)))))) + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) + inner-lambda)))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame neg-blame orig-str)))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (call-with-values + (lambda () (rng-mk-x arg-x ...)) + (lambda rng-contracts + (call-with-values + (lambda () + (val (dom-projection-x arg-x) ...)) + (lambda results + (check-rng-lengths results rng-contracts) + (apply + values + (map (lambda (rng-contract result) + (((coerce/select-contract ->d* rng-contract) + pos-blame + neg-blame + src-info + orig-str) + result)) + rng-contracts + results))))))))))))] + [(_ (dom ...) rest rng-mk) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-rest-x) (generate-temporaries (syntax (rest)))] + [(dom-rest-contract-x) (generate-temporaries (syntax (rest)))] + [(dom-rest-projection-x) (generate-temporaries (syntax (rest)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [arity (length (syntax->list (syntax (dom ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract ->d* dom)] ... + [dom-rest-contract-x (coerce-contract ->d* rest)]) + (let ([dom-x (contract-proc dom-contract-x)] ... + [dom-rest-x (contract-proc dom-rest-contract-x)] + [rng-mk-x rng-mk]) + (check-rng-procedure/more rng-mk-x arity) + (let ([name-id (build-compound-type-name + '->d* + (build-compound-type-name name-dom-contract-x ...) + dom-rest-contract-x + '(... ...))]) + body)))))) + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ... + [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) + inner-lambda)))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ;; CHECK: old check use "and more", but error message didn't + (check-procedure/more val arity src-info pos-blame neg-blame orig-str)))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ... . rest-arg-x) + (call-with-values + (lambda () + (apply rng-mk-x arg-x ... rest-arg-x)) + (lambda rng-contracts + (call-with-values + (lambda () + (apply + val + (dom-projection-x arg-x) + ... + (dom-rest-projection-x rest-arg-x))) + (lambda results + (check-rng-lengths results rng-contracts) + (apply + values + (map (lambda (rng-contract result) + (((coerce/select-contract ->d* rng-contract) + pos-blame + neg-blame + src-info + orig-str) + result)) + rng-contracts + results))))))))))))])) + + ;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->r/h method-proc? stx) + (syntax-case stx () + [(_ ([x dom] ...) rng) + (syntax-case* (syntax rng) (any values) module-or-top-identifier=? + [any + (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t any)))] + [(values . args) + (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng #t)))] + [rng + (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng unused-id #t)))] + [_ + (raise-syntax-error '->r "unknown result contract spec" stx (syntax rng))])] + + [(_ ([x dom] ...) rest-x rest-dom rng) + (syntax-case* (syntax rng) (values any) module-or-top-identifier=? + [any + (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t any)))] + [(values . whatever) + (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng #t)))] + [_ + (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng unused-id #t)))])])) + + ;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->pp/h method-proc? stx) (->r-pp/h method-proc? '->pp stx)) + + ;; ->pp/h : boolean symbol stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->r-pp/h method-proc? name stx) + (syntax-case stx () + [(_ ([x dom] ...) pre-expr . result-stuff) + (and (andmap identifier? (syntax->list (syntax (x ...)))) + (not (check-duplicate-identifier (syntax->list (syntax (x ...)))))) + (with-syntax ([stx-name name]) + (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))] + [arity (length (syntax->list (syntax (dom ...))))] + [name-stx + (with-syntax ([(name-xs ...) (if method-proc? + (cdr (syntax->list (syntax (x ...)))) + (syntax (x ...)))]) + (syntax + (build-compound-type-name 'stx-name + (build-compound-type-name + (build-compound-type-name 'name-xs '(... ...)) + ...) + '(... ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (let ([name-id name-stx]) + body)))) + (lambda (outer-args inner-lambda) inner-lambda) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [kind-of-thing (if method-proc? 'method 'procedure)]) + (syntax + (begin + (check-procedure/kind val arity 'kind-of-thing src-info pos-blame neg-blame orig-str))))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=? + [(any) + (syntax + ((x ...) + (begin + (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) + (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] + ...) + (val (dom-id x) ...)))))] + [((values (rng-ids rng-ctc) ...) post-expr) + (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) + (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) + (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))]) + (syntax + ((x ...) + (begin + (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) + (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] + ...) + (let-values ([(rng-ids ...) (val (dom-id x) ...)]) + (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) + (let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc) + pos-blame neg-blame src-info orig-str)] ...) + (values (rng-ids-x rng-ids) ...))))))))] + [((values (rng-ids rng-ctc) ...) post-expr) + (andmap identifier? (syntax->list (syntax (rng-ids ...)))) + (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))]) + (raise-syntax-error name "duplicate identifier" stx dup))] + [((values (rng-ids rng-ctc) ...) post-expr) + (for-each (lambda (rng-id) + (unless (identifier? rng-id) + (raise-syntax-error name "expected identifier" stx rng-id))) + (syntax->list (syntax (rng-ids ...))))] + [((values . x) . junk) + (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))] + [(rng res-id post-expr) + (syntax + ((x ...) + (begin + (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) + (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] + ... + [rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)]) + (let ([res-id (rng-id (val (dom-id x) ...))]) + (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) + res-id)))))] + [_ + (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))] + [(_ ([x dom] ...) pre-expr . result-stuff) + (andmap identifier? (syntax->list (syntax (x ...)))) + (raise-syntax-error + name + "duplicate identifier" + stx + (check-duplicate-identifier (syntax->list (syntax (x ...)))))] + [(_ ([x dom] ...) pre-expr . result-stuff) + (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x))) + (syntax->list (syntax (x ...))))] + [(_ (x ...) pre-expr . result-stuff) + (for-each (lambda (x) + (syntax-case x () + [(x y) (identifier? (syntax x)) (void)] + [bad (raise-syntax-error name "expected identifier and contract" stx (syntax bad))])) + (syntax->list (syntax (x ...))))] + [(_ x dom pre-expr . result-stuff) + (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))])) + + ;; ->pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->pp-rest/h method-proc? stx) (->r-pp-rest/h method-proc? '->pp-rest stx)) + + ;; ->r-pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->r-pp-rest/h method-proc? name stx) + (syntax-case stx () + [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff) + (and (identifier? (syntax rest-x)) + (andmap identifier? (syntax->list (syntax (x ...)))) + (not (check-duplicate-identifier (cons (syntax rest-x) (syntax->list (syntax (x ...))))))) + (with-syntax ([stx-name name]) + (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))] + [arity (length (syntax->list (syntax (dom ...))))] + [name-stx + (with-syntax ([(name-xs ...) (if method-proc? + (cdr (syntax->list (syntax (x ...)))) + (syntax (x ...)))]) + (syntax + (build-compound-type-name 'stx-name + `(,(build-compound-type-name 'name-xs '(... ...)) ...) + 'rest-x + '(... ...) + '(... ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (let ([name-id name-stx]) + body)))) + (lambda (outer-args inner-lambda) inner-lambda) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [kind-of-thing (if method-proc? 'method 'procedure)]) + (syntax + (begin + (check-procedure/more/kind val arity 'kind-of-thing src-info pos-blame neg-blame orig-str))))) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax-case* (syntax result-stuff) (values any) module-or-top-identifier=? + [(any) + (syntax + ((x ... . rest-x) + (begin + (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) + (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] + ... + [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)]) + (apply val (dom-id x) ... (rest-id rest-x))))))] + [(any . x) + (raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))] + [((values (rng-ids rng-ctc) ...) post-expr) + (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) + (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) + (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))]) + (syntax + ((x ... . rest-x) + (begin + (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) + (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] + ... + [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)]) + (let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))]) + (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) + (let ([rng-ids-x ((coerce/select-contract stx-name rng-ctc) + pos-blame neg-blame src-info orig-str)] ...) + (values (rng-ids-x rng-ids) ...))))))))] + [((values (rng-ids rng-ctc) ...) . whatever) + (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) + (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) + (raise-syntax-error name "expected exactly on post-expression at the end" stx)] + [((values (rng-ids rng-ctc) ...) . whatever) + (andmap identifier? (syntax->list (syntax (rng-ids ...)))) + (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))]) + (raise-syntax-error name "duplicate identifier" stx dup))] + [((values (rng-ids rng-ctc) ...) . whatever) + (for-each (lambda (rng-id) + (unless (identifier? rng-id) + (raise-syntax-error name "expected identifier" stx rng-id))) + (syntax->list (syntax (rng-ids ...))))] + [((values . x) . whatever) + (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))] + [(rng res-id post-expr) + (identifier? (syntax res-id)) + (syntax + ((x ... . rest-x) + (begin + (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) + (let ([dom-id ((coerce/select-contract stx-name dom) neg-blame pos-blame src-info orig-str)] + ... + [rest-id ((coerce/select-contract stx-name rest-dom) neg-blame pos-blame src-info orig-str)] + [rng-id ((coerce/select-contract stx-name rng) pos-blame neg-blame src-info orig-str)]) + (let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))]) + (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) + res-id)))))] + [(rng res-id post-expr) + (not (identifier? (syntax res-id))) + (raise-syntax-error name "expected an identifier" stx (syntax res-id))] + [_ + (raise-syntax-error name "malformed result sepecification" stx (syntax result-stuff))]))))))] + [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff) + (not (identifier? (syntax rest-x))) + (raise-syntax-error name "expected identifier" stx (syntax rest-x))] + [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff) + (and (identifier? (syntax rest-x)) + (andmap identifier? (cons (syntax rest-x) (syntax->list (syntax (x ...)))))) + (raise-syntax-error + name + "duplicate identifier" + stx + (check-duplicate-identifier (syntax->list (syntax (x ...)))))] + + [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff) + (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x))) + (cons + (syntax rest-x) + (syntax->list (syntax (x ...)))))] + [(_ x dom rest-x rest-dom rng . result-stuff) + (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))])) + + ;; select/h : syntax -> /h-function + (define (select/h stx err-name ctxt-stx) + (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) + [(-> . args) ->/h] + [(->* . args) ->*/h] + [(->d . args) ->d/h] + [(->d* . args) ->d*/h] + [(->r . args) ->r/h] + [(->pp . args) ->pp/h] + [(->pp-rest . args) ->pp-rest/h] + [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))] + [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)])) + + + ;; set-inferred-name-from : syntax syntax -> syntax + (define (set-inferred-name-from with-name to-be-named) + (let ([name (syntax-local-infer-name with-name)]) + (cond + [(identifier? name) + (with-syntax ([rhs (syntax-property to-be-named 'inferred-name (syntax-e name))] + [name (syntax-e name)]) + (syntax (let ([name rhs]) name)))] + [(symbol? name) + (with-syntax ([rhs (syntax-property to-be-named 'inferred-name name)] + [name name]) + (syntax (let ([name rhs]) name)))] + [else to-be-named]))) + + ;; (cons X (listof X)) -> (listof X) + ;; returns the elements of `l', minus the last element + ;; special case: if l is an improper list, it leaves off + ;; the contents of the last cdr (ie, making a proper list + ;; out of the input), so (all-but-last '(1 2 . 3)) = '(1 2) + (define (all-but-last l) + (cond + [(null? l) (error 'all-but-last "bad input")] + [(not (pair? l)) '()] + [(null? (cdr l)) null] + [(pair? (cdr l)) (cons (car l) (all-but-last (cdr l)))] + [else (list (car l))])) + + ;; generate-indicies : syntax[list] -> (cons number (listof number)) + ;; given a syntax list of length `n', returns a list containing + ;; the number n followed by th numbers from 0 to n-1 + (define (generate-indicies stx) + (let ([n (length (syntax->list stx))]) + (cons n + (let loop ([i n]) + (cond + [(zero? i) null] + [else (cons (- n i) + (loop (- i 1)))])))))) + + ;; procedure-accepts-and-more? : procedure number -> boolean + ;; returns #t if val accepts dom-length arguments and + ;; any number of arguments more than dom-length. + ;; returns #f otherwise. + (define (procedure-accepts-and-more? val dom-length) + (let ([arity (procedure-arity val)]) + (cond + [(number? arity) #f] + [(arity-at-least? arity) + (<= (arity-at-least-value arity) dom-length)] + [else + (let ([min-at-least (let loop ([ars arity] + [acc #f]) + (cond + [(null? ars) acc] + [else (let ([ar (car ars)]) + (cond + [(arity-at-least? ar) + (if (and acc + (< acc (arity-at-least-value ar))) + (loop (cdr ars) acc) + (loop (cdr ars) (arity-at-least-value ar)))] + [(number? ar) + (loop (cdr ars) acc)]))]))]) + (and min-at-least + (begin + (let loop ([counts (quicksort (filter number? arity) >=)]) + (unless (null? counts) + (let ([count (car counts)]) + (cond + [(= (+ count 1) min-at-least) + (set! min-at-least count) + (loop (cdr counts))] + [(< count min-at-least) + (void)] + [else (loop (cdr counts))])))) + (<= min-at-least dom-length))))]))) + + ;; ---------------------------------------- + ;; Checks and error functions used in macro expansions + + (define (check->* f arity-count) + (unless (procedure? f) + (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) + (unless (procedure-arity-includes? f arity-count) + (error 'object-contract + "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e" + arity-count + f))) + + (define (check->*/more f arity-count) + (unless (procedure? f) + (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) + (unless (procedure-accepts-and-more? f arity-count) + (error 'object-contract + "expected last argument of ->d* to be a procedure that accepts ~a arguments and arbitrarily many more, got ~e" + arity-count + f))) + + + (define (check-pre-expr->pp/h pre-expr src-info pos-blame neg-blame orig-str) + (unless pre-expr + (raise-contract-error src-info + neg-blame + pos-blame + orig-str + "pre-condition expression failure"))) + + (define (check-post-expr->pp/h post-expr src-info pos-blame neg-blame orig-str) + (unless post-expr + (raise-contract-error src-info + pos-blame + neg-blame + orig-str + "post-condition expression failure"))) + + (define (check-procedure val dom-length src-info pos-blame neg-blame orig-str) + (unless (and (procedure? val) + (procedure-arity-includes? val dom-length)) + (raise-contract-error + src-info + pos-blame + neg-blame + orig-str + "expected a procedure that accepts ~a arguments, given: ~e" + dom-length + val))) + + (define (check-procedure/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str) + (unless (procedure? val) + (raise-contract-error src-info + pos-blame + neg-blame + orig-str + "expected a procedure, got ~e" + val)) + (unless (procedure-arity-includes? val arity) + (raise-contract-error src-info + pos-blame + neg-blame + orig-str + "expected a ~a of arity ~a (not arity ~a), got ~e" + kind-of-thing + arity + (procedure-arity val) + val))) + + (define (check-procedure/more/kind val arity kind-of-thing src-info pos-blame neg-blame orig-str) + (unless (procedure? val) + (raise-contract-error src-info + pos-blame + neg-blame + orig-str + "expected a procedure, got ~e" + val)) + (unless (procedure-accepts-and-more? val arity) + (raise-contract-error src-info + pos-blame + neg-blame + orig-str + "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e" + kind-of-thing + arity + (procedure-arity val) + val))) + + (define (check-procedure/more val dom-length src-info pos-blame neg-blame orig-str) + (unless (and (procedure? val) + (procedure-accepts-and-more? val dom-length)) + (raise-contract-error + src-info + pos-blame + neg-blame + orig-str + "expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e" + dom-length + dom-length + val))) + + + (define (check-rng-procedure who rng-x arity) + (unless (and (procedure? rng-x) + (procedure-arity-includes? rng-x arity)) + (error who "expected range position to be a procedure that accepts ~a arguments, given: ~e" + arity + rng-x))) + + (define (check-rng-procedure/more rng-mk-x arity) + (unless (and (procedure? rng-mk-x) + (procedure-accepts-and-more? rng-mk-x arity)) + (error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e" + arity + rng-mk-x))) + + (define (check-rng-lengths results rng-contracts) + (unless (= (length results) (length rng-contracts)) + (error '->d* + "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" + (length results) (length rng-contracts)))) + + (define (check-object val src-info pos-blame neg-blame orig-str) + (unless (object? val) + (raise-contract-error src-info + pos-blame + neg-blame + orig-str + "expected an object, got ~e" + val))) + + (define (check-method method-name val-mtd-names src-info pos-blame neg-blame orig-str) + (unless (memq method-name val-mtd-names) + (raise-contract-error src-info + pos-blame + neg-blame + orig-str + "expected an object with method ~s" + method-name))) + + (define (field-error field-name src-info pos-blame neg-blame orig-str) + (raise-contract-error src-info + pos-blame + neg-blame + orig-str + "expected an object with field ~s" + field-name)) + + #| + + test cases for procedure-accepts-and-more? + + (and (procedure-accepts-and-more? (lambda (x . y) 1) 3) + (procedure-accepts-and-more? (lambda (x . y) 1) 2) + (procedure-accepts-and-more? (lambda (x . y) 1) 1) + (not (procedure-accepts-and-more? (lambda (x . y) 1) 0)) + + (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3) + (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2) + (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1) + (not (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0)) + + (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2) + (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1) + (not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0))) + + |# + + + ;; coerce/select-contract : id (union contract? procedure-arity-1) -> contract-proc + ;; contract-proc = sym sym stx -> alpha -> alpha + ;; returns the procedure for the contract after extracting it from the + ;; struct. Coerces the argument to a flat contract if it is procedure, but first. + (define-syntax (coerce/select-contract stx) + (syntax-case stx () + [(_ name val) + (syntax (coerce/select-contract/proc 'name val))])) + + (define (coerce/select-contract/proc name x) + (cond + [(contract? x) + (contract-proc x)] + [(and (procedure? x) (procedure-arity-includes? x 1)) + (contract-proc (flat-contract x))] + [else + (error name + "expected contract or procedure of arity 1, got ~e" + x)])) + + ;; coerce-contract : id (union contract? procedure-arity-1) -> contract + ;; contract-proc = sym sym stx -> alpha -> alpha + ;; returns the procedure for the contract after extracting it from the + ;; struct. Coerces the argument to a flat contract if it is procedure, but first. + (define-syntax (coerce-contract stx) + (syntax-case stx () + [(_ name val) + (syntax (coerce-contract/proc 'name val))])) + + (define (coerce-contract/proc name x) + (cond + [(contract? x) x] + [(and (procedure? x) (procedure-arity-includes? x 1)) + (flat-contract x)] + [else + (error name + "expected contract or procedure of arity 1, got ~e" + x)])) + +; +; +; +; ; +; +; ; ; +; ; ;; ;; ; ;;; ;;; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; ;;; +; ;; ;; ; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; +; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; +; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;;;; ; ; ;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ;;; ;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; ;;; +; +; +; + + + + (provide any/c + anaphoric-contracts + flat-rec-contract + flat-murec-contract + union + and/c + not/c + =/c >=/c <=/c /c + integer-in + exact-integer-in + real-in + natural-number/c + string/len + false/c + printable/c + symbols + is-a?/c subclass?/c implementation?/c + listof list-immutableof + vectorof vector-immutableof vector/c vector-immutable/c + cons-immutable/c cons/c list-immutable/c list/c + box-immutable/c box/c + promise/c + struct/c + mixin-contract make-mixin-contract + syntax/c) + + (define-syntax (flat-rec-contract stx) + (syntax-case stx () + [(_ name ctc ...) + (identifier? (syntax name)) + (with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))] + [(pred-id ...) (generate-temporaries (syntax (ctc ...)))]) + (syntax + (let* ([pred (lambda (x) (error 'flat-rec-contract "applied too soon"))] + [name (flat-contract (let ([name (lambda (x) (pred x))]) name))]) + (let ([ctc-id (coerce-contract flat-rec-contract ctc)] ...) + (unless (flat-contract? ctc-id) + (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id)) + ... + (set! pred + (let ([pred-id (flat-contract-predicate ctc-id)] ...) + (lambda (x) + (or (pred-id x) ...)))) + name))))] + [(_ name ctc ...) + (raise-syntax-error 'flat-rec-contract "expected first argument to be an identifier" stx (syntax name))])) + + (define-syntax (flat-murec-contract stx) + (syntax-case stx () + [(_ ([name ctc ...] ...) body1 body ...) + (andmap identifier? (syntax->list (syntax (name ...)))) + (with-syntax ([((ctc-id ...) ...) (map generate-temporaries + (syntax->list (syntax ((ctc ...) ...))))] + [(pred-id ...) (generate-temporaries (syntax (name ...)))] + [((pred-arm-id ...) ...) (map generate-temporaries + (syntax->list (syntax ((ctc ...) ...))))]) + (syntax + (let* ([pred-id (lambda (x) (error 'flat-murec-contract "applied too soon"))] ... + [name (flat-contract (let ([name (lambda (x) (pred-id x))]) name))] ...) + (let-values ([(ctc-id ...) (values (coerce-contract flat-rec-contract ctc) ...)] ...) + (begin + (void) + (unless (flat-contract? ctc-id) + (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id)) + ...) ... + (set! pred-id + (let ([pred-arm-id (flat-contract-predicate ctc-id)] ...) + (lambda (x) + (or (pred-arm-id x) ...)))) ... + body1 + body ...))))] + [(_ ([name ctc ...] ...) body1 body ...) + (for-each (lambda (name) + (unless (identifier? name) + (raise-syntax-error 'flat-rec-contract + "expected an identifier" stx name))) + (syntax->list (syntax (name ...))))] + [(_ ([name ctc ...] ...)) + (raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)])) + + + (define anaphoric-contracts + (case-lambda + [() (make-anaphoric-contracts (make-hash-table 'weak))] + [(x) + (unless (eq? x 'equal) + (error 'anaphoric-contracts "expected either no arguments, or 'equal as first argument, got ~e" x)) + (make-anaphoric-contracts (make-hash-table 'equal 'weak))])) + + (define (make-anaphoric-contracts ht) + (values + (flat-named-contract + "(anaphoric-contracts,from)" + (lambda (v) + (hash-table-put! ht v #t) + v)) + (flat-named-contract + "(anaphoric-contracts,to)" + (lambda (v) + (hash-table-get ht v (lambda () #f)))))) + + (define (union . args) + (for-each + (lambda (x) + (unless (or (contract? x) + (and (procedure? x) + (procedure-arity-includes? x 1))) + (error 'union "expected procedures of arity 1 or contracts, given: ~e" x))) + args) + (let-values ([(contract fc/predicates) + (let loop ([contract #f] + [fc/predicates null] + [args args]) + (cond + [(null? args) (values contract (reverse fc/predicates))] + [else + (let ([arg (car args)]) + (cond + [(or (flat-contract? arg) + (not (contract? arg))) + (loop contract (cons arg fc/predicates) (cdr args))] + [contract + (error 'union "expected at most one non-flat contract, given ~e and ~e" + contract + arg)] + [else (loop arg fc/predicates (cdr args))]))]))]) + (let* ([flat-contracts (map (lambda (x) (if (flat-contract? x) + x + (flat-contract x))) + fc/predicates)] + [predicates (map flat-contract-predicate flat-contracts)]) + (cond + [contract + (let ([c-proc (contract-proc contract)]) + (make-contract + (apply build-compound-type-name 'union contract flat-contracts) + (lambda (pos neg src-info orig-str) + (let ([partial-contract (c-proc pos neg src-info orig-str)]) + (lambda (val) + (cond + [(ormap (lambda (pred) (pred val)) predicates) + val] + [else + (partial-contract val)]))))))] + [else + (build-flat-contract + (apply build-compound-type-name 'union flat-contracts) + (lambda (x) + (ormap (lambda (pred) (pred x)) predicates)))])))) + + (define false/c + (flat-named-contract + 'false/c + (lambda (x) (not x)))) + + (define any/c + (make-flat-contract + 'any/c + (lambda (pos neg src-info orig-str) (lambda (val) val)) + (lambda (x) #t))) + + (define (string/len n) + (unless (number? n) + (error 'string/len "expected a number as argument, got ~e" n)) + (flat-named-contract + `(string/len ,n) + (lambda (x) + (and (string? x) + ((string-length x) . < . n))))) + + (define (symbols . ss) + (unless ((length ss) . >= . 1) + (error 'symbols "expected at least one argument")) + (unless (andmap symbol? ss) + (error 'symbols "expected symbols as arguments, given: ~a" + (apply string-append (map (lambda (x) (format "~e " x)) ss)))) + (flat-named-contract + `(symbols ,@(map (lambda (x) `',x) ss)) + (lambda (x) + (memq x ss)))) + + (define printable/c + (flat-named-contract + 'printable/c + (lambda (x) + (let printable? ([x x]) + (or (symbol? x) + (string? x) + (bytes? x) + (boolean? x) + (char? x) + (null? x) + (number? x) + (regexp? x) + (and (pair? x) + (printable? (car x)) + (printable? (cdr x))) + (and (vector? x) + (andmap printable? (vector->list x))) + (and (box? x) + (printable? (unbox x)))))))) + + (define (=/c x) + (flat-named-contract + `(=/c ,x) + (lambda (y) (and (number? y) (= y x))))) + (define (>=/c x) + (flat-named-contract + `(>=/c ,x) + (lambda (y) (and (number? y) (>= y x))))) + (define (<=/c x) + (flat-named-contract + `(<=/c ,x) + (lambda (y) (and (number? y) (<= y x))))) + (define (/c x) + (flat-named-contract + `(>/c ,x) + (lambda (y) (and (number? y) (> y x))))) + + (define natural-number/c + (flat-named-contract + 'natural-number/c + (lambda (x) + (and (number? x) + (integer? x) + (x . >= . 0))))) + + (define (integer-in start end) + (unless (and (integer? start) + (integer? end)) + (error 'integer-in "expected two integers as arguments, got ~e and ~e" start end)) + (flat-named-contract + `(integer-in ,start ,end) + (lambda (x) + (and (integer? x) + (<= start x end))))) + + (define (exact-integer-in start end) + (unless (and (integer? start) + (exact? start) + (integer? end) + (exact? end)) + (error 'integer-in "expected two exact integers as arguments, got ~e and ~e" start end)) + (flat-named-contract + `(exact-integer-in ,start ,end) + (lambda (x) + (and (integer? x) + (exact? x) + (<= start x end))))) + + (define (real-in start end) + (unless (and (real? start) + (real? end)) + (error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end)) + (flat-named-contract + `(real-in ,start ,end) + (lambda (x) + (and (real? x) + (<= start x end))))) + + (define (and/c . fs) + (for-each + (lambda (x) + (unless (or (contract? x) + (and (procedure? x) + (procedure-arity-includes? x 1))) + (error 'and/c "expected procedures of arity 1 or s, given: ~e" x))) + fs) + (cond + [(null? fs) any/c] + [(andmap flat-contract/predicate? fs) + (let* ([to-predicate + (lambda (x) + (if (flat-contract? x) + (flat-contract-predicate x) + x))] + [contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)] + [pred + (let loop ([pred (to-predicate (car fs))] + [preds (cdr fs)]) + (cond + [(null? preds) pred] + [else + (let* ([fst (to-predicate (car preds))]) + (loop (let ([and/c-contract? (lambda (x) (and (pred x) (fst x)))]) + and/c-contract?) + (cdr preds)))]))]) + (flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))] + [else + (let* ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)] + [contract/procs (map contract-proc contracts)]) + (make-contract + (apply build-compound-type-name 'and/c contracts) + (lambda (pos neg src-info orig-str) + (let ([partial-contracts (map (lambda (contract/proc) (contract/proc pos neg src-info orig-str)) + contract/procs)]) + (let loop ([ctct (car partial-contracts)] + [rest (cdr partial-contracts)]) + (cond + [(null? rest) ctct] + [else + (let ([fst (car rest)]) + (loop (lambda (x) (fst (ctct x))) + (cdr rest)))]))))))])) + + (define (not/c f) + (unless (flat-contract/predicate? f) + (error 'not/c "expected a procedure of arity 1 or , given: ~e" f)) + (build-flat-contract + (build-compound-type-name 'not/c (proc/ctc->ctc f)) + (lambda (x) (not (test-proc/flat-contract f x))))) + + (define (is-a?/c <%>) + (unless (or (interface? <%>) + (class? <%>)) + (error 'is-a?/c "expected or , given: ~e" <%>)) + (let ([name (object-name <%>)]) + (flat-named-contract + (cond + [name + `(is-a?/c ,name)] + [(class? <%>) + `(is-a?/c unknown%)] + [else `(is-a?/c unknown<%>)]) + (lambda (x) (is-a? x <%>))))) + + (define (listof p) + (unless (flat-contract/predicate? p) + (error 'listof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p)) + (build-flat-contract + (build-compound-type-name 'listof (proc/ctc->ctc p)) + (lambda (v) + (and (list? v) + (andmap (lambda (ele) (test-proc/flat-contract p ele)) + v))))) + + (define-syntax (*-immutableof stx) + (syntax-case stx () + [(_ predicate? fill type-name name) + (syntax + (let ([predicate?-name predicate?] + [fill-name fill]) + (lambda (input) + (let* ([ctc (coerce-contract name input)] + [p (contract-proc ctc)]) + (make-contract + (build-compound-type-name 'name ctc) + (lambda (pos neg src-info orig-str) + (let ([p-app (p pos neg src-info orig-str)]) + (lambda (val) + (unless (predicate?-name val) + (raise-contract-error + src-info + pos + neg + orig-str + "expected <~a>, given: ~e" + 'type-name + val)) + (fill-name p-app val)))))))))])) + + (define (map-immutable f lst) + (let loop ([lst lst]) + (cond + [(pair? lst) + (cons-immutable (f (car lst)) + (loop (cdr lst)))] + [(null? lst) null]))) + + (define (immutable-list? lst) + (cond + [(and (pair? lst) + (immutable? lst)) + (immutable-list? (cdr lst))] + [(null? lst) #t] + [else #f])) + + (define list-immutableof + (*-immutableof immutable-list? map-immutable immutable-list list-immutableof)) + + (define vector-immutableof + (*-immutableof (lambda (x) (and (vector? x) (immutable? x))) + (lambda (f v) (apply vector-immutable (map f (vector->list v)))) + immutable-vector + vector-immutableof)) + + (define (vectorof p) + (unless (flat-contract/predicate? p) + (error 'vectorof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p)) + (build-flat-contract + (build-compound-type-name 'vectorof (proc/ctc->ctc p)) + (lambda (v) + (and (vector? v) + (andmap (lambda (ele) (test-proc/flat-contract p ele)) + (vector->list v)))))) + + (define (vector/c . args) + (unless (andmap flat-contract/predicate? args) + (error 'vector/c "expected flat contracts as arguments, got: ~a" + (let loop ([args args]) + (cond + [(null? args) ""] + [(null? (cdr args)) (format "~e" (car args))] + [else (string-append + (format "~e " (car args)) + (loop (cdr args)))])))) + (let ([largs (length args)]) + (build-flat-contract + (apply build-compound-type-name 'vector/c (map proc/ctc->ctc args)) + (lambda (v) + (and (vector? v) + (= (vector-length v) largs) + (andmap test-proc/flat-contract + args + (vector->list v))))))) + + (define (box/c pred) + (unless (flat-contract/predicate? pred) + (error 'box/c "expected a flat contract or a procedure of arity 1, got: ~e" pred)) + (build-flat-contract + (build-compound-type-name 'box/c (proc/ctc->ctc pred)) + (lambda (x) + (and (box? x) + (test-proc/flat-contract pred (unbox x)))))) + + (define (cons/c hdp tlp) + (unless (and (flat-contract/predicate? hdp) + (flat-contract/predicate? tlp)) + (error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e" hdp tlp)) + (build-flat-contract + (build-compound-type-name 'cons/c (proc/ctc->ctc hdp) (proc/ctc->ctc tlp)) + (lambda (x) + (and (pair? x) + (test-proc/flat-contract hdp (car x)) + (test-proc/flat-contract tlp (cdr x)))))) + + (define-syntax (*-immutable/c stx) + (syntax-case stx () + [(_ predicate? constructor (arb? selectors ...) type-name name) + (eq? #f (syntax-object->datum (syntax arb?))) + (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))] + [(p-apps ...) (generate-temporaries (syntax (selectors ...)))] + [(procs ...) (generate-temporaries (syntax (selectors ...)))] + [(selector-names ...) (generate-temporaries (syntax (selectors ...)))]) + (syntax + (let ([predicate?-name predicate?] + [constructor-name constructor] + [selector-names selectors] ...) + (lambda (params ...) + (let ([procs (coerce/select-contract name params)] ...) + (make-contract + (build-compound-type-name 'name (proc/ctc->ctc params) ...) + (lambda (pos neg src-info orig-str) + (let ([p-apps (procs pos neg src-info orig-str)] ...) + (lambda (v) + (if (and (immutable? v) + (predicate?-name v)) + (constructor-name (p-apps (selector-names v)) ...) + (raise-contract-error + src-info + pos + neg + orig-str + "expected <~a>, given: ~e" + 'type-name + v)))))))))))] + [(_ predicate? constructor (arb? selector) correct-size type-name name) + (eq? #t (syntax-object->datum (syntax arb?))) + (syntax + (let ([predicate?-name predicate?] + [constructor-name constructor] + [selector-name selector]) + (lambda params + (let ([procs (map (lambda (param) (coerce/select-contract name param)) params)]) + (make-contract + (apply build-compound-type-name 'name (map proc/ctc->ctc params)) + (lambda (pos neg src-info orig-str) + (let ([p-apps (map (lambda (proc) (proc pos neg src-info orig-str)) procs)] + [count (length params)]) + (lambda (v) + (if (and (immutable? v) + (predicate?-name v) + (correct-size count v)) + (apply constructor-name + (let loop ([p-apps p-apps] + [i 0]) + (cond + [(null? p-apps) null] + [else (let ([p-app (car p-apps)]) + (cons (p-app (selector-name v i)) + (loop (cdr p-apps) (+ i 1))))]))) + (raise-contract-error + src-info + pos + neg + orig-str + "expected <~a>, given: ~e" + 'type-name + v))))))))))])) + + (define cons-immutable/c (*-immutable/c pair? cons-immutable (#f car cdr) immutable-cons cons-immutable/c)) + (define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c)) + (define vector-immutable/c (*-immutable/c vector? + vector-immutable + (#t (lambda (v i) (vector-ref v i))) + (lambda (n v) (= n (vector-length v))) + immutable-vector + vector-immutable/c)) + + (define (list/c . args) + (unless (andmap flat-contract/predicate? args) + (error 'list/c "expected flat contracts, got: ~a" + (let loop ([args args]) + (cond + [(null? args) ""] + [(null? (cdr args)) (format "~e" (car args))] + [else (string-append + (format "~e " (car args)) + (loop (cdr args)))])))) + (let loop ([args args]) + (cond + [(null? args) (flat-contract null?)] + [else (cons/c (car args) (loop (cdr args)))]))) + + (define (list-immutable/c . args) + (unless (andmap (lambda (x) (or (contract? x) + (and (procedure? x) + (procedure-arity-includes? x 1)))) + args) + (error 'list/c "expected flat contracts or procedures of arity 1, got: ~a" + (let loop ([args args]) + (cond + [(null? args) ""] + [(null? (cdr args)) (format "~e" (car args))] + [else (string-append + (format "~e " (car args)) + (loop (cdr args)))])))) + (let loop ([args args]) + (cond + [(null? args) (flat-contract null?)] + [else (cons-immutable/c (car args) (loop (cdr args)))]))) + + (define (syntax/c ctc-in) + (let ([ctc (coerce-contract syntax/c ctc-in)]) + (build-flat-contract + (build-compound-type-name 'syntax/c ctc) + (let ([pred (flat-contract-predicate ctc)]) + (lambda (val) + (and (syntax? val) + (pred (syntax-e val)))))))) + + (define promise/c + (lambda (ctc-in) + (let* ([ctc (coerce-contract promise/c ctc-in)] + [ctc-proc (contract-proc ctc)]) + (make-contract + (build-compound-type-name 'promise/c ctc) + (lambda (pos neg src-info orig-str) + (let ([p-app (ctc-proc pos neg src-info orig-str)]) + (lambda (val) + (unless (promise? val) + (raise-contract-error + src-info + pos + neg + orig-str + "expected , given: ~e" + val)) + (delay (p-app (force val)))))))))) + + #| + as with copy-struct in struct.ss, this first begin0 + expansion "declares" that struct/c is an expression. + It prevents further expansion until the internal definition + context is sorted out. + |# + (define-syntax (struct/c stx) + (syntax-case stx () + [(_ . args) (syntax (begin0 (do-struct/c . args)))])) + + (define-syntax (do-struct/c stx) + (syntax-case stx () + [(_ struct-name args ...) + (and (identifier? (syntax struct-name)) + (syntax-local-value (syntax struct-name) (lambda () #f))) + (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))] + [(ctc-proc-x ...) (generate-temporaries (syntax (args ...)))] + [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))] + [(type-desc-id + constructor-id + predicate-id + (selector-id ...) + (mutator-id ...) + super-id) + (syntax-local-value (syntax struct-name))]) + (syntax + (let ([ctc-x (coerce-contract struct/c args)] ...) + + (unless predicate-id + (error 'struct/c "could not determine predicate for ~s" 'struct-name)) + (unless (and selector-id ...) + (error 'struct/c "could not determine selectors for ~s" 'struct-name)) + + (unless (flat-contract? ctc-x) + (error 'struct/c "expected flat contracts as arguments, got ~e" ctc-x)) + ... + + (let ([ctc-proc-x (contract-proc ctc-x)] ...) + (make-contract + (build-compound-type-name 'struct/c 'struct-name ctc-x ...) + (lambda (pos neg src-info orig-str) + (let ([ctc-app-x (ctc-proc-x pos neg src-info orig-str)] ...) + (lambda (val) + (unless (predicate-id val) + (raise-contract-error + src-info + pos + neg + orig-str + "expected <~a>, given: ~e" + 'struct-name + val)) + (ctc-app-x (selector-id val)) ... + val))))))))] + [(_ struct-name anything ...) + (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])) + + (define (flat-contract/predicate? pred) + (or (flat-contract? pred) + (and (procedure? pred) + (procedure-arity-includes? pred 1)))) + + (define (subclass?/c %) + (unless (class? %) + (error 'subclass?/c "expected , given: ~e" %)) + (let ([name (object-name %)]) + (flat-named-contract + `(subclass?/c ,(or name 'unknown%)) + (lambda (x) (subclass? x %))))) + + (define (implementation?/c <%>) + (unless (interface? <%>) + (error 'implementation?/c "expected , given: ~e" <%>)) + (let ([name (object-name <%>)]) + (flat-named-contract + `(implementation?/c ,(or name 'unknown<%>)) + (lambda (x) (implementation? x <%>))))) + + (define mixin-contract (class? . ->d . subclass?/c)) + + (define (make-mixin-contract . %/<%>s) + ((and/c (flat-contract class?) + (apply and/c (map sub/impl?/c %/<%>s))) + . ->d . + subclass?/c)) + + (define (sub/impl?/c %/<%>) + (cond + [(interface? %/<%>) (implementation?/c %/<%>)] + [(class? %/<%>) (subclass?/c %/<%>)] + [else (error 'make-mixin-contract "unknown input ~e" %/<%>)])))