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

Changed to be more like what Sam and I envisioned.

Browse Source 
svn: r13039
This commit is contained in:
Stevie Strickland 2009-01-08 20:50:33 +00:00
parent d5f0b90981
commit bf0d872afd
1 changed files with 54 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

79
collects/mzlib/unit.ss
View File

@ -558,12 +558,7 @@
(syntax->list #'((int-ivar ...) ...)) (syntax->list #'((int-ivar ...) ...))
(syntax->list #'((ext-ivar ...) ...)) (syntax->list #'((ext-ivar ...) ...))
(syntax->list #'((iloc ...) ...)) (syntax->list #'((iloc ...) ...))
(map cadddr import-sigs)) (map cadddr import-sigs)))
[(int-evar ...)
(make-id-mappers
(quote-syntax (unbox eloc))
...)]
...)
(letrec-syntaxes+values (renames ... (letrec-syntaxes+values (renames ...
mac ... ...) mac ... ...)
(val ... ...) (val ... ...)
@ -703,27 +698,25 @@
(var-info-id defid))))) (var-info-id defid)))))
local-ivars) local-ivars)
(with-syntax ([(intname ...) (with-syntax ([(defn&expr ...)
(foldr (apply
(lambda (var res) append
(cond
((not (or (var-info-syntax? (cdr var))
(var-info-exported? (cdr var))))
(cons (car var) res))
(else res)))
null
(bound-identifier-mapping-map defined-names-table cons))]
[(evar ...) #'evars]
[(l-evar ...) local-evars]
[(defn&expr ...)
(filter
values
(map (lambda (defn-or-expr) (map (lambda (defn-or-expr)
(syntax-case defn-or-expr (define-values define-syntaxes) (syntax-case defn-or-expr (define-values define-syntaxes)
[(define-values () expr) [(define-values () expr)
(syntax/loc defn-or-expr (set!-values () expr))] defn-or-expr]
[(define-values ids expr) [(define-values ids expr)
(let ([ids (syntax->list #'ids)] (let* ([ids (syntax->list #'ids)]
[tmps (generate-temporaries ids)]
[new-defn (quasisyntax/loc defn-or-expr
(define-values #,(map (lambda (id tmp)
(if (var-info-exported?
(bound-identifier-mapping-get
defined-names-table
id))
tmp
id))
ids tmps) expr))]
[do-one [do-one
(lambda (id tmp name) (lambda (id tmp name)
(let ([unit-name (let ([unit-name
@ -741,45 +734,29 @@
(cond (cond
(export-loc (export-loc
;; set! exported id: ;; set! exported id:
(list
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
(set-box! #,export-loc (set-box! #,export-loc
#,(if name #,(if name
#`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)]) #`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)])
#,name) #,name)
tmp)))) tmp)))
(quasisyntax/loc defn-or-expr
(define-syntax #,id (make-id-mapper (quote-syntax #,tmp))))))
(else (else
;; not an exported id ;; not an exported id
(quasisyntax/loc defn-or-expr null))))])
(set! #,id #,tmp))))))])
(if (null? (cdr ids)) (if (null? (cdr ids))
(do-one (car ids) (syntax expr) (car ids)) (cons new-defn (do-one (car ids) (car tmps) (car ids)))
(let ([tmps (generate-temporaries ids)]) (cons new-defn (apply append
(with-syntax ([(tmp ...) tmps]
[(set ...)
(map (lambda (id tmp) (map (lambda (id tmp)
(do-one id tmp #f)) (do-one id tmp #f))
ids tmps)]) ids tmps)))))]
(syntax/loc defn-or-expr [else (list defn-or-expr)]))
(let-values ([(tmp ...) expr])
set ...))))))]
[(define-syntaxes . l) #f]
[else defn-or-expr]))
expanded-body))]
[(stx-defn ...)
(filter
values
(map (lambda (defn-or-expr)
(syntax-case defn-or-expr (define-syntaxes)
[(define-syntaxes . l) #'l]
[else #f]))
expanded-body))]) expanded-body))])
#'(letrec-syntaxes+values (stx-defn #'(begin-with-definitions
... defn&expr ...
((l-evar) (make-rename-transformer (quote-syntax evar))) (void))))))))
...)
([(intname) undefined] ...)
(void) ; in case the body would be empty
defn&expr ...)))))))
(define-for-syntax (redirect-imports/exports import?) (define-for-syntax (redirect-imports/exports import?)
(lambda (table-stx (lambda (table-stx