diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss index 536df91..c2768f4 100644 --- a/collects/mzlib/class.ss +++ b/collects/mzlib/class.ss @@ -1,44 +1,3 @@ (module class mzscheme - - ;; All of the implementation is actually in private/class-internal.ss, - ;; which provides extra (private) functionality to contract.ss. - (require "private/class-internal.ss") - - (provide class class* class/derived - define-serializable-class define-serializable-class* - class? - mixin - interface interface? - object% object? externalizable<%> - object=? - new make-object instantiate - send send/apply send* class-field-accessor class-field-mutator with-method - get-field field-bound? field-names - private* public* pubment* - override* overment* - augride* augment* - public-final* override-final* augment-final* - define/private define/public define/pubment - define/override define/overment - define/augride define/augment - define/public-final define/override-final define/augment-final - define-local-member-name define-member-name - member-name-key generate-member-key - member-name-key? member-name-key=? member-name-key-hash-code - generic make-generic send-generic - is-a? subclass? implementation? interface-extension? - object-interface object-info object->vector - object-method-arity-includes? - method-in-interface? interface->method-names class->interface class-info - (struct exn:fail:object ()) - make-primitive-class - - ;; "keywords": - private public override augment - pubment overment augride - public-final override-final augment-final - field init init-field init-rest - rename-super rename-inner inherit inherit/super inherit/inner inherit-field - this super inner - super-make-object super-instantiate super-new - inspect)) + (require scheme/private/class-internal) + (provide-public-names)) \ No newline at end of file diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index d92bc62..d43e465 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -1,180 +1,10 @@ +#lang scheme/base +(require scheme/contract) +(provide (all-from-out scheme/contract)) -(module contract mzscheme +;; provide contracts for objects +(require scheme/private/contract-object) +(provide (all-from-out scheme/private/contract-object)) + - ;; povide contracts for objects - (require "private/contract-object.ss") - (provide (all-from "private/contract-object.ss")) - - (require "private/contract.ss" - "private/contract-arrow.ss" - "private/contract-guts.ss" - "private/contract-ds.ss" - "private/contract-opt-guts.ss" - "private/contract-opt.ss" - "private/contract-basic-opters.ss") - - (provide - opt/c define-opt/c ;(all-from "private/contract-opt.ss") - (all-from-except "private/contract-ds.ss" - lazy-depth-to-look) - (all-from-except "private/contract-arrow.ss" - check-procedure) - (all-from-except "private/contract.ss" - check-between/c - check-unary-between/c)) - - ;; from contract-guts.ss - - (provide any - and/c - any/c - none/c - make-none/c - - guilty-party - contract-violation->string - - contract? - contract-name - contract-proc - - flat-contract? - flat-contract - flat-contract-predicate - flat-named-contract - - contract-first-order-passes? - - ;; below need docs - - make-proj-contract - - contract-stronger? - - coerce-contract - flat-contract/predicate? - - build-compound-type-name - raise-contract-error - - proj-prop proj-pred? proj-get - name-prop name-pred? name-get - stronger-prop stronger-pred? stronger-get - flat-prop flat-pred? flat-get - first-order-prop first-order-get)) - - -;; ====================================================================== -;; The alternate implementation disables contracts. Its useful mainly to -;; measure the cost of contracts. It's not necessarily complete, but it -;; works well enough for starting DrScheme. - -#; -(module contract mzscheme - - (define-syntax provide/contract - (syntax-rules () - [(_ elem ...) - (begin (provide-one elem) ...)])) - - (define-syntax provide-one - (syntax-rules (struct rename) - [(_ (struct (id par-id) ([field . rest] ...))) - (provide-struct id par-id (field ...))] - [(_ (struct id ([field . rest] ...))) - (provide (struct id (field ...)))] - [(_ (rename id1 id2 c)) - (provide (rename id1 id2))] - [(_ (id c)) - (provide id)])) - - (define-syntax (provide-struct stx) - (syntax-case stx () - [(_ id par-id . rest) - (let ([info (syntax-local-value #'id (lambda () #f))] - [p-info (syntax-local-value #'par-id (lambda () #f))] - [prefix (lambda (l n) - (let loop ([l l][len (length l)]) - (if (= n len) - null - (cons (car l) (loop (cdr l) - (- len 1))))))] - [ids (lambda (l) (let loop ([l l]) - (cond - [(null? l) null] - [(car l) (cons (car l) (loop (cdr l)))] - [else (loop (cdr l))])))]) - (if (and info - p-info - (list? info) - (list? p-info) - (= (length info) 6) - (= (length p-info) 6)) - #`(provide #,@(append - (list #'id - (list-ref info 0) - (list-ref info 1) - (list-ref info 2)) - (ids (prefix (list-ref info 3) (length (list-ref p-info 3)))) - (ids (prefix (list-ref info 4) (length (list-ref p-info 4)))))) - (raise-syntax-error - #f - (cond - [(not info) "cannot find struct info"] - [(not p-info) "cannot find parent-struct info"] - [else (format "struct or parent-struct info has unexpected shape: ~e and ~e" - info p-info)]) - #'id)))])) - - (define-syntax define-contract-struct - (syntax-rules () - [(_ . rest) (define-struct . rest)])) - - (define-syntax define/contract - (syntax-rules () - [(_ id c expr) (define id expr)])) - - (define-syntax contract - (syntax-rules () - [(_ c expr . rest) expr])) - - (provide provide/contract - define-contract-struct - define/contract - contract) - - (define mk* - (lambda args (lambda (x) x))) - - (define-syntax mk - (syntax-rules () - [(_ id) (begin - (define-syntax (id stx) (quote-syntax mk*)) - (provide id))] - [(_ id ...) - (begin (mk id) ...)])) - - (mk -> - ->* - opt-> - case-> - ->r - or/c - and/c - any/c - flat-named-contract - flat-contract - flat-contract-predicate - object-contract - union - listof - is-a?/c) - - (define-syntax symbols - (syntax-rules () - [(_ sym ...) - (lambda (v) (memq v '(sym ...)))])) - (provide symbols) - - ) diff --git a/collects/mzlib/serialize.ss b/collects/mzlib/serialize.ss index 8da9809..545e6de 100644 --- a/collects/mzlib/serialize.ss +++ b/collects/mzlib/serialize.ss @@ -4,13 +4,13 @@ (lib "etc.ss") (lib "list.ss") ;; core [de]serializer: - "private/serialize.ss") + (lib "private/serialize.ss" "scheme")) (provide define-serializable-struct define-serializable-struct/versions ;; core [de]serializer: - (all-from "private/serialize.ss")) + (all-from (lib "private/serialize.ss" "scheme"))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; define-serializable-struct diff --git a/collects/mzlib/trait.ss b/collects/mzlib/trait.ss index b3902ff..0088150 100644 --- a/collects/mzlib/trait.ss +++ b/collects/mzlib/trait.ss @@ -1,729 +1,3 @@ -(module trait mzscheme - (require (lib "class.ss") - (lib "list.ss") - (lib "struct.ss")) - (require-for-syntax (lib "list.ss") - (lib "stx.ss" "syntax") - (lib "boundmap.ss" "syntax") - (lib "kerncase.ss" "syntax") - ;; This should be part of a public expand-time API - ;; exported by the class system: - (only (lib "classidmap.ss" "mzlib" "private") - generate-class-expand-context)) - - (provide (rename :trait trait) - trait? - trait->mixin - trait-sum - trait-exclude trait-exclude-field - trait-alias - trait-rename trait-rename-field) - - ;; A trait is a list of supplied methods. - ;; Each supplied method is: - ;; * an external name - ;; * supplies inherit? - ;; * supplies super? - ;; * supplies inner? - ;; * overrides? - ;; * augments? - ;; * list of required methods (external names) for inherit - ;; * list of required methods (external names) for super - ;; * list of required methods (external names) for inner - ;; * list of required methods (external names) for inherit-fields - ;; * a mixin patameterized by all external names - ;; * an indrection mixin for supers - - (define-struct trait (methods fields)) - - (define-struct method (name inherit? super? inner? - override? augment? - need-inherit need-super need-inner need-field - make-mixin - make-super-indirection-mixin)) - - (define-struct feeld (name make-mixin)) - - (define-syntax (:trait stx) - ;; The main compiler (helpers are below): - (define (main stx) - (syntax-case stx () - [(_ clause ...) - (let* ([clauses (syntax->list #'(clause ...))] - [expanded-clauses (expand-body clauses)]) - ;; Pull out declared names: - (let-values ([(publics pubments - overrides augments augrides overments - inherits inherits/super inherits/inner - inherit-fields) - (extract expanded-clauses - (map syntax->list - (syntax->list - #'((public public-final) - (pubment) - (override override-final) - (augment augment-final) - (augride) - (overment) - (inherit) (inherit/super) (inherit/inner) - (inherit-field)))))] - [(fields) - (extract-fields expanded-clauses)]) - ;; Every declaration implies direct use for other declarations: - (let* ([to-inherit - (append publics pubments - overrides augments augrides overments - inherits inherits/super inherits/inner)] - [to-inherit-fields - (append fields inherit-fields)] - [decls - (append to-inherit-fields to-inherit)]) - ;; Check distinct delcarations: - (check-distinct-external-names to-inherit) - (check-distinct-external-names to-inherit-fields) - (check-distinct-internal-names decls) - - ;; Some declarations imply use via `super' or `inner': - (let ([to-super (append overrides inherits/super)] - [to-inner (append augments pubments inherits/inner)]) - - (let ([to-inherit-only - (filter (lambda (n) - (not (or (ormap (lambda (n2) (internal-identifier=? n n2)) - to-super) - (ormap (lambda (n2) (internal-identifier=? n n2)) - to-inner)))) - to-inherit)]) - - ;; Current method-making function with respect to the - ;; common part: - (let* ([bindings (make-bindings expanded-clauses)] - [compose-method (compose-method-with-requirements - bindings - to-inherit-only to-super to-inner - to-inherit-fields)]) - - ;; Build a mixin and `method' record for each declaration: - (with-syntax ([(method ...) - (append - (map (compose-method #'override #t #f #f #f #f #f) publics) - (map (compose-method #'overment #t #t #f #f #f #f) pubments) - (map (compose-method #'override #t #t #f #t #f #f) overrides) - (map (compose-method #'overment #t #f #f #t #f #t) overments) - (map (compose-method #'augment #t #f #t #f #t #f) augments) - (map (compose-method #'augride #t #f #f #f #t #f) augrides))] - [(field ...) - (map (compose-field bindings) fields)]) - - (bound-identifier-mapping-for-each - bindings - (lambda (key val) - (when val - (raise-syntax-error - #f - "definition has no corresponding declaration (e.g., public)" - stx - key)))) - - ;; Combine the result into a trait: - #'(make-trait (list method ...) - (list field ...)))))))))])) - - (define (expand-body clauses) - ;; For now, we expand naively: no support for internal define-syntax, - ;; and no shadowing of syntax with method definitions. - (let ([stop-forms - (append - (syntax->list - #'(private - public public-final pubment - override override-final augment augment-final augride overment - inherit inherit/super inherit/inner - this super inner - field inherit-field)) - (kernel-form-identifier-list))] - [expand-context (generate-class-expand-context)]) - (let loop ([l clauses]) - (cond - [(null? l) null] - [else (let ([e (local-expand (car l) - expand-context - stop-forms)]) - (syntax-case e (begin define-values) - [(begin expr ...) - (loop (append - (syntax->list (syntax (expr ...))) - (cdr l)))] - [(define-values (id) rhs) - (cons e (loop (cdr l)))] - [(field (id expr) ...) - (if (andmap (lambda (id) - (or (identifier? id) - (syntax-case id () - [(a b) - (and (identifier? #'a) - (identifier? #'b))] - [_else #f]))) - (syntax->list #'(id ...))) - (cons e (loop (cdr l))) - (raise-syntax-error - #f - "bad syntax" - e))] - [(id . rest) - (ormap (lambda (x) (module-identifier=? x #'id)) - (syntax->list - #'(public public-final pubment - override override-final augment augment-final augride overment - inherit inherit/super inherit/inner - inherit-field))) - (let ([l2 (syntax->list #'rest)]) - (if (and l2 - (andmap (lambda (i) - (or (identifier? i) - (syntax-case i () - [(a b) - (and (identifier? #'a) - (identifier? #'b))] - [_else #f]))) - l2)) - (cons e (loop (cdr l))) - (raise-syntax-error - #f - "bad syntax (inside trait)" - e)))] - [(define-values . _) - (raise-syntax-error - #f - "bad syntax" - e)] - [(field . _) - (raise-syntax-error - #f - "bad syntax" - e)] - [else - (raise-syntax-error - #f - "not allowed in a trait" - e)]))])))) - - (define (extract expanded-clauses keyword-mapping) - (let loop ([l expanded-clauses] - [results (map (lambda (x) null) keyword-mapping)]) - (cond - [(null? l) (apply values results)] - [else - (let ([kw (stx-car (car l))]) - (if (or (module-identifier=? kw #'define-values) - (module-identifier=? kw #'field)) - (loop (cdr l) results) - (loop (cdr l) - (let iloop ([mapping keyword-mapping] - [results results]) - (if (ormap (lambda (x) (module-identifier=? kw x)) - (car mapping)) - (cons (append (stx->list (stx-cdr (car l))) - (car results)) - (cdr results)) - (cons (car results) - (iloop (cdr mapping) - (cdr results))))))))]))) - - (define (extract-fields expanded-clauses) - (apply - append - (map (lambda (clause) - (syntax-case clause (field) - [(field [id expr] ...) - (syntax->list #'(id ...))] - [_else null])) - expanded-clauses))) - - (define (make-bindings expanded-clauses) - (let ([boundmap (make-bound-identifier-mapping)]) - (for-each (lambda (clause) - (syntax-case clause (define-values field) - [(define-values (id) rhs) - (bound-identifier-mapping-put! boundmap #'id #'rhs)] - [(field [id expr] ...) - (for-each (lambda (id expr) - (bound-identifier-mapping-put! boundmap (internal-name id) expr)) - (syntax->list #'(id ...)) - (syntax->list #'(expr ...)))] - [_else (void)])) - expanded-clauses) - boundmap)) - - (define (internal-identifier=? a b) - (bound-identifier=? (internal-name a) (internal-name b))) - - (define (internal-name decl) - (if (identifier? decl) - decl - (stx-car decl))) - - (define (external-name decl) - (if (identifier? decl) - decl - (stx-car (stx-cdr decl)))) - - (define (check-distinct-names method-decls - what which - make-identifier-mapping - identifier-mapping-get - identifier-mapping-set!) - (let ([idmap (make-identifier-mapping)]) - (for-each (lambda (decl) - (let ([ext-id (which decl)]) - (when (identifier-mapping-get - idmap ext-id - (lambda () - (identifier-mapping-set! - idmap ext-id - #t) - #f)) - (raise-syntax-error - #f - (format "duplicate definition of ~a name in trait" - what) - ext-id)))) - method-decls))) - - (define (check-distinct-external-names method-decls) - (check-distinct-names method-decls - "external" external-name - make-module-identifier-mapping - module-identifier-mapping-get - module-identifier-mapping-put!)) - - (define (check-distinct-internal-names method-decls) - (check-distinct-names method-decls - "internal" internal-name - make-bound-identifier-mapping - bound-identifier-mapping-get - bound-identifier-mapping-put!)) - - (define (((compose-method-with-requirements binding-map - to-inherit to-super to-inner - to-inherit-field) - keyword inherit? super? inner? override? augment? always-deep?) - name) - (let ([impl (bound-identifier-mapping-get binding-map (internal-name name))] - [to-inherit (if always-deep? - (filter (lambda (n) (not (internal-identifier=? n name))) - to-inherit) - to-inherit)]) - (with-syntax ([(to-inherit ...) to-inherit] - [(to-super ...) to-super] - [(to-inner ...) to-inner] - [(to-inherit-field ...) to-inherit-field] - [(to-inherit-ext ...) (map external-name to-inherit)] - [(to-super-ext ...) (map external-name to-super)] - [(to-inner-ext ...) (map external-name to-inner)] - [(to-inherit-field-ext ...) (map external-name to-inherit-field)] - [(to-inherit-arg ...) (generate-temporaries to-inherit)] - [(to-super-arg ...) (generate-temporaries to-super)] - [(to-inner-arg ...) (generate-temporaries to-inner)] - [(to-inherit-field-arg ...) (generate-temporaries to-inherit-field)] - [impl impl] - [declare keyword] - [this-method (if always-deep? - name - #'this-method)] - [wrap-super-indirect (if override? - #'values - #'omit)] - [wrap-inner-indirect (if augment? - #'values - #'omit)]) - ;; for tracking unused bindings at the end: - (bound-identifier-mapping-put! binding-map (internal-name name) #f) - ;; generate method: - #`(make-method - (member-name-key #,(external-name name)) - #,inherit? #,super? #,inner? #,override? #,augment? - (list (member-name-key to-inherit-ext) ...) - (list (member-name-key to-super-ext) ...) - (list (member-name-key to-inner-ext) ...) - (list (member-name-key to-inherit-field-ext) ...) - (lambda (this-method-arg to-inherit-arg ... - to-super-arg ... - to-inner-arg ... - to-inherit-field-arg ...) - (define-member-name this-method this-method-arg) - (define-member-name to-inherit-ext to-inherit-arg) ... - (define-member-name to-super-ext to-super-arg) ... - (define-member-name to-inner-ext to-inner-arg) ... - (define-member-name to-inherit-field-ext to-inherit-field-arg) ... - (lambda (%) - (class % - (inherit to-inherit ...) - (inherit/super to-super ...) - (inherit/inner to-inner ...) - (inherit-field to-inherit-field ...) - (declare this-method) - (define this-method (let ([#,(internal-name name) impl]) - #,(internal-name name))) - (super-new)))) - ;; For `super' call indirections: - (wrap-super-indirect - (lambda (name-arg super-name-arg) - (define-member-name name name-arg) - (define-member-name super-name super-name-arg) - (lambda (%) - (class % - (override name) - (inherit/super super-name) - (define name (similar-lambda impl (super super-name))) - (super-new))))))))) - - (define ((compose-field binding-map) name) - (let ([impl (bound-identifier-mapping-get binding-map (internal-name name))]) - ;; for tracking unused bindings at the end: - (bound-identifier-mapping-put! binding-map (internal-name name) #f) - ;; generate method: - #`(make-feeld - (member-name-key #,(external-name name)) - (lambda (name-arg) - (define-member-name #,(external-name name) name-arg) - (lambda (%) - (class % - (field [#,name #,impl]) - (super-new))))))) - - (main stx)) - - (define-syntax (similar-lambda stx) - ;; Try to get arity the same: - (syntax-case stx (lambda) - [(_ (lambda (id ...) . __) (new-body ...)) - #'(lambda (id ...) (new-body ... id ...))] - ;; Generic case: - [(_ method-lambda (new-body ...)) - #'(lambda args (new-body ... . args))])) - - (define-syntax (omit stx) #'#f) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; trait->mixin - - (define (trait->mixin t) - (let ([methods (trait-methods t)]) - - ;; If a needed inherit, super, or inner is not immediately satisified, - ;; we can just leave it to the superclass. - ;; But we can't expect a super and have it introduced as non-overriding. - ;; We need to check in trait-sum, trait-alias, etc., because we'll - ;; have to use dummy introductions when stacking up the mixins, and - ;; there might be no error otherwise. - - ;; Order the mixins. If M1 super-calls M2 and we have an override - ;; for M2, then try to mix M2 later. Similarly, if M1 inner-calls M2 - ;; and we have an augment for M2, try to mix M2 earlier. - ;; We'll have to break cycles by inserting indirections, but we can't - ;; do that for `inner'; consequently, an `inner' from M1 to M2 - ;; might land at an implementation in the same trait! - ;; For simplicty, we sort right now by just all augments first - ;; and all overrides last. In the common case where methods - ;; only self-call supers and inners, that will work fine. - (let loop ([methods (sort methods - (lambda (a b) - (or (method-augment? a) - (method-override? b))))] - ;; Start by adding mixins for fields. Then continue - ;; by mixing a dummy method for each public/pubment - ;; method. We'll override it, but having it here at the start - ;; means that the methods can refer to each other via - ;; `inherit'. - [mixin (let loop ([methods methods] - [mixin (let loop ([mixin (lambda (%) %)] - [fields (trait-fields t)]) - (cond - [(null? fields) mixin] - [else (let ([mix ((feeld-make-mixin (car fields)) - (feeld-name (car fields)))]) - (loop (lambda (%) (mix (mixin %))) - (cdr fields)))]))]) - (cond - [(null? methods) mixin] - [else (let ([method (car methods)]) - (loop (cdr methods) - (if (or (method-override? method) - (method-augment? method)) - mixin - (introduce-into-mixin - (method-name method) - mixin))))]))] - [super-indirections null]) - (cond - [(null? methods) - ;; No more methods to add, so just insert needed - ;; super indirections (as accumulated when adding - ;; methods before): - (let loop ([indirections super-indirections] - [mixin mixin]) - (cond - [(null? indirections) mixin] - [else (let ([method (list-ref (car indirections) 2)]) - (loop (cdr indirections) - (let ([mix ((method-make-super-indirection-mixin method) - (method-name method) - (cadar indirections))]) - (lambda (%) (mix (mixin %))))))]))] - [else - ;; Add one method: - (let*-values ([(method) (car methods)] - ;; Rename method, in case we need a super - ;; indirection: - [(name) - (if (and (method-override? method) - (ormap (lambda (m) - (ormap (lambda (n) - (same-name? n (method-name method))) - (method-need-super m))) - (cdr methods))) - (generate-member-key) - (method-name method))] - ;; Build the base mixin: - [(next-mixin) (apply - (method-make-mixin method) - name - (append - (method-need-inherit method) - (method-need-super method) - (method-need-inner method) - (method-need-field method)))]) - (loop (cdr methods) - (lambda (%) (next-mixin (mixin %))) - (if (eq? name (method-name method)) - super-indirections - (cons (list (method-name method) - name - method) - super-indirections))))])))) - - (define (introduce-into-mixin name mixin) - (define-member-name m name) - (lambda (%) - (class (mixin %) - (define/public (m) 'inroduce-stub) - (super-new)))) - - (define same-name? member-name-key=?) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; sum, exclude, alias - - (define (validate-trait who t) - ;; Methods: - (let ([ht (make-hash-table)]) - ;; Build up table and check for duplicates: - (for-each (lambda (m) - (let* ([name (method-name m)] - [key (member-name-key-hash-code name)]) - (let ([l (hash-table-get ht key null)]) - (when (ormap (lambda (n) (member-name-key=? (car n) name)) - l) - (raise-mismatch-error - who - "result would include multiple declarations of a method: " - name)) - (hash-table-put! ht key (cons (cons name m) l))))) - (trait-methods t)) - ;; Check consistency of expectations and provisions: - (let* ([find (lambda (name) - (let ([l (hash-table-get ht (member-name-key-hash-code name) null)]) - (ormap (lambda (n) - (and (member-name-key=? (car n) name) - (cdr n))) - l)))] - [check (lambda (super? inner?) - (lambda (name) - (let ([m (find name)]) - (when m - (when (and super? - (not (method-override? m))) - (raise-mismatch-error - who - (string-append - "result would include both a super requirement and" - " a non-overriding declaration for method: ") - name)) - - (when (and inner? - (not (method-inner? m))) - (raise-mismatch-error - who - (string-append - "result would include both an inner requirement and" - " a non-augmentable declaration for method: ") - name))))))]) - (for-each (lambda (m) - (for-each (check #t #f) - (method-need-super m)) - (for-each (check #f #t) - (method-need-inner m))) - (trait-methods t)))) - ;; Fields: - (let ([ht (make-hash-table)]) - ;; Build up table and check for duplicates: - (for-each (lambda (f) - (let* ([name (feeld-name f)] - [key (member-name-key-hash-code name)]) - (let ([l (hash-table-get ht key null)]) - (when (ormap (lambda (n) (member-name-key=? (car n) name)) - l) - (raise-mismatch-error - who - "result would include multiple declarations of a field: " - name)) - (hash-table-put! ht key (cons (cons name f) l))))) - (trait-fields t))) - ;; Return validated trait: - t) - - (define (trait-sum . ts) - (for-each (lambda (t) - (unless (trait? t) - (raise-type-error 'trait-sum "trait" t))) - ts) - (validate-trait - 'trait-sum - (make-trait (apply - append - (map trait-methods ts)) - (apply - append - (map trait-fields ts))))) - - (define (:trait-exclude t name) - (unless (trait? t) - (raise-type-error 'trait-exclude "trait" t)) - (let ([new-methods - (filter (lambda (m) - (not (member-name-key=? (method-name m) name))) - (trait-methods t))]) - (when (= (length new-methods) - (length (trait-methods t))) - (raise-mismatch-error - 'trait-exclude - "method not in trait: " name)) - (make-trait new-methods (trait-fields t)))) - - (define (:trait-exclude-field t name) - (unless (trait? t) - (raise-type-error 'trait-exclude-field "trait" t)) - (let ([new-fields - (filter (lambda (m) - (not (member-name-key=? (feeld-name m) name))) - (trait-fields t))]) - (when (= (length new-fields) - (length (trait-fields t))) - (raise-mismatch-error - 'trait-exclude - "field not in trait: " name)) - (make-trait (trait-methods t) new-fields))) - - (define-syntax define-trait-exclude - (syntax-rules () - [(_ trait-exclude :trait-exclude) - (define-syntax (trait-exclude stx) - (syntax-case stx () - [(_ t name) - (begin - (unless (identifier? #'name) - (raise-syntax-error - #f - "expected an identifier for a method name" - stx - #'name)) - #'(:trait-exclude t (member-name-key name)))]))])) - - (define-trait-exclude trait-exclude :trait-exclude) - (define-trait-exclude trait-exclude-field :trait-exclude-field) - - (define (:trait-alias t name new-name) - (unless (trait? t) - (raise-type-error 'trait-alias "trait" t)) - (let ([m (ormap (lambda (m) - (and (member-name-key=? (method-name m) name) - m)) - (trait-methods t))]) - (unless m - (raise-mismatch-error - 'trait-alias - "method not in trait: " name)) - (validate-trait - 'trait-alias - (make-trait - (cons (copy-struct method m - [method-name new-name]) - (trait-methods t)) - (trait-fields t))))) - - (define (:trait-rename t name new-name) - (unless (trait? t) - (raise-type-error 'trait-rename "trait" t)) - (let ([rename (lambda (n) - (if (same-name? n name) - new-name - n))]) - (validate-trait - 'trait-rename - (make-trait - (map (lambda (m) - (copy-struct method m - [method-name (rename (method-name m))] - [method-need-inherit (map rename (method-need-inherit m))] - [method-need-super (map rename (method-need-super m))] - [method-need-inner (map rename (method-need-inner m))])) - (trait-methods t)) - (trait-fields t))))) - - (define (:trait-rename-field t name new-name) - (unless (trait? t) - (raise-type-error 'trait-rename-field "trait" t)) - (let ([rename (lambda (n) - (if (same-name? n name) - new-name - n))]) - (validate-trait - 'trait-rename - (make-trait - (map (lambda (m) - (copy-struct method m - [method-need-field (map rename (method-need-field m))])) - (trait-methods t)) - (map (lambda (f) - (copy-struct feeld f - [feeld-name (rename (feeld-name f))])) - (trait-fields t)))))) - - (define-syntax define-trait-alias - (syntax-rules () - [(_ trait-alias :trait-alias) - (define-syntax (trait-alias stx) - (syntax-case stx () - [(_ t name new-name) - (begin - (unless (identifier? #'name) - (raise-syntax-error - #f - "expected an identifier for a method name" - stx - #'name)) - (unless (identifier? #'new-name) - (raise-syntax-error - #f - "expected an identifier for a method name" - stx - #'new-name)) - #'(:trait-alias t (member-name-key name) (member-name-key new-name)))]))])) - - (define-trait-alias trait-alias :trait-alias) - (define-trait-alias trait-rename :trait-rename) - (define-trait-alias trait-rename-field :trait-rename-field) - - ;; ----------------------------------------; - ) +(module trait scheme/base + (require scheme/trait) + (provide (all-from-out scheme/trait))) diff --git a/collects/scheme/private/contract-arr-checks.ss b/collects/scheme/private/contract-arr-checks.ss new file mode 100644 index 0000000..87be0df --- /dev/null +++ b/collects/scheme/private/contract-arr-checks.ss @@ -0,0 +1,198 @@ +(module contract-arr-checks mzscheme + (provide (all-defined)) + (require (lib "list.ss") + "contract-guts.ss") + + (define empty-case-lambda/c + (flat-named-contract '(case->) + (λ (x) (and (procedure? x) (null? (procedure-arity x)))))) + + ;; ---------------------------------------- + ;; Checks and error functions used in macro expansions + + ;; 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 (sort (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))))]))) + + (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 argument~a and arbitrarily many more, got ~e" + arity-count + (if (= 1 arity-count) "" "s") + f))) + + + (define (check-pre-expr->pp/h val pre-expr src-info blame orig-str) + (unless pre-expr + (raise-contract-error val + src-info + blame + orig-str + "pre-condition expression failure"))) + + (define (check-post-expr->pp/h val post-expr src-info blame orig-str) + (unless post-expr + (raise-contract-error val + src-info + blame + orig-str + "post-condition expression failure"))) + + (define (check-procedure val dom-length src-info blame orig-str) + (unless (and (procedure? val) + (procedure-arity-includes? val dom-length)) + (raise-contract-error + val + src-info + blame + orig-str + "expected a procedure that accepts ~a arguments, given: ~e" + dom-length + val))) + + (define ((check-procedure? arity) val) + (and (procedure? val) + (procedure-arity-includes? val arity))) + + (define ((check-procedure/more? arity) val) + (and (procedure? val) + (procedure-accepts-and-more? val arity))) + + (define (check-procedure/kind val arity kind-of-thing src-info blame orig-str) + (unless (procedure? val) + (raise-contract-error val + src-info + blame + orig-str + "expected a procedure, got ~e" + val)) + (unless (procedure-arity-includes? val arity) + (raise-contract-error val + src-info + 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 blame orig-str) + (unless (procedure? val) + (raise-contract-error val + src-info + blame + orig-str + "expected a procedure, got ~e" + val)) + (unless (procedure-accepts-and-more? val arity) + (raise-contract-error val + src-info + 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 blame orig-str) + (unless (and (procedure? val) + (procedure-accepts-and-more? val dom-length)) + (raise-contract-error + val + src-info + 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)))) + + #| + + 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))) + + |# +) diff --git a/collects/scheme/private/contract-arr-obj-helpers.ss b/collects/scheme/private/contract-arr-obj-helpers.ss new file mode 100644 index 0000000..8c4b904 --- /dev/null +++ b/collects/scheme/private/contract-arr-obj-helpers.ss @@ -0,0 +1,1111 @@ +(module contract-arr-obj-helpers mzscheme + (require (lib "stx.ss" "syntax") + (lib "name.ss" "syntax")) + + (require-for-template mzscheme + "contract-guts.ss" + "contract-arr-checks.ss") + + (provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h + ->pp/h ->pp-rest/h + make-case->/proc + make-opt->/proc make-opt->*/proc) + + ;; 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 first-order-check 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 + (syntax + (lambda (val) + inner-check + inner-lambda))]) + (with-syntax ([proj-code (build-proj outer-args inner-lambda)] + [first-order-check first-order-check]) + (arguments-check + outer-args + (syntax/loc stx + (make-proj-contract + name-id + (lambda (pos-blame neg-blame src-info orig-str) + proj-code) + first-order-check)))))))))) + + (define (make-case->/proc method-proc? stx inferred-name-stx select/h) + (syntax-case stx () + + ;; if there are no cases, this contract should only accept the "empty" case-lambda. + [(_) (syntax empty-case-lambda/c)] + + ;; if there is only a single case, just skip it. + [(_ case) (syntax case)] + + [(_ cases ...) + (let-values ([(arguments-check build-projs check-val first-order-check wrapper) + (case->/h method-proc? stx (syntax->list (syntax (cases ...))) select/h)]) + (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 + inferred-name-stx + (syntax/loc stx (case-lambda body ...)))]) + (let ([inner-lambda + (syntax + (lambda (val) + inner-check ... + inner-lambda))]) + (with-syntax ([proj-code (build-projs outer-args inner-lambda)] + [first-order-check first-order-check]) + (arguments-check + outer-args + (syntax/loc stx + (make-proj-contract + (apply build-compound-type-name 'case-> name-id) + (lambda (pos-blame neg-blame src-info orig-str) + proj-code) + first-order-check)))))))))])) + + (define (make-opt->/proc method-proc? stx select/h case-arr-stx arr-stx) + (syntax-case stx (any) + [(_ (reqs ...) (opts ...) any) + (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)) stx select/h case-arr-stx arr-stx)] + [(_ (reqs ...) (opts ...) res) + (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))) stx select/h case-arr-stx arr-stx)])) + + (define (make-opt->*/proc method-proc? stx inferred-name-stx select/h case-arr-stx arr-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? + (with-syntax ([case-> case-arr-stx] + [-> arr-stx]) + (syntax (case-> (-> case-doms ... any) ...))) + inferred-name-stx + select/h)]) + (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? + (with-syntax ([case-> case-arr-stx] + [-> arr-stx]) + (syntax (case-> (-> case-doms ... single-case-result) ...))) + inferred-name-stx + select/h)]) + (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) + ;; select/h + ;; -> (values (syntax -> syntax) + ;; (syntax -> syntax) + ;; (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 select/h) + (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 ())) + (syntax (lambda (x) #t)) + (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 first-order-checks wrappers) + (loop (cdr cases) (cons new-id name-ids))] + [(arguments-check build-proj check-val first-order-check 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)))) + (with-syntax ([checks first-order-checks] + [check first-order-check]) + (syntax (lambda (x) (and (checks x) (check x))))) + (lambda (args) + (with-syntax ([case (wrapper args)] + [cases (wrappers args)]) + (syntax (case . cases)))))))]))) + + ;; 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)))) + + ;; 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 six 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 the projection + ;; - [check-val] + ;; code that does error checking on the contract'd value itself + ;; (is it a function of the right arity?) + ;; - [first-order-check] + ;; predicate function that does the first order check and returns a boolean + ;; (is it a function of the right arity?) + ;; - [pos-wrapper] + ;; a piece of syntax that has the arguments to the wrapper + ;; and the body of the wrapper. + ;; - [neg-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 five + ;; names: val, 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)))))) + + ;; proj + (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 orig-str)))) + (syntax (check-procedure? dom-length)) + (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)))))) + + ;; proj + (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 orig-str)))) + (syntax (check-procedure? dom-length)) + + (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)))))) + + ;; proj + (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 orig-str)))) + (syntax (check-procedure? dom-length)) + (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 ...)) + (->/h method-proc? (syntax (-> dom ... (values rng ...))))] + [(_ (dom ...) any) + (->/h method-proc? (syntax (-> dom ... any)))] + [(_ (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)))))) + ;; proj + (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 orig-str)))) + (syntax (check-procedure/more? dom-length)) + (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)))))) + ;; proj + (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-procedure/more val dom-length src-info pos-blame orig-str)))) + (syntax (check-procedure/more? dom-length)) + (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 ([(rng-x) (generate-temporaries (syntax (rng)))] + [(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)))))) + + ;; proj + (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 orig-str)))) + + (syntax (check-procedure? arity)) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (let ([arg-x (dom-projection-x arg-x)] ...) + (let ([rng-contract (rng-x arg-x ...)]) + (((contract-proc (coerce-contract '->d rng-contract)) + pos-blame + neg-blame + src-info + orig-str) + (val 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)))))) + + ;; proj + (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 orig-str)))) + (syntax (check-procedure? dom-length)) + + (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) + (((contract-proc (coerce-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)))))) + + ;; proj + (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-procedure/more val arity src-info pos-blame orig-str)))) + (syntax (check-procedure/more? arity)) + + (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) + (((contract-proc (coerce-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 orig-str))))) + + (syntax (check-procedure? arity)) + + (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 val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-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 val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-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 val post-expr src-info pos-blame orig-str) + (let ([rng-ids-x ((contract-proc (coerce-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 val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] + ... + [rng-id ((contract-proc (coerce-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 val post-expr src-info pos-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 orig-str))))) + (syntax (check-procedure/more? arity)) + + (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 val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] + ... + [rest-id ((contract-proc (coerce-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 val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] + ... + [rest-id ((contract-proc (coerce-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 val post-expr src-info pos-blame orig-str) + (let ([rng-ids-x ((contract-proc (coerce-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 val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] + ... + [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)] + [rng-id ((contract-proc (coerce-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 val post-expr src-info pos-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))])) + + ;; 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]))) + + ;; 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)))])))))) diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss new file mode 100644 index 0000000..7dbfead --- /dev/null +++ b/collects/scheme/private/contract-arrow.ss @@ -0,0 +1,461 @@ +(module contract-arrow mzscheme + (require (lib "etc.ss") + "contract-guts.ss" + "contract-arr-checks.ss" + "contract-opt.ss") + (require-for-syntax "contract-opt-guts.ss" + "contract-helpers.ss" + "contract-arr-obj-helpers.ss" + (lib "stx.ss" "syntax") + (lib "name.ss" "syntax")) + + (provide -> + ->d + ->* + ->d* + ->r + ->pp + ->pp-rest + case-> + opt-> + opt->* + unconstrained-domain-> + check-procedure) + + (define-syntax (unconstrained-domain-> stx) + (syntax-case stx () + [(_ rngs ...) + (with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))] + [(proj-x ...) (generate-temporaries #'(rngs ...))] + [(p-app-x ...) (generate-temporaries #'(rngs ...))] + [(res-x ...) (generate-temporaries #'(rngs ...))]) + #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) + (let ([proj-x ((proj-get rngs-x) rngs-x)] ...) + (make-proj-contract + (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) + (λ (pos-blame neg-blame src-info orig-str) + (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...) + (λ (val) + (if (procedure? val) + (λ args + (let-values ([(res-x ...) (apply val args)]) + (values (p-app-x res-x) ...))) + (raise-contract-error val + src-info + pos-blame + orig-str + "expected a procedure"))))) + procedure?))))])) + + ;; FIXME: need to pass in the name of the contract combinator. + (define (build--> name doms doms-rest rngs rng-any? func) + (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] + [rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)] + [doms-rest/c (and doms-rest (coerce-contract name doms-rest))]) + (make--> rng-any? doms/c doms-rest/c rngs/c func))) + + (define-struct/prop -> (rng-any? doms dom-rest rngs func) + ((proj-prop (λ (ctc) + (let* ([doms/c (map (λ (x) ((proj-get x) x)) + (if (->-dom-rest ctc) + (append (->-doms ctc) (list (->-dom-rest ctc))) + (->-doms ctc)))] + [rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))] + [func (->-func ctc)] + [dom-length (length (->-doms ctc))] + [check-proc + (if (->-dom-rest ctc) + check-procedure/more + check-procedure)]) + (lambda (pos-blame neg-blame src-info orig-str) + (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) + doms/c)] + [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str)) + rngs/c)]) + (apply func + (λ (val) (check-proc val dom-length src-info pos-blame orig-str)) + (append partial-doms partial-ranges))))))) + (name-prop (λ (ctc) (single-arrow-name-maker + (->-doms ctc) + (->-dom-rest ctc) + (->-rng-any? ctc) + (->-rngs ctc)))) + (first-order-prop + (λ (ctc) + (let ([l (length (->-doms ctc))]) + (if (->-dom-rest ctc) + (λ (x) + (and (procedure? x) + (procedure-accepts-and-more? x l))) + (λ (x) + (and (procedure? x) + (procedure-arity-includes? x l))))))) + (stronger-prop + (λ (this that) + (and (->? that) + (= (length (->-doms that)) + (length (->-doms this))) + (andmap contract-stronger? + (->-doms that) + (->-doms this)) + (= (length (->-rngs that)) + (length (->-rngs this))) + (andmap contract-stronger? + (->-rngs this) + (->-rngs that))))))) + + (define (single-arrow-name-maker doms/c doms-rest rng-any? rngs) + (cond + [doms-rest + (build-compound-type-name + '->* + (apply build-compound-type-name doms/c) + doms-rest + (cond + [rng-any? 'any] + [else (apply build-compound-type-name rngs)]))] + [else + (let ([rng-name + (cond + [rng-any? 'any] + [(null? rngs) '(values)] + [(null? (cdr rngs)) (car rngs)] + [else (apply build-compound-type-name 'values rngs)])]) + (apply build-compound-type-name '-> (append doms/c (list rng-name))))])) + + (define arity-one-wrapper + (lambda (chk a3 c5) (lambda (val) (chk val) (lambda (a1) (c5 (val (a3 a1))))))) + + (define arity-two-wrapper + (lambda (chk a3 b4 c5) (lambda (val) (chk val) (lambda (a1 b2) (c5 (val (a3 a1) (b4 b2))))))) + + (define arity-three-wrapper + (lambda (chk a9 b10 c11 r12) (lambda (val) (chk val) (lambda (a6 b7 c8) (r12 (val (a9 a6) (b10 b7) (c11 c8))))))) + + (define arity-four-wrapper + (lambda (chk a17 b18 c19 d20 r21) (lambda (val) (chk val) (lambda (a13 b14 c15 d16) (r21 (val (a17 a13) (b18 b14) (c19 c15) (d20 d16))))))) + + (define arity-five-wrapper + (lambda (chk a27 b28 c29 d30 e31 r32) + (lambda (val) (chk val) (lambda (a22 b23 c24 d25 e26) (r32 (val (a27 a22) (b28 b23) (c29 c24) (d30 d25) (e31 e26))))))) + + (define arity-six-wrapper + (lambda (chk a39 b40 c41 d42 e43 f44 r45) + (lambda (val) (chk val) (lambda (a33 b34 c35 d36 e37 f38) (r45 (val (a39 a33) (b40 b34) (c41 c35) (d42 d36) (e43 e37) (f44 f38))))))) + + (define arity-seven-wrapper + (lambda (chk a53 b54 c55 d56 e57 f58 g59 r60) + (lambda (val) (chk val) (lambda (a46 b47 c48 d49 e50 f51 g52) (r60 (val (a53 a46) (b54 b47) (c55 c48) (d56 d49) (e57 e50) (f58 f51) (g59 g52))))))) + + (define-syntax-set (-> ->*) + (define (->/proc stx) + (let-values ([(stx _1 _2) (->/proc/main stx)]) + stx)) + + ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) + (define (->/proc/main stx) + (let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)]) + (with-syntax ([(args body) inner-args/body]) + (with-syntax ([(dom-names ...) dom-names] + [(rng-names ...) rng-names] + [(dom-ctcs ...) dom-ctcs] + [(rng-ctcs ...) rng-ctcs] + [inner-lambda + (add-name-prop + (syntax-local-infer-name stx) + (syntax (lambda args body)))] + [use-any? use-any?]) + (with-syntax ([outer-lambda + (let* ([lst (syntax->list #'args)] + [len (and lst (length lst))]) + (if (and #f ;; this optimization disables the names so is turned off for now + lst + (not (syntax-e #'use-any?)) + (= len (length (syntax->list #'(dom-names ...)))) + (= 1 (length (syntax->list #'(rng-names ...)))) + (<= 1 len 7)) + (case len + [(1) #'arity-one-wrapper] + [(2) #'arity-two-wrapper] + [(3) #'arity-three-wrapper] + [(4) #'arity-four-wrapper] + [(5) #'arity-five-wrapper] + [(6) #'arity-six-wrapper] + [(7) #'arity-seven-wrapper]) + (syntax + (lambda (chk dom-names ... rng-names ...) + (lambda (val) + (chk val) + inner-lambda)))))]) + (values + (syntax (build--> '-> + (list dom-ctcs ...) + #f + (list rng-ctcs ...) + use-any? + outer-lambda)) + inner-args/body + (syntax (dom-names ... rng-names ...)))))))) + + (define (->-helper stx) + (syntax-case* stx (-> any values) module-or-top-identifier=? + [(-> doms ... any) + (with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] + [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] + [(ignored) (generate-temporaries (syntax (rng)))]) + (values (syntax (dom-ctc ...)) + (syntax (ignored)) + (syntax (doms ...)) + (syntax (any/c)) + (syntax ((args ...) (val (dom-ctc args) ...))) + #t))] + [(-> doms ... (values rngs ...)) + (with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] + [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] + [(rng-x ...) (generate-temporaries (syntax (rngs ...)))] + [(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))]) + (values (syntax (dom-ctc ...)) + (syntax (rng-ctc ...)) + (syntax (doms ...)) + (syntax (rngs ...)) + (syntax ((args ...) + (let-values ([(rng-x ...) (val (dom-ctc args) ...)]) + (values (rng-ctc rng-x) ...)))) + #f))] + [(_ doms ... rng) + (with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] + [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] + [(rng-ctc) (generate-temporaries (syntax (rng)))]) + (values (syntax (dom-ctc ...)) + (syntax (rng-ctc)) + (syntax (doms ...)) + (syntax (rng)) + (syntax ((args ...) (rng-ctc (val (dom-ctc args) ...)))) + #f))])) + + (define (->*/proc stx) + (let-values ([(stx _1 _2) (->*/proc/main stx)]) + stx)) + + ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) + (define (->*/proc/main stx) + (syntax-case* stx (->* any) module-or-top-identifier=? + [(->* (doms ...) any) + (->/proc/main (syntax (-> doms ... any)))] + [(->* (doms ...) (rngs ...)) + (->/proc/main (syntax (-> doms ... (values rngs ...))))] + [(->* (doms ...) rst (rngs ...)) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))] + [(args ...) (generate-temporaries (syntax (doms ...)))] + [(rst-x) (generate-temporaries (syntax (rst)))] + [(rest-arg) (generate-temporaries (syntax (rst)))] + [(rng-x ...) (generate-temporaries (syntax (rngs ...)))] + [(rng-args ...) (generate-temporaries (syntax (rngs ...)))]) + (let ([inner-args/body + (syntax ((args ... . rest-arg) + (let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))]) + (values (rng-x rng-args) ...))))]) + (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body]) + (add-name-prop + (syntax-local-infer-name stx) + (syntax (lambda args body))))]) + (with-syntax ([outer-lambda + (syntax + (lambda (chk dom-x ... rst-x rng-x ...) + (lambda (val) + (chk val) + inner-lambda)))]) + (values (syntax (build--> '->* + (list doms ...) + rst + (list rngs ...) + #f + outer-lambda)) + inner-args/body + (syntax (dom-x ... rst-x rng-x ...)))))))] + [(->* (doms ...) rst any) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))] + [(args ...) (generate-temporaries (syntax (doms ...)))] + [(rst-x) (generate-temporaries (syntax (rst)))] + [(rest-arg) (generate-temporaries (syntax (rst)))]) + (let ([inner-args/body + (syntax ((args ... . rest-arg) + (apply val (dom-x args) ... (rst-x rest-arg))))]) + (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body]) + (add-name-prop + (syntax-local-infer-name stx) + (syntax (lambda args body))))]) + (with-syntax ([outer-lambda + (syntax + (lambda (chk dom-x ... rst-x ignored) + (lambda (val) + (chk val) + inner-lambda)))]) + (values (syntax (build--> '->* + (list doms ...) + rst + (list any/c) + #t + outer-lambda)) + inner-args/body + (syntax (dom-x ... rst-x)))))))]))) + + (define-for-syntax (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)])) + + (define-syntax (->d stx) (make-/proc #f ->d/h stx)) + (define-syntax (->d* stx) (make-/proc #f ->d*/h stx)) + (define-syntax (->r stx) (make-/proc #f ->r/h stx)) + (define-syntax (->pp stx) (make-/proc #f ->pp/h stx)) + (define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx)) + (define-syntax (case-> stx) (make-case->/proc #f stx stx select/h)) + (define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->)) + (define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->)) + + ;; + ;; arrow opter + ;; + (define/opter (-> opt/i opt/info stx) + (define (opt/arrow-ctc doms rngs) + (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms) + (generate-temporaries rngs))] + [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) + (let loop ([vars dom-vars] + [doms doms] + [next-doms null] + [lifts-doms null] + [superlifts-doms null] + [partials-doms null] + [stronger-ribs null]) + (cond + [(null? doms) (values (reverse next-doms) + lifts-doms + superlifts-doms + partials-doms + stronger-ribs)] + [else + (let-values ([(next lift superlift partial _ __ this-stronger-ribs) + (opt/i (opt/info-swap-blame opt/info) (car doms))]) + (loop (cdr vars) + (cdr doms) + (cons (with-syntax ((next next) + (car-vars (car vars))) + (syntax (let ((val car-vars)) next))) + next-doms) + (append lifts-doms lift) + (append superlifts-doms superlift) + (append partials-doms partial) + (append this-stronger-ribs stronger-ribs)))]))] + [(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng) + (let loop ([vars rng-vars] + [rngs rngs] + [next-rngs null] + [lifts-rngs null] + [superlifts-rngs null] + [partials-rngs null] + [stronger-ribs null]) + (cond + [(null? rngs) (values (reverse next-rngs) + lifts-rngs + superlifts-rngs + partials-rngs + stronger-ribs)] + [else + (let-values ([(next lift superlift partial _ __ this-stronger-ribs) + (opt/i opt/info (car rngs))]) + (loop (cdr vars) + (cdr rngs) + (cons (with-syntax ((next next) + (car-vars (car vars))) + (syntax (let ((val car-vars)) next))) + next-rngs) + (append lifts-rngs lift) + (append superlifts-rngs superlift) + (append partials-rngs partial) + (append this-stronger-ribs stronger-ribs)))]))]) + (values + (with-syntax ((pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) + ((dom-arg ...) dom-vars) + ((rng-arg ...) rng-vars) + ((next-dom ...) next-doms) + (dom-len (length dom-vars)) + ((next-rng ...) next-rngs)) + (syntax (begin + (check-procedure val dom-len src-info pos orig-str) + (λ (dom-arg ...) + (let-values ([(rng-arg ...) (val next-dom ...)]) + (values next-rng ...)))))) + (append lifts-doms lifts-rngs) + (append superlifts-doms superlifts-rngs) + (append partials-doms partials-rngs) + #f + #f + (append stronger-ribs-dom stronger-ribs-rng)))) + + (define (opt/arrow-any-ctc doms) + (let*-values ([(dom-vars) (generate-temporaries doms)] + [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) + (let loop ([vars dom-vars] + [doms doms] + [next-doms null] + [lifts-doms null] + [superlifts-doms null] + [partials-doms null] + [stronger-ribs null]) + (cond + [(null? doms) (values (reverse next-doms) + lifts-doms + superlifts-doms + partials-doms + stronger-ribs)] + [else + (let-values ([(next lift superlift partial flat _ this-stronger-ribs) + (opt/i (opt/info-swap-blame opt/info) (car doms))]) + (loop (cdr vars) + (cdr doms) + (cons (with-syntax ((next next) + (car-vars (car vars))) + (syntax (let ((val car-vars)) next))) + next-doms) + (append lifts-doms lift) + (append superlifts-doms superlift) + (append partials-doms partial) + (append this-stronger-ribs stronger-ribs)))]))]) + (values + (with-syntax ((pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) + ((dom-arg ...) dom-vars) + ((next-dom ...) next-doms) + (dom-len (length dom-vars))) + (syntax (begin + (check-procedure val dom-len src-info pos orig-str) + (λ (dom-arg ...) + (val next-dom ...))))) + lifts-doms + superlifts-doms + partials-doms + #f + #f + stronger-ribs-dom))) + + (syntax-case* stx (-> values any) module-or-top-identifier=? + [(-> dom ... (values rng ...)) + (opt/arrow-ctc (syntax->list (syntax (dom ...))) + (syntax->list (syntax (rng ...))))] + [(-> dom ... any) + (opt/arrow-any-ctc (syntax->list (syntax (dom ...))))] + [(-> dom ... rng) + (opt/arrow-ctc (syntax->list (syntax (dom ...))) + (list #'rng))]))) diff --git a/collects/scheme/private/contract-object.ss b/collects/scheme/private/contract-object.ss new file mode 100644 index 0000000..4d670d7 --- /dev/null +++ b/collects/scheme/private/contract-object.ss @@ -0,0 +1,438 @@ +(module contract-object mzscheme + (require (lib "etc.ss") + "contract-arrow.ss" + "contract-guts.ss" + "class-internal.ss" + "contract-arr-checks.ss") + + (require-for-syntax "contract-helpers.ss" + "contract-arr-obj-helpers.ss" + (lib "list.ss")) + + (provide mixin-contract + make-mixin-contract + is-a?/c + subclass?/c + implementation?/c + object-contract) + + (define-syntax-set (object-contract) + + (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 (obj-case->/proc stx) (make-case->/proc #t stx stx select/h)) + + ;; WARNING: select/h is copied from contract-arrow.ss. I'm not sure how + ;; I can avoid this duplication -robby + (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)])) + + + (define (obj-opt->/proc stx) (make-opt->/proc #t stx select/h #'case-> #'->)) + (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx select/h #'case-> #'->)) + + (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 ...) + ;; this case cheats a little bit -- + ;; (args ...) contains the right number of arguments + ;; to the method because it also contains one arg for the result! urgh. + (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 ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))] + [this (datum->syntax-object mtd-stx 'this)]) + (values + obj->r/proc + (syntax (->r ([this any/c] [x dom] ...) rng)) + (syntax ((this-var arg-vars ...)))))] + + [(->r ([x dom] ...) rest-x rest-dom rng) + (andmap identifier? (syntax->list (syntax (x ...)))) + (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))] + [this (datum->syntax-object mtd-stx 'this)]) + (values + obj->r/proc + (syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng)) + (syntax ((this-var 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 ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))] + [this (datum->syntax-object mtd-stx 'this)]) + (values + obj->pp/proc + (syntax (->pp ([this any/c] [x dom] ...) . other-stuff)) + (syntax ((this-var 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 ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))] + [this (datum->syntax-object mtd-stx 'this)]) + (values + obj->pp-rest/proc + (syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff)) + (syntax ((this-var 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)] + ...) + (let ([cls (make-wrapper-class 'wrapper-class + '(method-name ...) + (list methods ...) + '(field-name ...))]) + (make-proj-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 ([field-names-list '(field-name ...)]) + (lambda (val) + (check-object val src-info pos-blame orig-str) + (let ([val-mtd-names + (interface->method-names + (object-interface + val))]) + (void) + (check-method val 'method-name val-mtd-names src-info pos-blame orig-str) + ...) + + (unless (field-bound? field-name val) + (field-error val 'field-name src-info pos-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)) ... + )))))) + #f)))))))]))) + + + (define (check-object val src-info blame orig-str) + (unless (object? val) + (raise-contract-error val + src-info + blame + orig-str + "expected an object, got ~e" + val))) + + (define (check-method val method-name val-mtd-names src-info blame orig-str) + (unless (memq method-name val-mtd-names) + (raise-contract-error val + src-info + blame + orig-str + "expected an object with method ~s" + method-name))) + + (define (field-error val field-name src-info blame orig-str) + (raise-contract-error val + src-info + blame + orig-str + "expected an object with field ~s" + field-name)) + + (define (make-mixin-contract . %/<%>s) + ((and/c (flat-contract class?) + (apply and/c (map sub/impl?/c %/<%>s))) + . ->d . + subclass?/c)) + + (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 (sub/impl?/c %/<%>) + (cond + [(interface? %/<%>) (implementation?/c %/<%>)] + [(class? %/<%>) (subclass?/c %/<%>)] + [else (error 'make-mixin-contract "unknown input ~e" %/<%>)])) + + (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 mixin-contract (class? . ->d . subclass?/c))) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 8a2ed75..c66bfdd 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -4814,7 +4814,7 @@ so that propagation occurs. 'provide/contract12 '(begin (eval '(module pc12-m mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct (exn2 exn) ()) (provide/contract (struct (exn2 exn) ((message any/c) (continuation-marks any/c)))))) (eval '(require 'pc12-m)))) @@ -4823,7 +4823,7 @@ so that propagation occurs. 'provide/contract13 '(begin (eval '(module pc13-common-msg-structs mzscheme - (require (lib "contract.ss" "mzlib")) + (require scheme/contract) (define-struct register (name type) (make-inspector)) (provide/contract (struct register ([name any/c] [type any/c]))))) @@ -4838,7 +4838,7 @@ so that propagation occurs. 'provide/contract14 '(begin (eval '(module pc14-test1 mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct type (flags)) (define-struct (type:ptr type) (type)) @@ -4861,7 +4861,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pos mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (provide/contract [i any/c])))) exn:fail:syntax?) @@ -4871,7 +4871,7 @@ so that propagation occurs. 'provide/contract15 '(begin (eval '(module pos mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define i #f) (provide/contract [i integer?]))) (eval '(require 'pos))) @@ -4882,7 +4882,7 @@ so that propagation occurs. 'provide/contract16 '(begin (eval '(module neg mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define i #f) (provide/contract [i integer?]))) (eval '(require 'neg))) @@ -4895,7 +4895,7 @@ so that propagation occurs. 'provide/contract17 '(begin (eval '(module pos mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct s (a)) (provide/contract [struct s ((a integer?))]))) (eval '(module neg mzscheme @@ -4908,7 +4908,7 @@ so that propagation occurs. 'provide/contract18 '(begin (eval '(module pc18-pos mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct s ()) (provide/contract [struct s ()]))) (eval '(require 'pc18-pos)) @@ -4918,19 +4918,19 @@ so that propagation occurs. 'provide/contract19 '(begin (eval '(module pc19-a mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct a (x)) (provide/contract [struct a ([x number?])]))) (eval '(module pc19-b mzscheme (require 'pc19-a - (lib "contract.ss")) + scheme/contract) (define-struct (b a) (y)) (provide/contract [struct (b a) ([x number?] [y number?])]))) (eval '(module pc19-c mzscheme (require 'pc19-b - (lib "contract.ss")) + scheme/contract) (define-struct (c b) (z)) (provide/contract [struct (c b) ([x number?] [y number?] [z number?])]))) @@ -4948,7 +4948,7 @@ so that propagation occurs. (test/spec-passed 'provide/contract20 '(eval '(module tmp mzscheme - (require (lib "contract.ss") + (require scheme/contract (lib "unit.ss")) (define-struct s (a b)) @@ -4961,7 +4961,7 @@ so that propagation occurs. 'provide/contract21 '(begin (eval '(module provide/contract21a mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (provide/contract [f integer?]) (define f 1))) (eval '(module provide/contract21b mzscheme @@ -4974,7 +4974,7 @@ so that propagation occurs. 'provide/contract22 '(begin (eval '(module provide/contract22a mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (provide/contract [make-bound-identifier-mapping integer?]) (define make-bound-identifier-mapping 1))) (eval '(module provide/contract22b mzscheme @@ -4990,7 +4990,7 @@ so that propagation occurs. 'provide/contract23 '(begin (eval '(module provide/contract23a mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (provide/contract [f integer?]) (define f 3))) @@ -5005,7 +5005,7 @@ so that propagation occurs. 'provide/contract24 '(begin (eval '(module provide/contract24 mzscheme - (require (prefix c: (lib "contract.ss"))) + (require (prefix c: scheme/contract)) (c:case-> (c:-> integer? integer?) (c:-> integer? integer? integer?)))))) @@ -5015,7 +5015,7 @@ so that propagation occurs. 'provide/contract25 '(begin (eval '(module provide/contract25a mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (provide/contract [seventeen integer?]) (define seventeen 17))) (eval '(module provide/contract25b mzscheme @@ -5039,7 +5039,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce1-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define the-defined-variable1 'five) (provide/contract [the-defined-variable1 number?]))) (eval '(require 'pce1-bug))) @@ -5050,7 +5050,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce2-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define the-defined-variable2 values) (provide/contract [the-defined-variable2 (-> number? any)]))) (eval '(require 'pce2-bug)) @@ -5062,7 +5062,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce3-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define the-defined-variable3 (λ (x) #f)) (provide/contract [the-defined-variable3 (-> any/c number?)]))) (eval '(require 'pce3-bug)) @@ -5074,7 +5074,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce4-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define the-defined-variable4 (λ (x) #f)) (provide/contract [the-defined-variable4 (-> any/c number?)]))) (eval '(require 'pce4-bug)) @@ -5086,7 +5086,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce5-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct bad (a b)) @@ -5100,7 +5100,7 @@ so that propagation occurs. (contract-error-test #'(begin (eval '(module pce6-bug mzscheme - (require (lib "contract.ss")) + (require scheme/contract) (define-struct bad-parent (a)) (define-struct (bad bad-parent) (b))