133 lines
3.9 KiB
Scheme
133 lines
3.9 KiB
Scheme
#lang scheme/base
|
|
|
|
#|
|
|
|
|
differences from v3:
|
|
. define/contract is no longer supported
|
|
. ->d and ->* are different
|
|
. ->r ->pp opt-> and opt->* are gone
|
|
|
|
|#
|
|
|
|
(require scheme/contract/exists
|
|
scheme/contract/regions
|
|
"contract/private/basic-opters.ss"
|
|
"contract/base.ss")
|
|
|
|
(provide (all-from-out "contract/base.ss")
|
|
(except-out (all-from-out scheme/contract/exists) ∃?)
|
|
(all-from-out scheme/contract/regions))
|
|
|
|
;; ======================================================================
|
|
;; 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.
|
|
;; (last used pre v4)
|
|
|
|
#;
|
|
(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
|
|
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
|
|
listof
|
|
is-a?/c)
|
|
|
|
(define-syntax symbols
|
|
(syntax-rules ()
|
|
[(_ sym ...)
|
|
(lambda (v) (memq v '(sym ...)))]))
|
|
(provide symbols)
|
|
|
|
)
|