finished the new ->*
svn: r8086 original commit: 342eb86c102a25d6573919437322b1d393cffafc
This commit is contained in:
Robby Findler
parent
cc5373a844
commit
351e6806e7
|
|
@ -1,10 +1,79 @@
|
|||
#lang scheme/base
|
||||
(require scheme/contract)
|
||||
(provide (all-from-out scheme/contract))
|
||||
|
||||
;; provide contracts for objects
|
||||
(require scheme/private/contract-object)
|
||||
(provide (all-from-out scheme/private/contract-object))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; provide arrow contracts from our local copy
|
||||
;;
|
||||
|
||||
(require "private/contract-arrow.ss")
|
||||
(provide (all-from-out "private/contract-arrow.ss"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; provide contracts for objects
|
||||
;;
|
||||
(require "private/contract-object.ss")
|
||||
(provide (all-from-out "private/contract-object.ss"))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; provide everything from the scheme/ implementation
|
||||
;; except the arrow contracts
|
||||
;;
|
||||
|
||||
(require scheme/private/contract
|
||||
scheme/private/contract-guts
|
||||
scheme/private/contract-ds
|
||||
scheme/private/contract-opt-guts
|
||||
scheme/private/contract-opt
|
||||
scheme/private/contract-basic-opters)
|
||||
|
||||
(provide
|
||||
opt/c define-opt/c ;(all-from "private/contract-opt.ss")
|
||||
(except-out (all-from-out scheme/private/contract-ds)
|
||||
lazy-depth-to-look)
|
||||
|
||||
(except-out (all-from-out scheme/private/contract)
|
||||
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)
|
||||
|
|
|
|||
535
collects/mzlib/private/contract-arrow.ss
Normal file
535
collects/mzlib/private/contract-arrow.ss
Normal file
|
|
@ -0,0 +1,535 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/private/contract-guts
|
||||
scheme/private/contract-arr-checks
|
||||
scheme/private/contract-opt)
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax scheme/private/contract-opt-guts)
|
||||
(for-syntax scheme/private/contract-helpers)
|
||||
(for-syntax scheme/private/contract-arr-obj-helpers)
|
||||
(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 doms-rest rngs kwds quoted-kwds rng-any? func)
|
||||
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
|
||||
[rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
|
||||
[kwds/c (map (λ (kwd) (coerce-contract name kwd)) kwds)]
|
||||
[doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
|
||||
(make--> rng-any? doms/c doms-rest/c rngs/c kwds/c quoted-kwds func)))
|
||||
;; rng-any? : boolean
|
||||
;; doms : (listof contract)
|
||||
;; dom-rest : (or/c false/c contract)
|
||||
;; rngs : (listof contract) -- may be ignored by the wrapper function in the case of any
|
||||
;; kwds : (listof contract)
|
||||
;; quoted-keywords : (listof keyword) -- must be sorted by keyword<
|
||||
;; 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 -> (rng-any? doms dom-rest rngs kwds quoted-kwds 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))]
|
||||
[kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
|
||||
[mandatory-keywords (->-quoted-kwds ctc)]
|
||||
[func (->-func ctc)]
|
||||
[dom-length (length (->-doms ctc))]
|
||||
[has-rest? (and (->-dom-rest ctc) #t)])
|
||||
(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)]
|
||||
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
kwds/c)])
|
||||
(apply func
|
||||
(λ (val)
|
||||
(if has-rest?
|
||||
(check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str)
|
||||
(check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str)))
|
||||
(append partial-doms partial-ranges partial-kwds)))))))
|
||||
(name-prop (λ (ctc) (single-arrow-name-maker
|
||||
(->-doms ctc)
|
||||
(->-dom-rest ctc)
|
||||
(->-kwds ctc)
|
||||
(->-quoted-kwds 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)
|
||||
(no-mandatory-keywords? x)))))))
|
||||
(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 kwds/c kwds rng-any? rngs)
|
||||
(cond
|
||||
[doms-rest
|
||||
(build-compound-type-name
|
||||
'->*
|
||||
(apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/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
|
||||
(apply append (map list kwds kwds/c))
|
||||
(list rng-name))))]))
|
||||
|
||||
(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 (car lst)))])
|
||||
(printf "comparing ~s to ~s\n" (car x) fst-kwd)
|
||||
(cond
|
||||
[(equal? (syntax-e (car x)) fst-kwd)
|
||||
(raise-syntax-error #f
|
||||
"duplicate keyword"
|
||||
stx
|
||||
(car x))]
|
||||
[(keyword<? (syntax-e (car x)) fst-kwd)
|
||||
(cons x lst)]
|
||||
[else (cons (car lst) (insert x (cdr lst)))]))]))
|
||||
|
||||
(let loop ([pairs (map syntax->list kwd/ctc-pairs)])
|
||||
(cond
|
||||
[(null? pairs) null]
|
||||
[else (insert (car pairs) (loop (cdr pairs)))])))
|
||||
|
||||
(define-for-syntax (split-doms stx name raw-doms)
|
||||
(let loop ([raw-doms raw-doms]
|
||||
[doms '()]
|
||||
[kwd-doms '()])
|
||||
(syntax-case raw-doms ()
|
||||
[() (list (reverse doms)
|
||||
(sort-keywords stx kwd-doms))]
|
||||
[(kwd arg . rest)
|
||||
(and (keyword? (syntax-e #'kwd))
|
||||
(not (keyword? (syntax-e #'arg))))
|
||||
(loop #'rest
|
||||
doms
|
||||
(cons #'(kwd arg) kwd-doms))]
|
||||
[(kwd arg . rest)
|
||||
(and (keyword? (syntax-e #'kwd))
|
||||
(keyword? (syntax-e #'arg)))
|
||||
(raise-syntax-error name
|
||||
"expected a keyword followed by a contract"
|
||||
stx
|
||||
#'kwd)]
|
||||
[(kwd)
|
||||
(keyword? (syntax-e #'kwd))
|
||||
(raise-syntax-error name
|
||||
"expected a keyword to be followed by a contract"
|
||||
stx
|
||||
#'kwd)]
|
||||
[(x . rest)
|
||||
(loop #'rest (cons #'x doms) kwd-doms)])))
|
||||
|
||||
(define-for-syntax (->-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 ... rng-names ... kwd-names ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values
|
||||
(syntax (build--> '->
|
||||
(list dom-ctcs ...)
|
||||
#f
|
||||
(list rng-ctcs ...)
|
||||
(list kwd-ctcs ...)
|
||||
'(kwds ...)
|
||||
use-any?
|
||||
outer-lambda))
|
||||
inner-args/body
|
||||
(syntax (dom-names ... rng-names ...))))))))
|
||||
|
||||
(define-syntax (-> stx)
|
||||
(let-values ([(stx _1 _2) (->/proc/main stx)])
|
||||
stx))
|
||||
|
||||
;; ->/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=?
|
||||
[(->* (doms ...) any)
|
||||
(->/proc/main (syntax (-> doms ... any)))]
|
||||
[(->* (doms ...) (rngs ...))
|
||||
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
|
||||
[(->* (raw-doms ...) rst rng)
|
||||
(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-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 ...)))])
|
||||
(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)))])
|
||||
(syntax-case #'rng (any)
|
||||
[(rngs ...)
|
||||
(with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
|
||||
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
|
||||
|
||||
(let ([inner-args/body
|
||||
#`((args ... keyword-formal-parameters ... . rest-arg)
|
||||
(let-values ([(rng-args ...)
|
||||
#,(if (null? (syntax-e #'(dom-kwd ...)))
|
||||
#'(apply val (dom-x args) ... (rst-x rest-arg))
|
||||
#'(keyword-apply val
|
||||
'(dom-kwd ...)
|
||||
(list (dom-kwd-ctc-id dom-kwd-arg) ...)
|
||||
(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 ... dom-kwd-ctc-id ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
(list rngs ...)
|
||||
(list dom-kwd-ctc ...)
|
||||
'(dom-kwd ...)
|
||||
#f
|
||||
outer-lambda))
|
||||
inner-args/body
|
||||
(syntax (dom-x ... rst-x rng-x ...)))))))]
|
||||
[any
|
||||
(let ([inner-args/body
|
||||
#`((args ... keyword-formal-parameters ... . rest-arg)
|
||||
#,(if (null? (syntax-e #'(dom-kwd ...)))
|
||||
#'(apply val (dom-x args) ... (rst-x rest-arg))
|
||||
#'(keyword-apply val
|
||||
'(dom-kwd ...)
|
||||
(list (dom-kwd-ctc-id dom-kwd-arg) ...)
|
||||
(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 dom-kwd-ctc-id ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
(list any/c)
|
||||
(list dom-kwd-ctc ...)
|
||||
'(dom-kwd ...)
|
||||
#t
|
||||
outer-lambda))
|
||||
inner-args/body
|
||||
(syntax (dom-x ... rst-x))))))])))))]))
|
||||
|
||||
(define-syntax (->* stx)
|
||||
(let-values ([(stx _1 _2) (->*/proc/main stx)])
|
||||
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)))]))
|
||||
443
collects/mzlib/private/contract-object.ss
Normal file
443
collects/mzlib/private/contract-object.ss
Normal file
|
|
@ -0,0 +1,443 @@
|
|||
#lang scheme/base
|
||||
(require "contract-arrow.ss"
|
||||
scheme/private/contract-guts
|
||||
scheme/private/class-internal
|
||||
scheme/private/contract-arr-checks)
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/private/contract-helpers
|
||||
scheme/private/contract-arr-obj-helpers))
|
||||
|
||||
(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 <class>, 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 <interface>, 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 <interface> or <class>, 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))
|
||||
|
|
@ -93,10 +93,10 @@
|
|||
orig-str
|
||||
"post-condition expression failure")))
|
||||
|
||||
(define (check-procedure val dom-length mandatory-kwds src-info blame orig-str)
|
||||
(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str)
|
||||
(unless (and (procedure? val)
|
||||
(procedure-arity-includes? val dom-length)
|
||||
(equal? mandatory-kwds (get-mandatory-keywords val)))
|
||||
(procedure-arity-includes?/optionals val dom-length optionals)
|
||||
(keywords-match mandatory-kwds optional-keywords val))
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
|
|
@ -107,6 +107,19 @@
|
|||
(keyword-error-text mandatory-kwds)
|
||||
val)))
|
||||
|
||||
(define (procedure-arity-includes?/optionals f base optionals)
|
||||
(cond
|
||||
[(zero? optionals) (procedure-arity-includes? f base)]
|
||||
[else (and (procedure-arity-includes? f (+ base optionals))
|
||||
(procedure-arity-includes?/optionals f base (- optionals 1)))]))
|
||||
|
||||
(define (keywords-match mandatory-kwds optional-kwds val)
|
||||
(let-values ([(proc-mandatory proc-all) (procedure-keywords val)])
|
||||
(and (equal? proc-mandatory mandatory-kwds)
|
||||
(andmap (λ (kwd) (and (member kwd proc-all)
|
||||
(not (member kwd proc-mandatory))))
|
||||
optional-kwds))))
|
||||
|
||||
(define (keyword-error-text mandatory-keywords)
|
||||
(cond
|
||||
[(null? mandatory-keywords) " without any keywords"]
|
||||
|
|
@ -165,10 +178,10 @@
|
|||
(procedure-arity val)
|
||||
val)))
|
||||
|
||||
(define (check-procedure/more val dom-length mandatory-kwds src-info blame orig-str)
|
||||
(define (check-procedure/more val dom-length mandatory-kwds optional-kwds src-info blame orig-str)
|
||||
(unless (and (procedure? val)
|
||||
(procedure-accepts-and-more? val dom-length)
|
||||
(equal? mandatory-kwds (get-mandatory-keywords val)))
|
||||
(keywords-match mandatory-kwds optional-kwds val))
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
|
|
|
|||
|
|
@ -382,7 +382,7 @@
|
|||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(syntax
|
||||
(check-procedure val dom-length '() #|mandatory-keywords|# src-info pos-blame orig-str))))
|
||||
(check-procedure val dom-length 0 '() '() #|keywords|# 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])
|
||||
|
|
@ -428,7 +428,7 @@
|
|||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(syntax
|
||||
(check-procedure val dom-length '() #|mandatory-keywords|# src-info pos-blame orig-str))))
|
||||
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(syntax (check-procedure? dom-length))
|
||||
|
||||
(lambda (outer-args)
|
||||
|
|
@ -472,7 +472,7 @@
|
|||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(syntax
|
||||
(check-procedure val dom-length '() #|mandatory keywords|# src-info pos-blame orig-str))))
|
||||
(check-procedure val dom-length 0 '() '() #|keywords|# 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])
|
||||
|
|
@ -548,7 +548,7 @@
|
|||
(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 '() #|mandatory keywords|# src-info pos-blame orig-str))))
|
||||
(check-procedure/more val dom-length '() '() #|keywords|# 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])
|
||||
|
|
@ -610,7 +610,7 @@
|
|||
(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 '() #|mandatory keywords|# src-info pos-blame orig-str))))
|
||||
(check-procedure/more val dom-length '() '() #|keywords|# 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])
|
||||
|
|
@ -663,7 +663,7 @@
|
|||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(syntax
|
||||
(check-procedure val arity '() #|mandatory keywords|# src-info pos-blame orig-str))))
|
||||
(check-procedure val arity 0 '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
|
||||
(syntax (check-procedure? arity))
|
||||
|
||||
|
|
@ -723,7 +723,7 @@
|
|||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(syntax
|
||||
(check-procedure val dom-length '() #|mandatory keywords|# src-info pos-blame orig-str))))
|
||||
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(syntax (check-procedure? dom-length))
|
||||
|
||||
(lambda (outer-args)
|
||||
|
|
@ -797,7 +797,7 @@
|
|||
(lambda (outer-args)
|
||||
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args])
|
||||
(syntax
|
||||
(check-procedure/more val arity '() #|mandatory keywords|# src-info pos-blame orig-str))))
|
||||
(check-procedure/more val arity '() '() #|keywords|# src-info pos-blame orig-str))))
|
||||
(syntax (check-procedure/more? arity))
|
||||
|
||||
(lambda (outer-args)
|
||||
|
|
|
|||
|
|
@ -2,16 +2,16 @@
|
|||
|
||||
#|
|
||||
|
||||
keywords done:
|
||||
v4 done:
|
||||
|
||||
- added mandatory keywords to ->, ->*
|
||||
- added mandatory keywords to ->
|
||||
- rewrote ->* using new notation
|
||||
|
||||
keywords todo:
|
||||
v4 todo:
|
||||
|
||||
add mandatory keywords to ->d ->d*
|
||||
- rewrite ->d
|
||||
|
||||
Add both optional and mandatory keywords to opt-> and friends.
|
||||
(Update opt-> so that it doesn't use case-lambda anymore.)
|
||||
- remove opt-> opt->* ->pp ->pp-rest ->r ->d*
|
||||
|
||||
- raise-syntax-errors
|
||||
. multiple identical keywords syntax error, sort-keywords
|
||||
|
|
@ -66,88 +66,119 @@ Add both optional and mandatory keywords to opt-> and friends.
|
|||
"expected a procedure")))))
|
||||
procedure?))))]))
|
||||
|
||||
(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
|
||||
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
|
||||
[rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
|
||||
[kwds/c (map (λ (kwd) (coerce-contract name kwd)) kwds)]
|
||||
[doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
|
||||
(make--> rng-any? doms/c doms-rest/c rngs/c kwds/c quoted-kwds func)))
|
||||
;; rng-any? : boolean
|
||||
(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
|
||||
;; kwds : (listof contract)
|
||||
;; quoted-keywords : (listof keyword) -- must be sorted by keyword<
|
||||
;; 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 -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
|
||||
(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/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))]
|
||||
[kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
|
||||
[mandatory-keywords (->-quoted-kwds 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 ctc))]
|
||||
[check-proc
|
||||
(if (->-dom-rest ctc)
|
||||
check-procedure/more
|
||||
check-procedure)])
|
||||
(lambda (pos-blame neg-blame src-info orig-str)
|
||||
[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/c)]
|
||||
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/c)]
|
||||
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
kwds/c)])
|
||||
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) (check-proc val dom-length mandatory-keywords src-info pos-blame orig-str))
|
||||
(append partial-doms partial-ranges partial-kwds)))))))
|
||||
(λ (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 ctc)
|
||||
(->-dom-rest ctc)
|
||||
(->-kwds ctc)
|
||||
(->-quoted-kwds ctc)
|
||||
(->-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 ctc))))
|
||||
(->-rngs/c 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)
|
||||
(no-mandatory-keywords? x)))))))
|
||||
(λ (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 that))
|
||||
(length (->-doms this)))
|
||||
(andmap contract-stronger?
|
||||
(->-doms that)
|
||||
(->-doms this))
|
||||
(= (length (->-rngs that))
|
||||
(length (->-rngs this)))
|
||||
(andmap contract-stronger?
|
||||
(->-rngs this)
|
||||
(->-rngs 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 doms-rest kwds/c kwds rng-any? rngs)
|
||||
(define (single-arrow-name-maker doms/c optional-doms/c doms-rest kwds/c kwds optional-kwds/c optional-kwds rng-any? rngs)
|
||||
(cond
|
||||
[doms-rest
|
||||
(build-compound-type-name
|
||||
'->*
|
||||
(apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c))))
|
||||
doms-rest
|
||||
(cond
|
||||
[rng-any? 'any]
|
||||
[else (apply build-compound-type-name rngs)]))]
|
||||
[(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
|
||||
|
|
@ -161,24 +192,26 @@ Add both optional and mandatory keywords to opt-> and friends.
|
|||
(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 (car lst)))])
|
||||
(printf "comparing ~s to ~s\n" (car x) fst-kwd)
|
||||
(let ([fst-kwd (syntax-e (car (syntax-e (car lst))))]
|
||||
[x-kwd (syntax-e (car (syntax-e x)))])
|
||||
(cond
|
||||
[(equal? (syntax-e (car x)) fst-kwd)
|
||||
[(equal? x-kwd fst-kwd)
|
||||
(raise-syntax-error #f
|
||||
"duplicate keyword"
|
||||
stx
|
||||
(car x))]
|
||||
[(keyword<? (syntax-e (car x)) fst-kwd)
|
||||
[(keyword<? x-kwd fst-kwd)
|
||||
(cons x lst)]
|
||||
[else (cons (car lst) (insert x (cdr lst)))]))]))
|
||||
|
||||
(let loop ([pairs (map syntax->list kwd/ctc-pairs)])
|
||||
(let loop ([pairs kwd/ctc-pairs])
|
||||
(cond
|
||||
[(null? pairs) null]
|
||||
[else (insert (car pairs) (loop (cdr pairs)))])))
|
||||
|
|
@ -278,19 +311,17 @@ Add both optional and mandatory keywords to opt-> and friends.
|
|||
[use-any? use-any?])
|
||||
(with-syntax ([outer-lambda
|
||||
(syntax
|
||||
(lambda (chk dom-names ... rng-names ... kwd-names ...)
|
||||
(lambda (chk dom-names ... kwd-names ... rng-names ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values
|
||||
(syntax (build--> '->
|
||||
(list dom-ctcs ...)
|
||||
#f
|
||||
(list rng-ctcs ...)
|
||||
(list kwd-ctcs ...)
|
||||
'(kwds ...)
|
||||
use-any?
|
||||
outer-lambda))
|
||||
(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 ...))))))))
|
||||
|
||||
|
|
@ -298,94 +329,118 @@ Add both optional and mandatory keywords to opt-> and friends.
|
|||
(let-values ([(stx _1 _2) (->/proc/main stx)])
|
||||
stx))
|
||||
|
||||
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
|
||||
(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=?
|
||||
[(->* (doms ...) any)
|
||||
(->/proc/main (syntax (-> doms ... any)))]
|
||||
[(->* (doms ...) (rngs ...))
|
||||
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
|
||||
[(->* (raw-doms ...) rst rng)
|
||||
(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-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 ...)))])
|
||||
(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)))])
|
||||
(syntax-case #'rng (any)
|
||||
[(rngs ...)
|
||||
(with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
|
||||
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
|
||||
|
||||
(let ([inner-args/body
|
||||
#`((args ... keyword-formal-parameters ... . rest-arg)
|
||||
(let-values ([(rng-args ...)
|
||||
#,(if (null? (syntax-e #'(dom-kwd ...)))
|
||||
#'(apply val (dom-x args) ... (rst-x rest-arg))
|
||||
#'(keyword-apply val
|
||||
'(dom-kwd ...)
|
||||
(list (dom-kwd-ctc-id dom-kwd-arg) ...)
|
||||
(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 ... dom-kwd-ctc-id ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
(list rngs ...)
|
||||
(list dom-kwd-ctc ...)
|
||||
'(dom-kwd ...)
|
||||
#f
|
||||
outer-lambda))
|
||||
inner-args/body
|
||||
(syntax (dom-x ... rst-x rng-x ...)))))))]
|
||||
[any
|
||||
(let ([inner-args/body
|
||||
#`((args ... keyword-formal-parameters ... . rest-arg)
|
||||
#,(if (null? (syntax-e #'(dom-kwd ...)))
|
||||
#'(apply val (dom-x args) ... (rst-x rest-arg))
|
||||
#'(keyword-apply val
|
||||
'(dom-kwd ...)
|
||||
(list (dom-kwd-ctc-id dom-kwd-arg) ...)
|
||||
(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 dom-kwd-ctc-id ...)
|
||||
(lambda (val)
|
||||
(chk val)
|
||||
inner-lambda)))])
|
||||
(values (syntax (build--> '->*
|
||||
(list doms ...)
|
||||
rst
|
||||
(list any/c)
|
||||
(list dom-kwd-ctc ...)
|
||||
'(dom-kwd ...)
|
||||
#t
|
||||
outer-lambda))
|
||||
inner-args/body
|
||||
(syntax (dom-x ... rst-x))))))])))))]))
|
||||
|
||||
(define-syntax (->* stx)
|
||||
(let-values ([(stx _1 _2) (->*/proc/main stx)])
|
||||
stx))
|
||||
[(->* (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)
|
||||
|
|
@ -479,7 +534,7 @@ Add both optional and mandatory keywords to opt-> and friends.
|
|||
(dom-len (length dom-vars))
|
||||
((next-rng ...) next-rngs))
|
||||
(syntax (begin
|
||||
(check-procedure val dom-len '() #| mandatory-keywords |# src-info pos orig-str)
|
||||
(check-procedure val dom-len 0 '() '() #| keywords |# src-info pos orig-str)
|
||||
(λ (dom-arg ...)
|
||||
(let-values ([(rng-arg ...) (val next-dom ...)])
|
||||
(values next-rng ...))))))
|
||||
|
|
@ -527,7 +582,7 @@ Add both optional and mandatory keywords to opt-> and friends.
|
|||
((next-dom ...) next-doms)
|
||||
(dom-len (length dom-vars)))
|
||||
(syntax (begin
|
||||
(check-procedure val dom-len '() #|mandatory-keywords|# src-info pos orig-str)
|
||||
(check-procedure val dom-len 0 '() '() #|keywords|# src-info pos orig-str)
|
||||
(λ (dom-arg ...)
|
||||
(val next-dom ...)))))
|
||||
lifts-doms
|
||||
|
|
|
|||
|
|
@ -13,12 +13,11 @@ of the contract library does not change over time.
|
|||
(let ()
|
||||
|
||||
(define contract-namespace
|
||||
(let ([n (make-base-namespace)])
|
||||
(let ([n ((dynamic-require 'mzscheme 'make-namespace))])
|
||||
(parameterize ([current-namespace n])
|
||||
(namespace-require '(for-syntax mzscheme))
|
||||
(namespace-require '(for-template mzscheme))
|
||||
(namespace-require 'mzlib/contract)
|
||||
(namespace-require 'mzlib/class)
|
||||
(namespace-require 'mzlib/etc)
|
||||
(namespace-require '(only mzscheme force delay)))
|
||||
n))
|
||||
|
||||
|
|
@ -79,12 +78,6 @@ of the contract library does not change over time.
|
|||
(define (test/spec-failed name expression blame)
|
||||
(let ()
|
||||
(define (has-proper-blame? msg)
|
||||
(printf ">> ~s\n"
|
||||
(cond
|
||||
[(regexp-match #rx"(^| )([^ ]*) broke" msg)
|
||||
=>
|
||||
(λ (x) (caddr x))]
|
||||
[else (format "no blame in error message: \"~a\"" msg)]))
|
||||
(equal?
|
||||
blame
|
||||
(cond
|
||||
|
|
@ -96,7 +89,7 @@ of the contract library does not change over time.
|
|||
(contract-eval
|
||||
`(,thunk-error-test
|
||||
(lambda () ,expression)
|
||||
(datum->syntax #'here ',expression)
|
||||
(datum->syntax-object #'here ',expression)
|
||||
(lambda (exn)
|
||||
(and (exn? exn)
|
||||
(,has-proper-blame? (exn-message exn))))))
|
||||
|
|
@ -105,7 +98,7 @@ of the contract library does not change over time.
|
|||
(contract-eval
|
||||
`(,thunk-error-test
|
||||
(lambda () ,rewritten)
|
||||
(datum->syntax #'here ',rewritten)
|
||||
(datum->syntax-object #'here ',rewritten)
|
||||
(lambda (exn)
|
||||
(and (exn? exn)
|
||||
(,has-proper-blame? (exn-message exn))))))))))
|
||||
|
|
@ -1969,7 +1962,7 @@ of the contract library does not change over time.
|
|||
'(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a])
|
||||
(opt-lambda (x [y 'a])
|
||||
x))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -1980,7 +1973,7 @@ of the contract library does not change over time.
|
|||
'(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x y [z #t])
|
||||
(opt-lambda (x y [z #t])
|
||||
x))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -1991,7 +1984,7 @@ of the contract library does not change over time.
|
|||
'(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a] [z #t])
|
||||
(opt-lambda (x [y 'a] [z #t])
|
||||
x))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -2002,7 +1995,7 @@ of the contract library does not change over time.
|
|||
'(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a] [z #t])
|
||||
(opt-lambda (x [y 'a] [z #t])
|
||||
x))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -2016,7 +2009,7 @@ of the contract library does not change over time.
|
|||
'(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a] [z #t])
|
||||
(opt-lambda (x [y 'a] [z #t])
|
||||
x))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -2031,7 +2024,7 @@ of the contract library does not change over time.
|
|||
'(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a] [z #t])
|
||||
(opt-lambda (x [y 'a] [z #t])
|
||||
x))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -2047,7 +2040,7 @@ of the contract library does not change over time.
|
|||
'(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a] [z #t])
|
||||
(opt-lambda (x [y 'a] [z #t])
|
||||
x))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -2060,7 +2053,7 @@ of the contract library does not change over time.
|
|||
'(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a] [z #t])
|
||||
(opt-lambda (x [y 'a] [z #t])
|
||||
x))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -2074,7 +2067,7 @@ of the contract library does not change over time.
|
|||
'(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a] [z #t])
|
||||
(opt-lambda (x [y 'a] [z #t])
|
||||
x))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -2089,7 +2082,7 @@ of the contract library does not change over time.
|
|||
'(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a] [z #t])
|
||||
(opt-lambda (x [y 'a] [z #t])
|
||||
'x))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -2105,7 +2098,7 @@ of the contract library does not change over time.
|
|||
(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a] [z #t])
|
||||
(opt-lambda (x [y 'a] [z #t])
|
||||
(values 1 'x)))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -2122,7 +2115,7 @@ of the contract library does not change over time.
|
|||
'(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a] [z #t])
|
||||
(opt-lambda (x [y 'a] [z #t])
|
||||
(values 'x 'x)))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -2137,7 +2130,7 @@ of the contract library does not change over time.
|
|||
'(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?))))
|
||||
(new (class object%
|
||||
(define/public m
|
||||
(lambda (x [y 'a] [z #t])
|
||||
(opt-lambda (x [y 'a] [z #t])
|
||||
(values 1 1)))
|
||||
(super-new)))
|
||||
'pos
|
||||
|
|
@ -3631,9 +3624,9 @@ of the contract library does not change over time.
|
|||
|
||||
(contract-eval '(define-contract-struct node (val obj rank left right) (make-inspector)))
|
||||
(contract-eval '(define (compute-rank n)
|
||||
(cond
|
||||
[(not n) 0]
|
||||
[else (node-rank n)])))
|
||||
(if n
|
||||
(node-rank n)
|
||||
0)))
|
||||
|
||||
(contract-eval '(define-opt/c (leftist-heap-greater-than/rank/opt n r)
|
||||
(or/c not
|
||||
|
|
@ -3783,7 +3776,7 @@ of the contract library does not change over time.
|
|||
(cond
|
||||
[(not t1) t2]
|
||||
[(not t2) t1]
|
||||
[else
|
||||
[#t
|
||||
(let ([t1-val (node-val t1)]
|
||||
[t2-val (node-val t2)])
|
||||
(cond
|
||||
|
|
@ -3793,7 +3786,7 @@ of the contract library does not change over time.
|
|||
(node-left t1)
|
||||
(merge (node-right t1)
|
||||
t2))]
|
||||
[else
|
||||
[#t
|
||||
(pick t2-val
|
||||
(node-obj t2)
|
||||
(node-left t2)
|
||||
|
|
@ -3806,7 +3799,7 @@ of the contract library does not change over time.
|
|||
(cond
|
||||
[(>= ra rb)
|
||||
(make-node x obj (+ rb 1) a b)]
|
||||
[else
|
||||
[#t
|
||||
(make-node x obj (+ ra 1) b a)])))
|
||||
(node-val
|
||||
(remove-min (ai (make-node 137 'x 1
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user