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

Basically write begin-with-definitions here by hand, which _does_ work.

Browse Source 
So that should pretty much give us unit contracts, modulo whether we can
separate out the projections so that contracts aren't checked twice
inappropriately.

svn: r13047

original commit: bae2c7b5e121448891289fde194ffbaaced33a24
This commit is contained in:
Stevie Strickland 2009-01-09 19:08:03 +00:00
parent 81e4bee047
commit ea41bc867d
1 changed files with 79 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
collects/mzlib/unit.ss
View File

@ -10,7 +10,6 @@
"private/unit-syntax.ss") "private/unit-syntax.ss")
(require mzlib/contract (require mzlib/contract
mzlib/etc
"private/unit-keywords.ss" "private/unit-keywords.ss"
"private/unit-runtime.ss") "private/unit-runtime.ss")
@ -695,18 +694,24 @@
(var-info-id defid))))) (var-info-id defid)))))
(syntax->list (localify #'ivars def-ctx))) (syntax->list (localify #'ivars def-ctx)))
(with-syntax ([(defn&expr ...) (let-values ([(stx-defns val-defns exprs)
(apply (let sort-clauses ([remaining expanded-body]
append [stx-clauses null]
(map (lambda (defn-or-expr) [val-clauses null]
(syntax-case defn-or-expr (define-values define-syntaxes) [exprs null])
[(define-values () expr) (if (null? remaining)
defn-or-expr] (values (reverse stx-clauses)
[(define-values ids expr) (reverse val-clauses)
(let* ([ids (syntax->list #'ids)] (if (null? exprs)
[tmps (generate-temporaries ids)] (list #'(void))
[new-defn (quasisyntax/loc defn-or-expr (reverse exprs)))
(define-values #,(map (lambda (id tmp) (let ([defn-or-expr (car remaining)])
(syntax-case defn-or-expr (define-values define-syntaxes)
[(define-values (id ...) expr)
(let*-values ([(ids) (syntax->list #'(id ...))]
[(tmps) (generate-temporaries ids)]
[(new-val-clause) (quasisyntax/loc defn-or-expr
(#,(map (λ (id tmp)
(if (var-info-exported? (if (var-info-exported?
(bound-identifier-mapping-get (bound-identifier-mapping-get
defined-names-table defined-names-table
@ -714,39 +719,67 @@
tmp tmp
id)) id))
ids tmps) expr))] ids tmps) expr))]
[do-one [(extra-stx-clauses extra-exprs)
(lambda (id tmp) (let loop ([ids ids]
(let ([unit-name [tmps tmps]
(syntax-local-infer-name (error-syntax))] [stx-clauses null]
[export-loc [exprs null])
(var-info-exported? (if (null? ids)
(bound-identifier-mapping-get (values stx-clauses exprs)
defined-names-table (let* ([id (car ids)]
id))] [tmp (car tmps)]
[add-ctc [unit-name
(var-info-add-ctc (syntax-local-infer-name (error-syntax))]
(bound-identifier-mapping-get [export-loc
defined-names-table (var-info-exported?
id))]) (bound-identifier-mapping-get
(cond defined-names-table
(export-loc id))]
;; set! exported id: [add-ctc
(list (var-info-add-ctc
(quasisyntax/loc defn-or-expr (bound-identifier-mapping-get
(set-box! #,export-loc defined-names-table
(let ([#,id #,(if add-ctc (add-ctc tmp) tmp)]) id))])
#,id))) (cond
(quasisyntax/loc defn-or-expr [export-loc
(define-syntax #,id ;; set! exported id:
(make-id-mapper (quote-syntax #,tmp)))))) (loop (cdr ids)
(else (cdr tmps)
;; not an exported id (cons (quasisyntax/loc defn-or-expr
null))))]) ((#,id) (make-id-mapper (quote-syntax #,tmp))))
(cons new-defn (apply append (map do-one ids tmps))))] stx-clauses)
[else (list defn-or-expr)])) (cons (quasisyntax/loc defn-or-expr
expanded-body))]) (set-box! #,export-loc
#'(begin-with-definitions (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)])
defn&expr ...))))))) #,id)))
exprs))]
[else
;; not an exported id
(loop (cdr ids)
(cdr tmps)
stx-clauses
exprs)]))))])
(sort-clauses (cdr remaining)
(append extra-stx-clauses stx-clauses)
(cons new-val-clause
(append (map (λ (s) #`(() (begin #,s (values)))) exprs)
val-clauses))
extra-exprs))]
[(define-syntaxes (id ...) expr)
(sort-clauses (cdr remaining)
(cons (cdr (syntax->list defn-or-expr))
stx-clauses)
val-clauses
exprs)]
[else
(sort-clauses (cdr remaining)
stx-clauses
val-clauses
(cons defn-or-expr exprs))]))))])
(with-syntax ([(stx-clause ...) stx-defns]
[(val-clause ...) val-defns]
[(expr ...) exprs])
#'(letrec-syntaxes+values (stx-clause ...) (val-clause ...) expr ...))))))))
(define-for-syntax (redirect-imports/exports import?) (define-for-syntax (redirect-imports/exports import?)
(lambda (table-stx (lambda (table-stx