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

removed links to old mzlib stuff and mzscheme module from the contract library (but not from all the libraries it depends on)

Browse Source 
svn: r8023

original commit: 8a7cdad926e8c3c9a8fa81f6f6966dcd453b6019
This commit is contained in:
Robby Findler 2007-12-16 00:20:18 +00:00
parent a23d25b76e
commit f0aa868ce8
4 changed files with 1772 additions and 1804 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,7 @@
(module contract-arr-checks mzscheme #lang scheme/base
(provide (all-defined))
(require (lib "list.ss") (provide (all-defined-out))
"contract-guts.ss") (require "contract-guts.ss")
(define empty-case-lambda/c (define empty-case-lambda/c
(flat-named-contract '(case->) (flat-named-contract '(case->)
@ -195,4 +195,3 @@
(not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0))) (not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0)))
|# |#
)

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

@ -1,10 +1,11 @@
(module contract-arr-obj-helpers mzscheme #lang scheme/base
(require (lib "stx.ss" "syntax") (require syntax/stx
(lib "name.ss" "syntax")) syntax/name)
(require-for-template mzscheme (require (for-syntax scheme/base))
"contract-guts.ss" (require (for-template scheme/base)
"contract-arr-checks.ss") (for-template "contract-guts.ss")
(for-template "contract-arr-checks.ss"))
(provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h (provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h
->pp/h ->pp-rest/h ->pp/h ->pp-rest/h
@ -199,7 +200,7 @@
;; get-case : syntax -> (union number (cons number 'more)) ;; get-case : syntax -> (union number (cons number 'more))
(define (get-case stx) (define (get-case stx)
(let ([ilist (syntax-object->datum stx)]) (let ([ilist (syntax->datum stx)])
(if (list? ilist) (if (list? ilist)
(length ilist) (length ilist)
(cons (cons
@ -290,24 +291,24 @@
;; prefix-super : syntax[identifier] -> syntax[identifier] ;; prefix-super : syntax[identifier] -> syntax[identifier]
;; adds super- to the front of the identifier ;; adds super- to the front of the identifier
(define (prefix-super stx) (define (prefix-super stx)
(datum->syntax-object (datum->syntax
#'here #'here
(string->symbol (string->symbol
(format (format
"super-~a" "super-~a"
(syntax-object->datum (syntax->datum
stx))))) stx)))))
;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier] ;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier]
;; given the syntax for a method name, constructs the name of a method ;; given the syntax for a method name, constructs the name of a method
;; that returns the super's contract for the original method. ;; that returns the super's contract for the original method.
(define (method-name->contract-method-name stx) (define (method-name->contract-method-name stx)
(datum->syntax-object (datum->syntax
#'here #'here
(string->symbol (string->symbol
(format (format
"ACK_DONT_GUESS_ME-super-contract-~a" "ACK_DONT_GUESS_ME-super-contract-~a"
(syntax-object->datum (syntax->datum
stx))))) stx)))))
;; Each of the /h functions builds six pieces of syntax: ;; Each of the /h functions builds six pieces of syntax:
@ -1108,4 +1109,4 @@
(cond (cond
[(zero? i) null] [(zero? i) null]
[else (cons (- n i) [else (cons (- n i)
(loop (- i 1)))])))))) (loop (- i 1)))])))))

55
collects/scheme/private/contract-arrow.ss
View File

