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
(provide (all-defined))
(require (lib "list.ss")
"contract-guts.ss")
#lang scheme/base
(provide (all-defined-out))
(require "contract-guts.ss")
(define empty-case-lambda/c
(flat-named-contract '(case->)
@ -195,4 +195,3 @@
(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
(require (lib "stx.ss" "syntax")
(lib "name.ss" "syntax"))
#lang scheme/base
(require syntax/stx
syntax/name)
(require-for-template mzscheme
"contract-guts.ss"
"contract-arr-checks.ss")
(require (for-syntax scheme/base))
(require (for-template scheme/base)
(for-template "contract-guts.ss")
(for-template "contract-arr-checks.ss"))
(provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h
->pp/h ->pp-rest/h
@ -199,7 +200,7 @@
;; get-case : syntax -> (union number (cons number 'more))
(define (get-case stx)
(let ([ilist (syntax-object->datum stx)])
(let ([ilist (syntax->datum stx)])
(if (list? ilist)
(length ilist)
(cons
@ -290,24 +291,24 @@
;; prefix-super : syntax[identifier] -> syntax[identifier]
;; adds super- to the front of the identifier
(define (prefix-super stx)
(datum->syntax-object
(datum->syntax
#'here
(string->symbol
(format
"super-~a"
(syntax-object->datum
(syntax->datum
stx)))))
;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier]
;; given the syntax for a method name, constructs the name of a method
;; that returns the super's contract for the original method.
(define (method-name->contract-method-name stx)
(datum->syntax-object
(datum->syntax
#'here
(string->symbol
(format
"ACK_DONT_GUESS_ME-super-contract-~a"
(syntax-object->datum
(syntax->datum
stx)))))
;; Each of the /h functions builds six pieces of syntax:
@ -1108,4 +1109,4 @@
(cond
[(zero? i) null]
[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")
"contract-guts.ss"
"contract-arr-checks.ss"
"contract-opt.ss")
(require-for-syntax "contract-opt-guts.ss"
"contract-helpers.ss"
"contract-arr-obj-helpers.ss"
(lib "stx.ss" "syntax")
(lib "name.ss" "syntax"))
(require (for-syntax scheme/base)
(for-syntax "contract-opt-guts.ss")
(for-syntax "contract-helpers.ss")
(for-syntax "contract-arr-obj-helpers.ss")
(for-syntax (lib "stx.ss" "syntax"))
(for-syntax (lib "name.ss" "syntax")))
(provide ->
->d
@ -123,30 +124,6 @@
[else (apply build-compound-type-name 'values rngs)])])
(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 (->/proc stx)
(let-values ([(stx _1 _2) (->/proc/main stx)])
@ -168,25 +145,11 @@
(with-syntax ([outer-lambda
(let* ([lst (syntax->list #'args)]
[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
(lambda (chk dom-names ... rng-names ...)
(lambda (val)
(chk val)
inner-lambda)))))])
inner-lambda))))])
(values
(syntax (build--> '->
(list dom-ctcs ...)
@ -458,4 +421,4 @@
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
[(-> dom ... rng)
(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
(require (lib "etc.ss")
"contract-arrow.ss"
#lang scheme/base
(require "contract-arrow.ss"
"contract-guts.ss"
"class-internal.ss"
"contract-arr-checks.ss")
(require-for-syntax "contract-helpers.ss"
"contract-arr-obj-helpers.ss"
(lib "list.ss"))
(require (for-syntax scheme/base
"contract-helpers.ss"
"contract-arr-obj-helpers.ss"))
(provide mixin-contract
make-mixin-contract
@ -16,8 +15,8 @@
implementation?/c
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->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 stx select/h #'case-> #'->))
(define (object-contract/proc stx)
(λ (stx)
;; name : syntax
;; ctc-stx : syntax[evals to a contract]
@ -204,7 +203,7 @@
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
[this (datum->syntax mtd-stx 'this)])
(values
obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rng))
@ -214,7 +213,7 @@
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
[this (datum->syntax mtd-stx 'this)])
(values
obj->r/proc
(syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng))
@ -226,7 +225,7 @@
(andmap identifier? (syntax->list (syntax (x ...))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
[this (datum->syntax mtd-stx 'this)])
(values
obj->pp/proc
(syntax (->pp ([this any/c] [x dom] ...) . other-stuff))
@ -238,7 +237,7 @@
(andmap identifier? (syntax->list (syntax (x ...)))))
(with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))]
[(this-var) (generate-temporaries (syntax (this-var)))]
[this (datum->syntax-object mtd-stx 'this)])
[this (datum->syntax mtd-stx 'this)])
(values
obj->pp-rest/proc
(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]
(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)]
[names (map mtd-name mtds)]
[i 0])
@ -279,7 +284,7 @@
rest-ids ...
last-var)))))])))
(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)])
(cons (syntax (lambda (field-ref) (let ([name proc]) name)))
(loop (cdr arg-spec-stxss)
@ -364,7 +369,7 @@
(method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ...
))))))
#f)))))))])))
#f)))))))]))))
(define (check-object val src-info blame orig-str)
@ -435,4 +440,4 @@
[else `(is-a?/c unknown<%>)])
(lambda (x) (is-a? x <%>)))))
(define mixin-contract (class? . ->d . subclass?/c)))
(define mixin-contract (class? . ->d . subclass?/c))