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

2007->2008

Browse Source 
svn: r8169

original commit: 281c1b8838aff87a984e16af9d96cc9d28c2eead
This commit is contained in:
Eli Barzilay 2007-12-31 00:47:21 +00:00
parent e60ffe9547
commit 855f00a028
3 changed files with 1 additions and 1347 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/md5.ss
View File

@ -2,7 +2,7 @@
(provide md5) (provide md5)
;;; Copyright (c) 2005-2007, PLT Scheme Inc. ;;; Copyright (c) 2005-2008, PLT Scheme Inc.
;;; Copyright (c) 2002, Jens Axel Soegaard ;;; Copyright (c) 2002, Jens Axel Soegaard
;;; ;;;
;;; Permission to copy this software, in whole or in part, to use this ;;; Permission to copy this software, in whole or in part, to use this

234
collects/scheme/private/contract-arr-checks.ss
View File

@ -1,234 +0,0 @@
#lang scheme/base
(provide (all-defined-out))
(require "contract-guts.ss")
(define empty-case-lambda/c
(flat-named-contract '(case->)
(λ (x) (and (procedure? x) (null? (procedure-arity x))))))
;; ----------------------------------------
;; Checks and error functions used in macro expansions
;; procedure-accepts-and-more? : procedure number -> boolean
;; returns #t if val accepts dom-length arguments and
;; any number of arguments more than dom-length.
;; returns #f otherwise.
(define (procedure-accepts-and-more? val dom-length)
(let ([arity (procedure-arity val)])
(cond
[(number? arity) #f]
[(arity-at-least? arity)
(<= (arity-at-least-value arity) dom-length)]
[else
(let ([min-at-least (let loop ([ars arity]
[acc #f])
(cond
[(null? ars) acc]
[else (let ([ar (car ars)])
(cond
[(arity-at-least? ar)
(if (and acc
(< acc (arity-at-least-value ar)))
(loop (cdr ars) acc)
(loop (cdr ars) (arity-at-least-value ar)))]
[(number? ar)
(loop (cdr ars) acc)]))]))])
(and min-at-least
(begin
(let loop ([counts (sort (filter number? arity) >=)])
(unless (null? counts)
(let ([count (car counts)])
(cond
[(= (+ count 1) min-at-least)
(set! min-at-least count)
(loop (cdr counts))]
[(< count min-at-least)
(void)]
[else (loop (cdr counts))]))))
(<= min-at-least dom-length))))])))
(define (check->* f arity-count)
(unless (procedure? f)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
(unless (and (procedure-arity-includes? f arity-count)
(no-mandatory-keywords? f))
(error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e"
arity-count
f)))
(define (get-mandatory-keywords f)
(let-values ([(mandatory optional) (procedure-keywords f)])
mandatory))
(define (no-mandatory-keywords? f)
(let-values ([(mandatory optional) (procedure-keywords f)])
(null? mandatory)))
(define (check->*/more f arity-count)
(unless (procedure? f)
(error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f))
(unless (procedure-accepts-and-more? f arity-count)
(error 'object-contract
"expected last argument of ->d* to be a procedure that accepts ~a argument~a and arbitrarily many more, got ~e"
arity-count
(if (= 1 arity-count) "" "s")
f)))
(define (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(unless pre-expr
(raise-contract-error val
src-info
blame
orig-str
"pre-condition expression failure")))
(define (check-post-expr->pp/h val post-expr src-info blame orig-str)
(unless post-expr
(raise-contract-error val
src-info
blame
orig-str
"post-condition expression failure")))
(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str)
(unless (and (procedure? val)
(procedure-arity-includes?/optionals val dom-length optionals)
(keywords-match mandatory-kwds optional-keywords val))
(raise-contract-error
val
src-info
blame
orig-str
"expected a procedure that accepts ~a arguments~a, given: ~e"
dom-length
(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"]
[(null? (cdr mandatory-keywords))
(format " and the keyword ~a" (car mandatory-keywords))]
[else
(format
" and the keywords ~a~a"
(car mandatory-keywords)
(apply string-append (map (λ (x) (format " ~a" x)) (cdr mandatory-keywords))))]))
(define ((check-procedure? arity) val)
(and (procedure? val)
(procedure-arity-includes? val arity)
(no-mandatory-keywords? val)))
(define ((check-procedure/more? arity) val)
(and (procedure? val)
(procedure-accepts-and-more? val arity)))
(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str)
(unless (procedure? val)
(raise-contract-error val
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(unless (procedure-arity-includes? val arity)
(raise-contract-error val
src-info
blame
orig-str
"expected a ~a of arity ~a (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str)
(unless (procedure? val)
(raise-contract-error val
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(unless (procedure-accepts-and-more? val arity)
(raise-contract-error val
src-info
blame
orig-str
"expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(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)
(keywords-match mandatory-kwds optional-kwds val))
(raise-contract-error
val
src-info
blame
orig-str
"expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e"
dom-length
(keyword-error-text mandatory-kwds)
val)))
(define (check-rng-procedure who rng-x arity)
(unless (and (procedure? rng-x)
(procedure-arity-includes? rng-x arity))
(error who "expected range position to be a procedure that accepts ~a arguments, given: ~e"
arity
rng-x)))
(define (check-rng-procedure/more rng-mk-x arity)
(unless (and (procedure? rng-mk-x)
(procedure-accepts-and-more? rng-mk-x arity))
(error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e"
arity
rng-mk-x)))
(define (check-rng-lengths results rng-contracts)
(unless (= (length results) (length rng-contracts))
(error '->d*
"expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively"
(length results) (length rng-contracts))))
#|
test cases for procedure-accepts-and-more?
(and (procedure-accepts-and-more? (lambda (x . y) 1) 3)
(procedure-accepts-and-more? (lambda (x . y) 1) 2)
(procedure-accepts-and-more? (lambda (x . y) 1) 1)
(not (procedure-accepts-and-more? (lambda (x . y) 1) 0))
(procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3)
(procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2)
(procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1)
(not (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0))
(procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2)
(procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1)
(not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0)))
|#

1112
collects/scheme/private/contract-arr-obj-helpers.ss
View File

File diff suppressed because it is too large Load Diff