@ -1,13 +1,14 @@
(module contract-arrow mzscheme #lang scheme/base
(require (lib "etc.ss") (require (lib "etc.ss")
"contract-guts.ss" "contract-guts.ss"
"contract-arr-checks.ss" "contract-arr-checks.ss"
"contract-opt.ss") "contract-opt.ss")
(require-for-syntax "contract-opt-guts.ss" (require (for-syntax scheme/base)
"contract-helpers.ss" (for-syntax "contract-opt-guts.ss")
"contract-arr-obj-helpers.ss" (for-syntax "contract-helpers.ss")
(lib "stx.ss" "syntax") (for-syntax "contract-arr-obj-helpers.ss")
(lib "name.ss" "syntax")) (for-syntax (lib "stx.ss" "syntax"))
(for-syntax (lib "name.ss" "syntax")))
(provide -> (provide ->
->d ->d
@ -123,30 +124,6 @@
[else (apply build-compound-type-name 'values rngs)])]) [else (apply build-compound-type-name 'values rngs)])])
(apply build-compound-type-name '-> (append doms/c (list rng-name))))])) (apply build-compound-type-name '-> (append doms/c (list rng-name))))]))
(define arity-one-wrapper
(lambda (chk a3 c5) (lambda (val) (chk val) (lambda (a1) (c5 (val (a3 a1)))))))
(define arity-two-wrapper
(lambda (chk a3 b4 c5) (lambda (val) (chk val) (lambda (a1 b2) (c5 (val (a3 a1) (b4 b2)))))))
(define arity-three-wrapper
(lambda (chk a9 b10 c11 r12) (lambda (val) (chk val) (lambda (a6 b7 c8) (r12 (val (a9 a6) (b10 b7) (c11 c8)))))))
(define arity-four-wrapper
(lambda (chk a17 b18 c19 d20 r21) (lambda (val) (chk val) (lambda (a13 b14 c15 d16) (r21 (val (a17 a13) (b18 b14) (c19 c15) (d20 d16)))))))
(define arity-five-wrapper
(lambda (chk a27 b28 c29 d30 e31 r32)
(lambda (val) (chk val) (lambda (a22 b23 c24 d25 e26) (r32 (val (a27 a22) (b28 b23) (c29 c24) (d30 d25) (e31 e26)))))))
(define arity-six-wrapper
(lambda (chk a39 b40 c41 d42 e43 f44 r45)
(lambda (val) (chk val) (lambda (a33 b34 c35 d36 e37 f38) (r45 (val (a39 a33) (b40 b34) (c41 c35) (d42 d36) (e43 e37) (f44 f38)))))))
(define arity-seven-wrapper
(lambda (chk a53 b54 c55 d56 e57 f58 g59 r60)
(lambda (val) (chk val) (lambda (a46 b47 c48 d49 e50 f51 g52) (r60 (val (a53 a46) (b54 b47) (c55 c48) (d56 d49) (e57 e50) (f58 f51) (g59 g52)))))))
(define-syntax-set (-> ->*) (define-syntax-set (-> ->*)
(define (->/proc stx) (define (->/proc stx)
(let-values ([(stx _1 _2) (->/proc/main stx)]) (let-values ([(stx _1 _2) (->/proc/main stx)])
@ -168,25 +145,11 @@
(with-syntax ([outer-lambda (with-syntax ([outer-lambda
(let* ([lst (syntax->list #'args)] (let* ([lst (syntax->list #'args)]
[len (and lst (length lst))]) [len (and lst (length lst))])
(if (and #f ;; this optimization disables the names so is turned off for now
lst
(not (syntax-e #'use-any?))
(= len (length (syntax->list #'(dom-names ...))))
(= 1 (length (syntax->list #'(rng-names ...))))
(<= 1 len 7))
(case len
[(1) #'arity-one-wrapper]
[(2) #'arity-two-wrapper]
[(3) #'arity-three-wrapper]
[(4) #'arity-four-wrapper]
[(5) #'arity-five-wrapper]
[(6) #'arity-six-wrapper]
[(7) #'arity-seven-wrapper])
(syntax (syntax
(lambda (chk dom-names ... rng-names ...) (lambda (chk dom-names ... rng-names ...)
(lambda (val) (lambda (val)
(chk val) (chk val)
inner-lambda)))))]) inner-lambda))))])
(values (values
(syntax (build--> '-> (syntax (build--> '->
(list dom-ctcs ...) (list dom-ctcs ...)
@ -458,4 +421,4 @@
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))] (opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
[(-> dom ... rng) [(-> dom ... rng)
(opt/arrow-ctc (syntax->list (syntax (dom ...))) (opt/arrow-ctc (syntax->list (syntax (dom ...)))
(list #'rng))]))) (list #'rng))]))

37
collects/scheme/private/contract-object.ss
View File

@ -1,13 +1,12 @@
(module contract-object mzscheme #lang scheme/base
(require (lib "etc.ss") (require "contract-arrow.ss"
"contract-arrow.ss"
"contract-guts.ss" "contract-guts.ss"
"class-internal.ss" "class-internal.ss"
"contract-arr-checks.ss") "contract-arr-checks.ss")
(require-for-syntax "contract-helpers.ss" (require (for-syntax scheme/base
"contract-arr-obj-helpers.ss" "contract-helpers.ss"
(lib "list.ss")) "contract-arr-obj-helpers.ss"))
(provide mixin-contract (provide mixin-contract
make-mixin-contract make-mixin-contract
@ -16,8 +15,8 @@
implementation?/c implementation?/c
object-contract) object-contract)
(define-syntax-set (object-contract) (define-syntax object-contract
(let ()
(define (obj->/proc stx) (make-/proc #t ->/h stx)) (define (obj->/proc stx) (make-/proc #t ->/h stx))
(define (obj->*/proc stx) (make-/proc #t ->*/h stx)) (define (obj->*/proc stx) (make-/proc #t ->*/h stx))
(define (obj->d/proc stx) (make-/proc #t ->d/h stx)) (define (obj->d/proc stx) (make-/proc #t ->d/h stx))
@ -45,7 +44,7 @@
(define (obj-opt->/proc stx) (make-opt->/proc #t stx select/h #'case-> #'->)) (define (obj-opt->/proc stx) (make-opt->/proc #t stx select/h #'case-> #'->))
(define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx select/h #'case-> #'->)) (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx select/h #'case-> #'->))
(define (object-contract/proc stx) (λ (stx)
;; name : syntax ;; name : syntax
;; ctc-stx : syntax[evals to a contract] ;; ctc-stx : syntax[evals to a contract]
@ -204,7 +203,7 @@
(andmap identifier? (syntax->list (syntax (x ...)))) (andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->r/proc obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rng)) (syntax (->r ([this any/c] [x dom] ...) rng))
@ -214,7 +213,7 @@
(andmap identifier? (syntax->list (syntax (x ...)))) (andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->r/proc obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng)) (syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng))
@ -226,7 +225,7 @@
(andmap identifier? (syntax->list (syntax (x ...)))) (andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->pp/proc obj->pp/proc
(syntax (->pp ([this any/c] [x dom] ...) . other-stuff)) (syntax (->pp ([this any/c] [x dom] ...) . other-stuff))
@ -238,7 +237,7 @@
(andmap identifier? (syntax->list (syntax (x ...))))) (andmap identifier? (syntax->list (syntax (x ...)))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))] [(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)]) [this (datum->syntax mtd-stx 'this)])
(values (values
obj->pp-rest/proc obj->pp-rest/proc
(syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff)) (syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff))
@ -249,6 +248,12 @@
;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc] ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc]
(define (build-methods-stx mtds) (define (build-methods-stx mtds)
(define (last-pair l)
(cond
[(not (pair? (cdr l))) l]
[else (last-pair (cdr l))]))
(let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)] (let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)]
[names (map mtd-name mtds)] [names (map mtd-name mtds)]
[i 0]) [i 0])
@ -279,7 +284,7 @@
rest-ids ... rest-ids ...
last-var)))))]))) last-var)))))])))
(syntax->list arg-spec-stxs))] (syntax->list arg-spec-stxs))]
[name (string->symbol (format "~a method" (syntax-object->datum (car names))))]) [name (string->symbol (format "~a method" (syntax->datum (car names))))])
(with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)]) (with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)])
(cons (syntax (lambda (field-ref) (let ([name proc]) name))) (cons (syntax (lambda (field-ref) (let ([name proc]) name)))
(loop (cdr arg-spec-stxss) (loop (cdr arg-spec-stxss)
@ -364,7 +369,7 @@
(method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ... (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ... (field/app-var (get-field field-name val)) ...
)))))) ))))))
#f)))))))]))) #f)))))))]))))
(define (check-object val src-info blame orig-str) (define (check-object val src-info blame orig-str)
@ -435,4 +440,4 @@
[else `(is-a?/c unknown<%>)]) [else `(is-a?/c unknown<%>)])
(lambda (x) (is-a? x <%>))))) (lambda (x) (is-a? x <%>)))))
(define mixin-contract (class? . ->d . subclass?/c))) (define mixin-contract (class? . ->d . subclass?/c))