141 lines
4.3 KiB
Scheme
141 lines
4.3 KiB
Scheme
|
|
(module contract mzscheme
|
|
(require "private/contract.ss"
|
|
"private/contract-arrow.ss"
|
|
"private/contract-guts.ss"
|
|
"private/contract-ds.ss"
|
|
"private/contract-opt-guts.ss"
|
|
"private/contract-opt.ss"
|
|
"private/contract-basic-opters.ss")
|
|
|
|
(provide
|
|
opt/c define-opt/c ;(all-from "private/contract-opt.ss")
|
|
(all-from-except "private/contract-ds.ss"
|
|
lazy-depth-to-look)
|
|
|
|
(all-from-except "private/contract-arrow.ss"
|
|
check-procedure)
|
|
(all-from-except "private/contract-guts.ss"
|
|
build-compound-type-name
|
|
first-order-prop
|
|
first-order-get
|
|
check-flat-contract
|
|
check-flat-named-contract)
|
|
(all-from-except "private/contract.ss"
|
|
check-between/c
|
|
check-unary-between/c)))
|
|
|
|
;; ======================================================================
|
|
;; The alternate implementation disables contracts. Its useful mainly to
|
|
;; measure the cost of contracts. It's not necessarily complete, but it
|
|
;; works well enough for starting DrScheme.
|
|
|
|
#;
|
|
(module contract mzscheme
|
|
|
|
(define-syntax provide/contract
|
|
(syntax-rules ()
|
|
[(_ elem ...)
|
|
(begin (provide-one elem) ...)]))
|
|
|
|
(define-syntax provide-one
|
|
(syntax-rules (struct rename)
|
|
[(_ (struct (id par-id) ([field . rest] ...)))
|
|
(provide-struct id par-id (field ...))]
|
|
[(_ (struct id ([field . rest] ...)))
|
|
(provide (struct id (field ...)))]
|
|
[(_ (rename id1 id2 c))
|
|
(provide (rename id1 id2))]
|
|
[(_ (id c))
|
|
(provide id)]))
|
|
|
|
(define-syntax (provide-struct stx)
|
|
(syntax-case stx ()
|
|
[(_ id par-id . rest)
|
|
(let ([info (syntax-local-value #'id (lambda () #f))]
|
|
[p-info (syntax-local-value #'par-id (lambda () #f))]
|
|
[prefix (lambda (l n)
|
|
(let loop ([l l][len (length l)])
|
|
(if (= n len)
|
|
null
|
|
(cons (car l) (loop (cdr l)
|
|
(- len 1))))))]
|
|
[ids (lambda (l) (let loop ([l l])
|
|
(cond
|
|
[(null? l) null]
|
|
[(car l) (cons (car l) (loop (cdr l)))]
|
|
[else (loop (cdr l))])))])
|
|
(if (and info
|
|
p-info
|
|
(list? info)
|
|
(list? p-info)
|
|
(= (length info) 6)
|
|
(= (length p-info) 6))
|
|
#`(provide #,@(append
|
|
(list #'id
|
|
(list-ref info 0)
|
|
(list-ref info 1)
|
|
(list-ref info 2))
|
|
(ids (prefix (list-ref info 3) (length (list-ref p-info 3))))
|
|
(ids (prefix (list-ref info 4) (length (list-ref p-info 4))))))
|
|
(raise-syntax-error
|
|
#f
|
|
(cond
|
|
[(not info) "cannot find struct info"]
|
|
[(not p-info) "cannot find parent-struct info"]
|
|
[else (format "struct or parent-struct info has unexpected shape: ~e and ~e"
|
|
info p-info)])
|
|
#'id)))]))
|
|
|
|
(define-syntax define-contract-struct
|
|
(syntax-rules ()
|
|
[(_ . rest) (define-struct . rest)]))
|
|
|
|
(define-syntax define/contract
|
|
(syntax-rules ()
|
|
[(_ id c expr) (define id expr)]))
|
|
|
|
(define-syntax contract
|
|
(syntax-rules ()
|
|
[(_ c expr . rest) expr]))
|
|
|
|
(provide provide/contract
|
|
define-contract-struct
|
|
define/contract
|
|
contract)
|
|
|
|
(define mk*
|
|
(lambda args (lambda (x) x)))
|
|
|
|
(define-syntax mk
|
|
(syntax-rules ()
|
|
[(_ id) (begin
|
|
(define-syntax (id stx) (quote-syntax mk*))
|
|
(provide id))]
|
|
[(_ id ...)
|
|
(begin (mk id) ...)]))
|
|
|
|
(mk ->
|
|
->*
|
|
opt->
|
|
case->
|
|
->r
|
|
or/c
|
|
and/c
|
|
any/c
|
|
flat-named-contract
|
|
flat-contract
|
|
flat-contract-predicate
|
|
object-contract
|
|
union
|
|
listof
|
|
is-a?/c)
|
|
|
|
(define-syntax symbols
|
|
(syntax-rules ()
|
|
[(_ sym ...)
|
|
(lambda (v) (memq v '(sym ...)))]))
|
|
(provide symbols)
|
|
|
|
)
|