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

..

Browse Source 
original commit: e918ee3ec5c89a35d9ed6322543b5cdd11019746
This commit is contained in:
Robby Findler 2002-03-01 15:24:16 +00:00
parent c21b3852be
commit 972ff377ec
1 changed files with 83 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
collects/framework/specs.ss
View File

@ -8,6 +8,7 @@
case->) case->)
(require-for-syntax mzscheme (require-for-syntax mzscheme
(lib "list.ss") (lib "list.ss")
(lib "name.ss" "syntax")
(lib "stx.ss" "syntax")) (lib "stx.ss" "syntax"))
(require (lib "class.ss")) (require (lib "class.ss"))
@ -43,8 +44,13 @@
(syntax (syntax
(-contract a-contract to-check pos-blame-e neg-blame-e src-loc)))] (-contract a-contract to-check pos-blame-e neg-blame-e src-loc)))]
[(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e)
(let ([name (syntax-local-infer-name (syntax a-contract-e))])
(with-syntax ([named-a-contract-e
(if name
(syntax-property (syntax a-contract-e) 'inferred-name name)
(syntax a-contract-e))])
(syntax (syntax
(let ([a-contract a-contract-e] (let ([a-contract named-a-contract-e]
[name to-check] [name to-check]
[neg-blame neg-blame-e] [neg-blame neg-blame-e]
[pos-blame pos-blame-e] [pos-blame pos-blame-e]
@ -63,7 +69,7 @@
a-contract a-contract
name name
src-info)) src-info))
(check-contract a-contract name pos-blame neg-blame src-info-e)))]))) (check-contract a-contract name pos-blame neg-blame src-info-e)))))])))
(define-syntaxes (-> ->* ->d ->d* case->) (define-syntaxes (-> ->* ->d ->d* case->)
(let () (let ()
@ -381,12 +387,23 @@
(with-syntax ([outer-args outer-args] (with-syntax ([outer-args outer-args]
[inner-check (make-inner-check outer-args)] [inner-check (make-inner-check outer-args)]
[(inner-args body) (make-main outer-args)]) [(inner-args body) (make-main outer-args)])
(with-syntax ([inner-lambda
(set-inferred-name-from
stx
(syntax (lambda inner-args body)))])
(add-outer-check (add-outer-check
(syntax (syntax
(make-contract (make-contract
(lambda outer-args (lambda outer-args
inner-check inner-check
(lambda inner-args body)))))))))) inner-lambda))))))))))
;; 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)))
;; ->/f : syntax -> syntax ;; ->/f : syntax -> syntax
;; the transformer for the -> macro ;; the transformer for the -> macro
@ -415,12 +432,16 @@
(with-syntax ([outer-args outer-args] (with-syntax ([outer-args outer-args]
[(inner-check ...) (make-inner-check outer-args)] [(inner-check ...) (make-inner-check outer-args)]
[(body ...) (make-bodies outer-args)]) [(body ...) (make-bodies outer-args)])
(with-syntax ([inner-lambda
(set-inferred-name-from
stx
(syntax (case-lambda body ...)))])
(add-outer-check (add-outer-check
(syntax (syntax
(make-contract (make-contract
(lambda outer-args (lambda outer-args
inner-check ... inner-check ...
(case-lambda body ...))))))))])) inner-lambda))))))))]))
;; case->/h : (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; 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
@ -485,14 +506,21 @@
subclass?/c implementation?/c is-a?/c subclass?/c implementation?/c is-a?/c
listof) listof)
(define (symbols . ss) (define-syntax (name stx)
(lambda (x) (syntax-case stx ()
(memq x ss))) [(_ name exp)
(syntax (let ([name exp])
name))]))
(define (>=/c x) (lambda (y) (and (number? y) (>= y x)))) (define (symbols . ss)
(define (<=/c x) (lambda (y) (and (number? y) (<= y x)))) (name symbols
(define (</c x) (lambda (y) (and (number? y) (< y x)))) (lambda (x)
(define (>/c x) (lambda (y) (and (number? y) (> y x)))) (memq x ss))))
(define (>=/c x) (name >=/c (lambda (y) (and (number? y) (>= y x)))))
(define (<=/c x) (name <=/c (lambda (y) (and (number? y) (<= y x)))))
(define (</c x) (name </c (lambda (y) (and (number? y) (< y x)))))
(define (>/c x) (name >/c (lambda (y) (and (number? y) (> y x)))))
(define (is-a?/c <%>) (lambda (x) (is-a? x <%>))) (define (is-a?/c <%>) (lambda (x) (is-a? x <%>)))
(define (subclass?/c <%>) (lambda (x) (subclass? x <%>))) (define (subclass?/c <%>) (lambda (x) (subclass? x <%>)))
@ -507,7 +535,7 @@
(procedure-arity-includes? x 1)) (procedure-arity-includes? x 1))
(error 'union "expected procedures of arity 1, got: ~e" x))) (error 'union "expected procedures of arity 1, got: ~e" x)))
fs) fs)
(apply or/f fs)) (name union (lambda (x) ((apply or/f fs) x))))
(define (and/f . fs) (define (and/f . fs)
(for-each (for-each
@ -516,8 +544,9 @@
(procedure-arity-includes? x 1)) (procedure-arity-includes? x 1))
(error 'and/f "expected procedures of arity 1, got: ~e" x))) (error 'and/f "expected procedures of arity 1, got: ~e" x)))
fs) fs)
(name and/f
(lambda (x) (lambda (x)
(andmap (lambda (f) (f x)) fs))) (andmap (lambda (f) (f x)) fs))))
(define (or/f . fs) (define (or/f . fs)
(for-each (for-each
@ -526,16 +555,19 @@
(procedure-arity-includes? x 1)) (procedure-arity-includes? x 1))
(error 'or/f "expected procedures of arity 1, got: ~e" x))) (error 'or/f "expected procedures of arity 1, got: ~e" x)))
fs) fs)
(name or/f
(lambda (x) (lambda (x)
(ormap (lambda (f) (f x)) fs))) (ormap (lambda (f) (f x)) fs))))
(define (listof p) (define (listof p)
(name listof
(lambda (v) (lambda (v)
(and (list? v) (and (list? v)
(andmap p v)))) (andmap p v)))))
(define (vectorof p) (define (vectorof p)
(name vectorof
(lambda (v) (lambda (v)
(and (vector? v) (and (vector? v)
(andmap p (vector->list v))))) (andmap p (vector->list v))))))
) )