From 96bcbb0713b05d78be6021f962a9ce262610e4e6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 29 Dec 2007 12:30:25 +0000 Subject: [PATCH] scheme/mpair svn: r8151 original commit: 92ac61e806c4d2b99a9da695a2409d6b61cd3ac4 --- collects/scheme/mpair.ss | 153 ++++++ collects/scheme/private/contract-arrow.ss | 609 --------------------- collects/scheme/private/contract-object.ss | 443 --------------- 3 files changed, 153 insertions(+), 1052 deletions(-) create mode 100644 collects/scheme/mpair.ss delete mode 100644 collects/scheme/private/contract-arrow.ss delete mode 100644 collects/scheme/private/contract-object.ss diff --git a/collects/scheme/mpair.ss b/collects/scheme/mpair.ss new file mode 100644 index 0000000..f6b6e3c --- /dev/null +++ b/collects/scheme/mpair.ss @@ -0,0 +1,153 @@ +#lang scheme/base + +(provide mmap + mfor-each + mlist + mlist? + mlength + mappend + mreverse + mlist-tail + mlist-ref + mmemq + mmemv + mmember + massq + massv + massoc + mlist->list + list->mlist + mlistof) + +(define mmap + (case-lambda + [(f l) (let loop ([l l]) + (cond + [(null? l) null] + [else (mcons (f (mcar l)) (loop (mcdr l)))]))] + [(f l1 l2) (let loop ([l1 l1][l2 l2]) + (cond + [(null? l1) null] + [else (mcons (f (mcar l1) (mcar l2)) + (loop (mcdr l1) (mcdr l2)))]))] + [(f l . ls) (let loop ([l l][ls ls]) + (cond + [(null? l) null] + [else (mcons (apply f (mcar l) (map mcar ls)) + (loop (mcdr l) (map mcdr ls)))]))])) + +(define mfor-each + (case-lambda + [(f l) (let loop ([l l]) + (cond + [(null? l) (void)] + [else (f (mcar l)) + (loop (mcdr l))]))] + [(f l1 l2) (let loop ([l1 l1][l2 l2]) + (cond + [(null? l1) (void)] + [else (f (mcar l1) (mcar l2)) + (loop (mcdr l1) (mcdr l2))]))] + [(f l . ls) (let loop ([l l][ls ls]) + (cond + [(null? l) (void)] + [else (apply f (mcar l) (map mcar ls)) + (loop (mcdr l) (map mcdr ls))]))])) + +(define (list->mlist l) + (cond + [(null? l) null] + [else (mcons (car l) (list->mlist (cdr l)))])) + +(define (mlist->list l) + (cond + [(null? l) null] + [else (cons (mcar l) (mlist->list (mcdr l)))])) + +(define mlist + (case-lambda + [() null] + [(a) (mcons a null)] + [(a b) (mcons a (mcons b null))] + [(a b c) (mcons a (mcons b (mcons c null)))] + [(a b c d) (mcons a (mcons b (mcons c (mcons d null))))] + [l (list->mlist l)])) + +(define (mlist? l) + (cond + [(null? l) #t] + [(mpair? l) (mlist? (mcdr l))] + [else #f])) + +(define (mlength l) + (let loop ([l l][len 0]) + (cond + [(null? l) len] + [else (loop (mcdr l) (add1 len))]))) + +(define mappend + (case-lambda + [() null] + [(a) a] + [(a b) (let loop ([a a]) + (if (null? a) + b + (mcons (mcar a) (loop (mcdr a)))))] + [(a . l) (mappend a (apply mappend l))])) + +(define (mreverse l) + (let loop ([l l][a null]) + (cond + [(null? l) a] + [else (loop (mcdr l) (mcons (mcar l) a))]))) + +(define (mlist-tail l n) + (cond + [(zero? n) l] + [else (mlist-tail (mcdr l) (sub1 n))])) + +(define (mlist-ref l n) + (cond + [(zero? n) (mcar l)] + [else (mlist-ref (mcdr l) (sub1 n))])) + +(define (do-member =? v l) + (let loop ([l l]) + (cond + [(null? l) #f] + [(=? v (mcar l)) l] + [else (loop (mcdr l))]))) + +(define (mmemq v l) + (do-member eq? v l)) + +(define (mmemv v l) + (do-member eqv? v l)) + +(define (mmember v l) + (do-member equal? v l)) + + +(define (do-assoc =? v l) + (let loop ([l l]) + (cond + [(null? l) #f] + [(=? v (mcar (mcar l))) (mcar l)] + [else (loop (mcdr l))]))) + +(define (massq v l) + (do-assoc eq? v l)) + +(define (massv v l) + (do-assoc eqv? v l)) + +(define (massoc v l) + (do-assoc equal? v l)) + +(define ((mlistof p?) l) + (let loop ([l l]) + (cond + [(null? l) #t] + [(not (mpair? l)) #f] + [(p? (mcar l)) (loop (mcdr l))] + [else #f]))) diff --git a/collects/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss deleted file mode 100644 index fb60c36..0000000 --- a/collects/scheme/private/contract-arrow.ss +++ /dev/null @@ -1,609 +0,0 @@ -#lang scheme/base - -#| - -v4 done: - -- added mandatory keywords to -> -- rewrote ->* using new notation - -v4 todo: - -- rewrite ->d - -- remove opt-> opt->* ->pp ->pp-rest ->r ->d* - -- raise-syntax-errors - . multiple identical keywords syntax error, sort-keywords - . split-doms - -|# - -(require "contract-guts.ss" - "contract-arr-checks.ss" - "contract-opt.ss") -(require (for-syntax scheme/base) - (for-syntax "contract-opt-guts.ss") - (for-syntax "contract-helpers.ss") - (for-syntax "contract-arr-obj-helpers.ss") - (for-syntax syntax/stx) - (for-syntax syntax/name)) - -(provide -> - ->d - ->* - ->d* - ->r - ->pp - ->pp-rest - case-> - opt-> - opt->* - unconstrained-domain->) - -(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?))))])) - -(define (build--> name - doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f - mandatory-kwds/c-or-p mandatory-kwds optional-kwds/c-or-p optional-kwds - rngs/c-or-p - rng-any? func) - (let ([cc (λ (c-or-p) (coerce-contract name c-or-p))]) - (make--> - (map cc doms/c-or-p) (map cc optional-doms/c-or-p) (and doms-rest/c-or-p-or-f (cc doms-rest/c-or-p-or-f)) - (map cc mandatory-kwds/c-or-p) mandatory-kwds (map cc optional-kwds/c-or-p) optional-kwds - (map cc rngs/c-or-p) rng-any? - func))) - -;; doms : (listof contract) -;; optional-doms/c : (listof contract) -;; dom-rest : (or/c false/c contract) -;; mandatory-kwds/c : (listof contract) -;; mandatory-kwds : (listof keyword) -- must be sorted by keyword< -;; optional-kwds/c : (listof contract) -;; optional-kwds : (listof keyword) -- must be sorted by keyword< -;; rngs : (listof contract) -- may be ignored by the wrapper function in the case of any -;; rng-any? : boolean -;; func : the wrapper function maker. It accepts a procedure for -;; checking the first-order properties and the contracts -;; and it produces a wrapper-making function. -(define-struct/prop -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func) - ((proj-prop (λ (ctc) - (let* ([doms-proj (map (λ (x) ((proj-get x) x)) - (if (->-dom-rest/c ctc) - (append (->-doms/c ctc) (list (->-dom-rest/c ctc))) - (->-doms/c ctc)))] - [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))] - [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))] - [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))] - [optional-kwds-proj (map (λ (x) ((proj-get x) x)) (->-optional-kwds/c ctc))] - [mandatory-keywords (->-mandatory-kwds ctc)] - [optional-keywords (->-optional-kwds ctc)] - [func (->-func ctc)] - [dom-length (length (->-doms/c ctc))] - [optionals-length (length (->-optional-doms/c ctc))] - [has-rest? (and (->-dom-rest/c ctc) #t)]) - (λ (pos-blame neg-blame src-info orig-str) - (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) - doms-proj)] - [partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) - doms-optional-proj)] - [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str)) - rngs-proj)] - [partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) - mandatory-kwds-proj)] - [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) - optional-kwds-proj)]) - (apply func - (λ (val) (if has-rest? - (check-procedure/more val dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str) - (check-procedure val dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str))) - (append partial-doms partial-optional-doms - partial-mandatory-kwds partial-optional-kwds - partial-ranges))))))) - (name-prop (λ (ctc) (single-arrow-name-maker - (->-doms/c ctc) - (->-optional-doms/c ctc) - (->-dom-rest/c ctc) - (->-mandatory-kwds/c ctc) - (->-mandatory-kwds ctc) - (->-optional-kwds/c ctc) - (->-optional-kwds ctc) - (->-rng-any? ctc) - (->-rngs/c ctc)))) - (first-order-prop - (λ (ctc) - (λ (x) - (let ([l (length (->-doms/c ctc))]) - (and (procedure? x) - (if (->-dom-rest/c ctc) - (procedure-accepts-and-more? x l) - (procedure-arity-includes? x l)) - (let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)]) - (and (equal? x-mandatory-keywords (->-mandatory-kwds ctc)) - (andmap (λ (optional-keyword) (member optional-keyword x-all-keywords)) - (->-mandatory-kwds ctc)))) - #t))))) - (stronger-prop - (λ (this that) - (and (->? that) - (= (length (->-doms/c that)) (length (->-doms/c this))) - (andmap contract-stronger? (->-doms/c that) (->-doms/c this)) - - (equal? (->-mandatory-kwds this) (->-mandatory-kwds that)) - (andmap contract-stronger? (->-mandatory-kwds/c that) (->-mandatory-kwds/c this)) - - (equal? (->-optional-kwds this) (->-optional-kwds that)) - (andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this)) - - (= (length (->-rngs/c that)) (length (->-rngs/c this))) - (andmap contract-stronger? (->-rngs/c this) (->-rngs/c that))))))) - -(define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs) - (cond - [(or doms-rest - (not (null? optional-kwds)) - (not (null? optional-doms/c))) - (let ([range - (cond - [rng-any? 'any] - [else (apply build-compound-type-name rngs)])]) - (apply - build-compound-type-name - '->* - (apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c)))) - (apply build-compound-type-name (append optional-doms/c (apply append (map list optional-kwds optional-kwds/c)))) - (if doms-rest - (list doms-rest range) - (list range))))] - [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 - (apply append (map list kwds kwds/c)) - (list rng-name))))])) - -;; sort-keywords : syntax (listof syntax[(kwd . whatever)] -> (listof syntax[(kwd . whatever)]) -;; sorts a list of syntax according to the keywords in the list -(define-for-syntax (sort-keywords stx kwd/ctc-pairs) - (define (insert x lst) - (cond - [(null? lst) (list x)] - [else - (let ([fst-kwd (syntax-e (car (syntax-e (car lst))))] - [x-kwd (syntax-e (car (syntax-e x)))]) - (cond - [(equal? x-kwd fst-kwd) - (raise-syntax-error #f - "duplicate keyword" - stx - (car x))] - [(keyword-helper stx) - (syntax-case stx () - [(-> raw-doms ... last-one) - (with-syntax ([((doms ...) ((dom-kwd dom-kwd-ctc) ...)) (split-doms stx '-> #'(raw-doms ...))]) - (with-syntax ([(dom-kwd-arg ...) (generate-temporaries (syntax (dom-kwd ...)))] - [(dom-kwd-ctc-id ...) (generate-temporaries (syntax (dom-kwd ...)))]) - (with-syntax ([(keyword-call/ctc ...) (apply append (map syntax->list (syntax->list #'((dom-kwd (dom-kwd-ctc-id dom-kwd-arg)) ...))))] - [(keyword-formal-parameters ...) (apply append (map syntax->list (syntax->list #'((dom-kwd dom-kwd-arg) ...))))] - [(args ...) (generate-temporaries (syntax (doms ...)))] - [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]) - (syntax-case* #'last-one (-> any values) module-or-top-identifier=? - [any - (with-syntax ([(ignored) (generate-temporaries (syntax (rng)))]) - (values (syntax (dom-ctc ...)) - (syntax (ignored)) - (syntax (dom-kwd-ctc-id ...)) - (syntax (doms ...)) - (syntax (any/c)) - (syntax (dom-kwd-ctc ...)) - (syntax (dom-kwd ...)) - (syntax ((args ... keyword-formal-parameters ...) (val (dom-ctc args) ... keyword-call/ctc ...))) - #t))] - [(values rngs ...) - (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))] - [(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))]) - (values (syntax (dom-ctc ...)) - (syntax (rng-ctc ...)) - (syntax (dom-kwd-ctc-id ...)) - (syntax (doms ...)) - (syntax (rngs ...)) - (syntax (dom-kwd-ctc ...)) - (syntax (dom-kwd ...)) - (syntax ((args ... keyword-formal-parameters ...) - (let-values ([(rng-x ...) (val (dom-ctc args) ... keyword-call/ctc ...)]) - (values (rng-ctc rng-x) ...)))) - #f))] - [rng - (with-syntax ([(rng-ctc) (generate-temporaries (syntax (rng)))]) - (values (syntax (dom-ctc ...)) - (syntax (rng-ctc)) - (syntax (dom-kwd-ctc-id ...)) - (syntax (doms ...)) - (syntax (rng)) - (syntax (dom-kwd-ctc ...)) - (syntax (dom-kwd ...)) - (syntax ((args ... keyword-formal-parameters ...) (rng-ctc (val (dom-ctc args) ... keyword-call/ctc ...)))) - #f))]))))])) - -;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) -(define-for-syntax (->/proc/main stx) - (let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)]) - (with-syntax ([(args body) inner-args/body]) - (with-syntax ([(dom-names ...) dom-names] - [(rng-names ...) rng-names] - [(kwd-names ...) kwd-names] - [(dom-ctcs ...) dom-ctcs] - [(rng-ctcs ...) rng-ctcs] - [(kwd-ctcs ...) kwd-ctcs] - [(kwds ...) kwds] - [inner-lambda - (add-name-prop - (syntax-local-infer-name stx) - (syntax (lambda args body)))] - [use-any? use-any?]) - (with-syntax ([outer-lambda - (syntax - (lambda (chk dom-names ... kwd-names ... rng-names ...) - (lambda (val) - (chk val) - inner-lambda)))]) - (values - (syntax - (build--> '-> - (list dom-ctcs ...) '() #f - (list kwd-ctcs ...) '(kwds ...) '() '() - (list rng-ctcs ...) use-any? - outer-lambda)) - inner-args/body - (syntax (dom-names ... rng-names ...)))))))) - -(define-syntax (-> stx) - (let-values ([(stx _1 _2) (->/proc/main stx)]) - stx)) - -(define unspecified-dom (gensym 'unspecified-keyword)) - -;; check-duplicate-kwds : syntax (listof syntax[keyword]) -> void -(define-for-syntax (check-duplicate-kwds stx kwds) - (let loop ([kwds kwds]) - (unless (null? kwds) - (when (member (syntax-e (car kwds)) (map syntax-e (cdr kwds))) - (raise-syntax-error #f "duplicate keyword" stx (car kwds)))))) - -;; ->*/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) -(define-for-syntax (->*/proc/main stx) - (syntax-case* stx (->* any) module-or-top-identifier=? - [(->* (raw-mandatory-dom ...) (raw-optional-dom ...) . rst) - (with-syntax ([((mandatory-dom ...) ((mandatory-dom-kwd mandatory-dom-kwd-ctc) ...)) - (split-doms stx '->* #'(raw-mandatory-dom ...))] - [((optional-dom ...) ((optional-dom-kwd optional-dom-kwd-ctc) ...)) - (split-doms stx '->* #'(raw-optional-dom ...))]) - ;(check-duplicate-kwds stx (syntax->list #'(mandatory-dom-kwd ... optional-dom-kwd ...))) - (with-syntax ([(mandatory-dom-proj ...) (generate-temporaries #'(mandatory-dom ...))] - [(mandatory-dom-arg ...) (generate-temporaries #'(mandatory-dom ...))] - [(mandatory-dom-kwd-proj ...) (generate-temporaries #'(mandatory-dom-kwd ...))] - [(mandatory-dom-kwd-arg ...) (generate-temporaries #'(mandatory-dom-kwd ...))] - - [(optional-dom-proj ...) (generate-temporaries #'(optional-dom ...))] - [(optional-dom-arg ...) (generate-temporaries #'(optional-dom ...))] - [(optional-dom-kwd-proj ...) (generate-temporaries #'(optional-dom-kwd ...))] - [(optional-dom-kwd-arg ...) (generate-temporaries #'(optional-dom-kwd ...))]) - (with-syntax ([(mandatory-dom-kwd/var-seq ...) (apply append - (map list - (syntax->list #'(mandatory-dom-kwd ...)) - (syntax->list #'(mandatory-dom-kwd-arg ...))))] - [(optional-dom-kwd/var-seq ...) (apply append - (map list - (syntax->list #'(optional-dom-kwd ...)) - (syntax->list #'([optional-dom-kwd-arg unspecified-dom] ...))))] - [(mandatory-dom-kwd-proj-apps ...) (apply append - (map list - (syntax->list #'(mandatory-dom-kwd ...)) - (syntax->list #'((mandatory-dom-kwd-proj mandatory-dom-kwd-arg) ...))))] - [((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...) - (sort-keywords stx (syntax->list - #'((mandatory-dom-kwd mandatory-dom-kwd-arg mandatory-dom-kwd-proj) ... - (optional-dom-kwd optional-dom-kwd-arg optional-dom-kwd-proj) ...)))]) - (with-syntax ([((rev-sorted-dom-kwd rev-sorted-dom-kwd-arg rev-sorted-dom-kwd-proj) ...) - (reverse (syntax->list #'((sorted-dom-kwd sorted-dom-kwd-arg sorted-dom-kwd-proj) ...)))] - [(rev-optional-dom-arg ...) (reverse (syntax->list #'(optional-dom-arg ...)))] - [(rev-optional-dom-proj ...) (reverse (syntax->list #'(optional-dom-proj ...)))]) - - - (let-values ([(rest-ctc rng-ctc) - ;; rest-ctc (or/c #f syntax) -- #f means no rest contract, syntax is the contract - ;; rng-ctc (or/c #f syntax) -- #f means `any', syntax is a sequence of result values - (syntax-case #'rst (any) - [(any) (values #f #f)] - [(rest-expr any) (values #'rest-expr #f)] - [((res-ctc ...)) (values #f #'(res-ctc ...))] - [(rest-expr (res-ctc ...)) (values #'rest-expr #'(res-ctc ...))] - [_ (raise-syntax-error #f "bad syntax" stx)])]) - (with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))] - [(rng ...) (generate-temporaries (or rng-ctc '()))]) - #`(build--> - '->* - (list mandatory-dom ...) - (list optional-dom ...) - #,rest-ctc - (list mandatory-dom-kwd-ctc ...) - '(mandatory-dom-kwd ...) - (list optional-dom-kwd-ctc ...) - '(optional-dom-kwd ...) - #,(if rng-ctc - (with-syntax ([(rng-ctc ...) rng-ctc]) - #'(list rng-ctc ...)) - #''()) - #,(if rng-ctc #f #t) - (λ (chk mandatory-dom-proj ... - #,@(if rest-ctc - #'(rest-proj) - #'()) - optional-dom-proj ... - mandatory-dom-kwd-proj ... - optional-dom-kwd-proj ... - rng-proj ...) - (λ (f) - (chk f) - #,(add-name-prop - (syntax-local-infer-name stx) - #`(λ (mandatory-dom-arg ... - [optional-dom-arg unspecified-dom] ... - mandatory-dom-kwd/var-seq ... - optional-dom-kwd/var-seq ... - #,@(if rest-ctc #'rest #'())) - (let*-values ([(kwds kwd-args) (values '() '())] - [(kwds kwd-args) (if (eq? unspecified-dom rev-sorted-dom-kwd-arg) - (values kwds kwd-args) - (values (cons 'rev-sorted-dom-kwd kwds) - (cons (rev-sorted-dom-kwd-proj rev-sorted-dom-kwd-arg) - kwd-args)))] - ... - [(opt-args) #,(if rest-ctc - #'(rest-proj rest) - #''())] - [(opt-args) (if (eq? unspecified-dom rev-optional-dom-arg) - opt-args - (cons (rev-optional-dom-proj rev-optional-dom-arg) opt-args))] - ...) - #,(let ([call #'(keyword-apply f kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args)]) - (if rng-ctc - #`(let-values ([(rng ...) #,call]) - (values (rng-proj rng) ...)) - call))))))))))))))])) - -(define-syntax (->* stx) (->*/proc/main stx)) - -(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 0 '() '() #| keywords |# 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 0 '() '() #|keywords|# 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 ...)) - (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...))) - (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword - (opt/arrow-ctc (syntax->list (syntax (dom ...))) - (syntax->list (syntax (rng ...)))))] - [(-> dom ... any) - (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...))) - (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword - (opt/arrow-any-ctc (syntax->list (syntax (dom ...)))))] - [(-> dom ... rng) - (if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...))) - (opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword - (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 deleted file mode 100644 index a8aa076..0000000 --- a/collects/scheme/private/contract-object.ss +++ /dev/null @@ -1,443 +0,0 @@ -#lang scheme/base -(require "contract-arrow.ss" - "contract-guts.ss" - "class-internal.ss" - "contract-arr-checks.ss") - -(require (for-syntax scheme/base - "contract-helpers.ss" - "contract-arr-obj-helpers.ss")) - -(provide mixin-contract - make-mixin-contract - is-a?/c - subclass?/c - implementation?/c - object-contract) - -(define-syntax object-contract - (let () - (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-> #'->)) - - (λ (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 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 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 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 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) - - (define (last-pair l) - (cond - [(not (pair? (cdr l))) l] - [else (last-pair (cdr l))])) - - (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->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))