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

Going to try switching this back, but need to sync from trunk to get Matthew's

Browse Source 
changes to see if it works.

svn: r13098

original commit: b5efb99548e940818a92f41c174bc713bfa80e6b
This commit is contained in:
Stevie Strickland 2009-01-14 01:12:52 +00:00
parent 6a6a4909d4
commit 4a1629bf41
1 changed files with 35 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
collects/mzlib/unit.ss
View File

@ -9,7 +9,8 @@
"private/unit-compiletime.ss" "private/unit-compiletime.ss"
"private/unit-syntax.ss") "private/unit-syntax.ss")
(require mzlib/contract (require mzlib/etc
mzlib/contract
mzlib/stxparam mzlib/stxparam
"private/unit-keywords.ss" "private/unit-keywords.ss"
"private/unit-runtime.ss") "private/unit-runtime.ss")
@ -706,90 +707,39 @@
(var-info-id defid))))) (var-info-id defid)))))
(syntax->list (localify #'ivars def-ctx))) (syntax->list (localify #'ivars def-ctx)))
(let-values ([(stx-defns val-defns exprs) (with-syntax ([(defn-or-expr ...)
(let sort-clauses ([remaining expanded-body] (apply append
[stx-clauses null] (map (λ (defn-or-expr)
[val-clauses null] (syntax-case defn-or-expr (define-values)
[exprs null]) [(define-values (id ...) body)
(if (null? remaining) (let* ([ids (syntax->list #'(id ...))]
(values (reverse stx-clauses) [tmps (generate-temporaries ids)]
(reverse val-clauses) [do-one
(if (null? exprs) (λ (id tmp)
(list #'(void)) (let ([var-info (bound-identifier-mapping-get
(reverse exprs)))
(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?
(bound-identifier-mapping-get
defined-names-table defined-names-table
id)) id)])
tmp
id))
ids tmps) expr))]
[(extra-stx-clauses extra-exprs)
(let loop ([ids ids]
[tmps tmps]
[stx-clauses null]
[exprs null])
(if (null? ids)
(values stx-clauses exprs)
(let* ([id (car ids)]
[tmp (car tmps)]
[export-loc
(var-info-exported?
(bound-identifier-mapping-get
defined-names-table
id))]
[add-ctc
(var-info-add-ctc
(bound-identifier-mapping-get
defined-names-table
id))])
(cond (cond
[export-loc [(var-info-exported? var-info)
;; set! exported id: =>
(loop (cdr ids) (λ (export-loc)
(cdr tmps) (let ([add-ctc (var-info-add-ctc var-info)])
(cons (quasisyntax/loc defn-or-expr (list (quasisyntax/loc defn-or-expr
((#,id) (make-id-mapper (quote-syntax #,tmp))))
stx-clauses)
(cons (quasisyntax/loc defn-or-expr
(set-box! #,export-loc (set-box! #,export-loc
(let ([#,id #,(if add-ctc (add-ctc tmp) tmp)]) (let ([#,id #,(if add-ctc (add-ctc tmp) tmp)])
#,id))) #,id)))
exprs))] (quasisyntax/loc defn-or-expr
[else (define-syntax #,id
;; not an exported id (make-id-mapper (quote-syntax #,tmp)))))))]
(loop (cdr ids) [else (list (quasisyntax/loc defn-or-expr
(cdr tmps) (define-syntax #,id
stx-clauses (make-rename-transformer (quote-syntax #,tmp)))))])))])
exprs)]))))]) (cons (quasisyntax/loc defn-or-expr
(sort-clauses (cdr remaining) (define-values #,tmps body))
(append extra-stx-clauses stx-clauses) (apply append (map do-one ids tmps))))]
(cons new-val-clause [else (list defn-or-expr)]))
(append (map (λ (s) #`(() (begin #,s (values)))) exprs) expanded-body))])
val-clauses)) #'(begin-with-definitions defn-or-expr ...)))))))
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