suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

..

Browse Source 
original commit: b126ca20564a9ca3d676ec0032a7074ec2b7f42e
This commit is contained in:
Robby Findler 2002-12-03 23:20:09 +00:00
parent 77896eab3f
commit bc512e0a8f
1 changed files with 477 additions and 452 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

255
collects/mzlib/contracts.ss
View File

@ -14,11 +14,14 @@
(require-for-syntax mzscheme (require-for-syntax mzscheme
(lib "list.ss") (lib "list.ss")
(lib "match.ss")
(lib "pretty.ss") (lib "pretty.ss")
(lib "name.ss" "syntax") (lib "name.ss" "syntax")
(lib "stx.ss" "syntax")) (lib "stx.ss" "syntax"))
(require (lib "class.ss")) (require (lib "class.ss")
(lib "etc.ss"))
(require (lib "contract-helpers.scm" "mzlib" "private")) (require (lib "contract-helpers.scm" "mzlib" "private"))
(require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private"))) (require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private")))
@ -590,15 +593,119 @@
; ;
(define-syntaxes (-> ->* ->d ->d* case->) (define-syntax-set (-> ->* ->d ->d* case-> class-contract)
(let ()
;; ->/proc : syntax -> syntax
;; the transformer for the -> macro
(define (->/proc stx) (make-/proc ->/h stx))
;; ->*/proc : syntax -> syntax
;; the transformer for the ->* macro
(define (->*/proc stx) (make-/proc ->*/h stx))
;; ->d/proc : syntax -> syntax
;; the transformer for the ->d macro
(define (->d/proc stx) (make-/proc ->d/h stx))
;; ->d*/proc : syntax -> syntax
;; the transformer for the ->d* macro
(define (->d*/proc stx) (make-/proc ->d*/h stx))
;; case->/proc : syntax -> syntax
;; the transformer for the case-> macro
(define (case->/proc stx)
(syntax-case stx ()
[(_ case ...)
(let-values ([(add-outer-check make-inner-check make-bodies)
(case->/h stx (syntax->list (syntax (case ...))))])
(let ([outer-args (syntax (val pos-blame neg-blame src-info))])
(with-syntax ([outer-args outer-args]
[(inner-check ...) (make-inner-check outer-args)]
[(body ...) (make-bodies outer-args)])
(with-syntax ([inner-lambda
(set-inferred-name-from
stx
(syntax (case-lambda body ...)))])
(add-outer-check
(syntax
(make-contract
(lambda outer-args
inner-check ...
inner-lambda))))))))]))
(define (class-contract/proc stx)
(syntax-case stx ()
[(_ (meth-name meth-contract) ...)
(andmap identifier? (syntax->list (syntax (meth-name ...))))
(match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...)
(map (lambda (meth-contract-stx)
(let ([/h (select/h meth-contract-stx 'class-contract stx)])
(let-values ([(make-outer-check xxx build-pieces) (/h meth-contract-stx)])
(list make-outer-check xxx build-pieces))))
(syntax->list (syntax (meth-contract ...))))])
(let ([outer-args (syntax (val pos neg src-info))])
(with-syntax ([outer-args outer-args]
[(super-meth-name ...) (map prefix-super (syntax->list (syntax (meth-name ...))))])
(foldr
(lambda (f stx) (f stx))
(syntax
(make-contract
(lambda outer-args
(unless (class? val)
(raise-contract-error src-info pos neg "expected a class, got: ~e" val))
(let ([class-i (class->interface val)])
(void)
(unless (method-in-interface? 'meth-name class-i)
(raise-contract-error src-info
pos neg
"expected class to have method ~a, got: ~e"
'meth-name
val))
...)
(class val
(rename [super-meth-name meth-name] ...)
(define/override meth-name
(lambda x (super-meth-name . x)))
...
(super-instantiate ())))))
make-outer-checks))))]
[(_ (meth-name meth-contract) ...)
(for-each (lambda (name)
(unless (identifier? name)
(raise-syntax-error 'class-contract "expected name" stx name)))
(syntax->list (syntax (meth-name ...))))]
[(_ clz ...)
(for-each (lambda (clz)
(syntax-case clz ()
[(a b) (void)]
[else (raise-syntax-error 'class-contract "bad method/contract clause" stx clz)]))
(syntax->list (syntax (clz ...))))]))
;; prefix-super : syntax[identifier] -> syntax[identifier]
;; adds super- to the front of the identifier
(define (prefix-super stx)
(datum->syntax-object
#'here
(string->symbol
(format
"super-~a"
(syntax-object->datum
stx)))))
;; Each of the /h functions builds three pieces of syntax: ;; Each of the /h functions builds three pieces of syntax:
;; - code that does error checking for the contract specs ;; - code that binds the contract values to names and
;; does error checking for the contract specs
;; (were the arguments all contracts?) ;; (were the arguments all contracts?)
;; - code that does error checking on the contract'd value ;; - code that does error checking on the contract'd value itself
;; (is a function of the right arity?) ;; (is a function of the right arity?)
;; - a piece of syntax that has the arguments to the wrapper ;; - a piece of syntax that has the arguments to the wrapper
;; and the body of the wrapper. ;; and the body of the wrapper.
;; the first functions accepts `body' and it wraps
;; the second and third function's input syntax should be four
;; names: val, pos-blame, neg-blame, src-info.
;; They are combined into a lambda for the -> ->* ->d ->d* macros, ;; They are combined into a lambda for the -> ->* ->d ->d* macros,
;; and combined into a case-lambda for the case-> macro. ;; and combined into a case-lambda for the case-> macro.
@ -921,10 +1028,9 @@
rng-contracts rng-contracts
results))))))))))))])) results))))))))))))]))
;; make-/f : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) ;; make-/proc : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)))
;; -> (syntax -> syntax) ;; -> (syntax -> syntax)
(define (make-/f /h) (define (make-/proc /h stx)
(lambda (stx)
(let-values ([(add-outer-check make-inner-check make-main) (/h stx)]) (let-values ([(add-outer-check make-inner-check make-main) (/h stx)])
(let ([outer-args (syntax (val pos-blame neg-blame src-info))]) (let ([outer-args (syntax (val pos-blame neg-blame src-info))])
(with-syntax ([outer-args outer-args] (with-syntax ([outer-args outer-args]
@ -939,68 +1045,19 @@
(make-contract (make-contract
(lambda outer-args (lambda outer-args
inner-check inner-check
inner-lambda)))))))))) inner-lambda)))))))))
;; set-inferred-name-from : syntax syntax -> syntax ;; case->/h : syntax (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
(define (set-inferred-name-from with-name to-be-named)
(let ([name (syntax-local-infer-name with-name)])
(if name
(syntax-property to-be-named 'inferred-name name)
to-be-named)))
;; ->/f : syntax -> syntax
;; the transformer for the -> macro
(define ->/f (make-/f ->/h))
;; ->*/f : syntax -> syntax
;; the transformer for the ->* macro
(define ->*/f (make-/f ->*/h))
;; ->d/f : syntax -> syntax
;; the transformer for the ->d macro
(define ->d/f (make-/f ->d/h))
;; ->d*/f : syntax -> syntax
;; the transformer for the ->d* macro
(define ->d*/f (make-/f ->d*/h))
;; case->/f : syntax -> syntax
;; the transformer for the case-> macro
(define (case->/f stx)
(syntax-case stx ()
[(_ case ...)
(let-values ([(add-outer-check make-inner-check make-bodies)
(case->/h (syntax->list (syntax (case ...))))])
(let ([outer-args (syntax (val pos-blame neg-blame src-info))])
(with-syntax ([outer-args outer-args]
[(inner-check ...) (make-inner-check outer-args)]
[(body ...) (make-bodies outer-args)])
(with-syntax ([inner-lambda
(set-inferred-name-from
stx
(syntax (case-lambda body ...)))])
(add-outer-check
(syntax
(make-contract
(lambda outer-args
inner-check ...
inner-lambda))))))))]))
;; case->/h : (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
;; like the other /h functions, but composes the wrapper functions ;; like the other /h functions, but composes the wrapper functions
;; together and combines the cases of the case-lambda into a single list. ;; together and combines the cases of the case-lambda into a single list.
(define (case->/h cases) (define (case->/h orig-stx cases)
(let loop ([cases cases]) (let loop ([cases cases])
(cond (cond
[(null? cases) (values (lambda (x) x) [(null? cases) (values (lambda (x) x)
(lambda (args) (syntax ())) (lambda (args) (syntax ()))
(lambda (args) (syntax ())))] (lambda (args) (syntax ())))]
[else [else
(let ([/h (syntax-case (car cases) (-> ->* ->d ->d*) (let ([/h (select/h (car cases) 'case-> orig-stx)])
[(-> . args) ->/h]
[(->* . args) ->*/h]
[(->d . args) ->d/h]
[(->d* . args) ->d*/h])])
(let-values ([(add-outer-checks make-inner-checks make-bodies) (loop (cdr cases))] (let-values ([(add-outer-checks make-inner-checks make-bodies) (loop (cdr cases))]
[(add-outer-check make-inner-check make-body) (/h (car cases))]) [(add-outer-check make-inner-check make-body) (/h (car cases))])
(values (values
@ -1014,13 +1071,32 @@
[cases (make-bodies args)]) [cases (make-bodies args)])
(syntax (case . cases)))))))]))) (syntax (case . cases)))))))])))
;; select/h : syntax -> /h-function
(define (select/h stx err-name ctxt-stx)
(syntax-case stx (-> ->* ->d ->d*)
[(-> . args) ->/h]
[(->* . args) ->*/h]
[(->d . args) ->d/h]
[(->d* . args) ->d*/h]
[(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
[_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
;; set-inferred-name-from : syntax syntax -> syntax
(define (set-inferred-name-from with-name to-be-named)
(let ([name (syntax-local-infer-name with-name)])
(if name
(syntax-property to-be-named 'inferred-name name)
to-be-named)))
;; (cons X (listof X)) -> (listof X)
;; returns the elements of `l', minus the last
;; element
(define (all-but-last l) (define (all-but-last l)
(cond (cond
[(null? l) (error 'all-but-last "bad input")] [(null? l) (error 'all-but-last "bad input")]
[(null? (cdr l)) null] [(null? (cdr l)) null]
[else (cons (car l) (all-but-last (cdr l)))])) [else (cons (car l) (all-but-last (cdr l)))])))
(values ->/f ->*/f ->d/f ->d*/f case->/f)))
(define-syntax (opt-> stx) (define-syntax (opt-> stx)
(syntax-case stx () (syntax-case stx ()
@ -1052,57 +1128,6 @@
(case-> (->* (case-doms ...) (double-res-vs ...)) ...)))))])) (case-> (->* (case-doms ...) (double-res-vs ...)) ...)))))]))
;
;
;
; ;
; ;
; ; ; ;
; ;;; ; ;;; ;;; ;;; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ;
; ; ; ; ;; ;; ; ; ; ; ; ; ; ; ; ; ;;
; ; ; ;;;; ;; ;; ; ; ; ; ; ; ; ;;;; ; ; ;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ; ;;;;; ;;; ;;; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; ;;;
;
;
;;
;
; (define-syntax (class-contract stx)
; (syntax-case stx ()
; [(_ (meth-name meth-contract) ...)
; (andmap identifier? (syntax->list (syntax (meth-name ...))))
; (let ()
; (define (expand-contract x y)
; (syntax 1))
; (with-syntax ([(((doms ...) (rngs ...)) ...)
; (map expand-contract
; (syntax->list (syntax (meth-name ...)))
; (syntax->list (syntax (meth-contract ...))))])
; (syntax
; (make-contract
; (lambda (val pos neg src-info)
; (unless (class? val)
; (raise-contract-error src-info pos neg "expected a class, got: ~e" val))
; (let ([class-i (class->interface val)])
; (void)
; (unless (method-in-interface? 'meth-name class-i)
; (raise-contract-error src-info
; pos neg
; "expected class to have method ~a, got: ~e"
; 'meth-name
; val))
; ...)
; (class val
; (define/override (meth-name
; val)))))]
; [(_ (meth-name meth-contract) ...)
; (for-each (lambda (name)
; (unless (identifier? name)
; (raise-syntax-error 'class-contract "expected name" stx name)))
; (syntax->list (syntax (meth-name ...))))]))
; ;
; ;
; ;