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

fix disappeared-binding information in a syntax-template expansion with a binding is used more than once

Browse Source 
svn: r5947
This commit is contained in:
Matthew Flatt 2007-04-16 00:52:28 +00:00
parent a61b6bc4a2
commit 5d1f33670a
3 changed files with 1695 additions and 1669 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3311
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

25
src/mzscheme/src/startup.inc
View File

@ -1330,9 +1330,13 @@
" #f" " #f"
"(lambda(r)" "(lambda(r)"
"(let((l(hash-table-get ht(syntax-e r) null)))" "(let((l(hash-table-get ht(syntax-e r) null)))"
"(unless(and(pair? l)" "(let((pr(and(pair? l)"
"(ormap(lambda(i)(bound-identifier=? i r)) l))" "(ormap(lambda(i) "
"(hash-table-put! ht(syntax-e r)(cons r l)))))))))" "(and(bound-identifier=?(car i) r) i))"
" l))))"
"(if pr"
"(set-cdr! pr(cons r(cdr pr)))"
"(hash-table-put! ht(syntax-e r)(cons(cons r(list r)) l))))))))))"
"(if proto-r" "(if proto-r"
" `(lambda(r)" " `(lambda(r)"
" ,(let((main(let((build(apply-to-r l)))" " ,(let((main(let((build(apply-to-r l)))"
@ -1353,7 +1357,10 @@
"(quote ,p)" "(quote ,p)"
"(quote-syntax ,(datum->syntax-object #f '... p)))" "(quote-syntax ,(datum->syntax-object #f '... p)))"
" main)))" " main)))"
"(apply append(hash-table-map ht(lambda(k v) v))))))" "(let((l(apply append(hash-table-map ht(lambda(k v) v)))))"
"(values"
"(map car l)"
"(map cdr l))))))"
"(-define(apply-to-r rest)" "(-define(apply-to-r rest)"
"(if(and(pair? rest)" "(if(and(pair? rest)"
"(eq?(car rest) 'lambda)" "(eq?(car rest) 'lambda)"
@ -1935,7 +1942,7 @@
"(datum->syntax-object" "(datum->syntax-object"
" here-stx" " here-stx"
"(let((pattern(stx-car(stx-cdr x))))" "(let((pattern(stx-car(stx-cdr x))))"
"(let((unique-vars(make-pexpand pattern #f null #f)))" "(let-values(((unique-vars all-varss)(make-pexpand pattern #f null #f)))"
"(let((var-bindings" "(let((var-bindings"
"(map" "(map"
"(lambda(var)" "(lambda(var)"
@ -1970,7 +1977,7 @@
"(cons(car vars) rest)))))))" "(cons(car vars) rest)))))))"
"(let((build-from-template" "(let((build-from-template"
"(make-pexpand pattern proto-r non-pattern-vars pattern))" "(make-pexpand pattern proto-r non-pattern-vars pattern))"
"(r(let loop((vars unique-vars)(bindings var-bindings))" "(r(let loop((vars unique-vars)(bindings var-bindings)(all-varss all-varss))"
"(cond" "(cond"
"((null? bindings) null)" "((null? bindings) null)"
"((car bindings)" "((car bindings)"
@ -1981,9 +1988,9 @@
"(syntax-e(syntax-mapping-valvar(car bindings)))" "(syntax-e(syntax-mapping-valvar(car bindings)))"
" x)" " x)"
" 'disappeared-use" " 'disappeared-use"
"(car vars))" "(car all-varss))"
"(loop(cdr vars)(cdr bindings))))" "(loop(cdr vars)(cdr bindings)(cdr all-varss))))"
"(else(loop(cdr vars)(cdr bindings)))))))" "(else(loop(cdr vars)(cdr bindings)(cdr all-varss)))))))"
"(if(identifier? pattern)" "(if(identifier? pattern)"
"(car r)" "(car r)"
"(list(datum->syntax-object" "(list(datum->syntax-object"

28
src/mzscheme/src/startup.ss
View File

@ -1554,9 +1554,13 @@
#f #f
(lambda (r) (lambda (r)
(let ([l (hash-table-get ht (syntax-e r) null)]) (let ([l (hash-table-get ht (syntax-e r) null)])
(unless (and (pair? l) (let ([pr (and (pair? l)
(ormap (lambda (i) (bound-identifier=? i r)) l)) (ormap (lambda (i)
(hash-table-put! ht (syntax-e r) (cons r l)))))))]) (and (bound-identifier=? (car i) r) i))
l))])
(if pr
(set-cdr! pr (cons r (cdr pr)))
(hash-table-put! ht (syntax-e r) (cons (cons r (list r)) l))))))))])
(if proto-r (if proto-r
`(lambda (r) `(lambda (r)
,(let ([main (let ([build (apply-to-r l)]) ,(let ([main (let ([build (apply-to-r l)])
@ -1578,8 +1582,12 @@
;; This is a trick to minimize the syntax structure we keep: ;; This is a trick to minimize the syntax structure we keep:
(quote-syntax ,(datum->syntax-object #f '... p))) (quote-syntax ,(datum->syntax-object #f '... p)))
main))) main)))
;; Get list of unique vars: (let ([l (apply append (hash-table-map ht (lambda (k v) v)))])
(apply append (hash-table-map ht (lambda (k v) v)))))) (values
;; Get list of unique vars:
(map car l)
;; All ids, including duplicates:
(map cdr l))))))
;; apply-to-r creates an S-expression that applies ;; apply-to-r creates an S-expression that applies
;; rest to `r', but it also optimizes ((lambda (r) E) r) ;; rest to `r', but it also optimizes ((lambda (r) E) r)
@ -2244,7 +2252,7 @@
(datum->syntax-object (datum->syntax-object
here-stx here-stx
(let ([pattern (stx-car (stx-cdr x))]) (let ([pattern (stx-car (stx-cdr x))])
(let ([unique-vars (make-pexpand pattern #f null #f)]) (let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f)])
(let ([var-bindings (let ([var-bindings
(map (map
(lambda (var) (lambda (var)
@ -2283,7 +2291,7 @@
;; Even if we don't use the builder, we need to check ;; Even if we don't use the builder, we need to check
;; for a well-formed pattern: ;; for a well-formed pattern:
(make-pexpand pattern proto-r non-pattern-vars pattern)] (make-pexpand pattern proto-r non-pattern-vars pattern)]
[r (let loop ([vars unique-vars][bindings var-bindings]) [r (let loop ([vars unique-vars][bindings var-bindings][all-varss all-varss])
(cond (cond
[(null? bindings) null] [(null? bindings) null]
[(car bindings) [(car bindings)
@ -2294,9 +2302,9 @@
(syntax-e (syntax-mapping-valvar (car bindings))) (syntax-e (syntax-mapping-valvar (car bindings)))
x) x)
'disappeared-use 'disappeared-use
(car vars)) (car all-varss))
(loop (cdr vars) (cdr bindings)))] (loop (cdr vars) (cdr bindings) (cdr all-varss)))]
[else (loop (cdr vars) (cdr bindings))]))]) [else (loop (cdr vars) (cdr bindings) (cdr all-varss))]))])
(if (identifier? pattern) (if (identifier? pattern)
;; Simple syntax-id lookup: ;; Simple syntax-id lookup:
(car r) (car r)