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

Fixing error with freevars and eliminating code duplication

Browse Source 
svn: r6915
This commit is contained in:
Jay McCarthy 2007-07-14 15:13:17 +00:00
parent 2758133083
commit 1119702903
3 changed files with 33 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/web-server/lang/elim-callcc.ss
View File

@ -80,6 +80,7 @@
(let* ([ke-prime (elim-callcc #'ke)]
[me-prime (elim-callcc #'me)]
[be-prime (elim-callcc #'be)])
; XXX Could be dangerous to evaluate ke-prime and me-prime twice
(markit
(quasisyntax/loc stx
(with-continuation-mark #,ke-prime #,me-prime
@ -101,19 +102,21 @@
(lambda () (#%app resume #,ref-to-cm #,ref-to-x)))))
(#%app activation-record-list))))))]
[(#%app call-with-values (lambda () prod) cons)
(let ([cons-prime (mark-lambda-as-safe (elim-callcc #'cons))])
(markit
(quasisyntax/loc stx
(#%app call-with-values
#,(mark-lambda-as-safe
(quasisyntax/loc stx
(lambda ()
#,(elim-callcc/mark
(lambda (x)
(quasisyntax/loc stx
(with-continuation-mark the-cont-key #,cons-prime #,x)))
#'prod))))
#,cons-prime))))]
(let ([cons-prime (datum->syntax-object #f (gensym 'cons))])
(quasisyntax/loc stx
(let-values ([(#,cons-prime) #,(mark-lambda-as-safe (elim-callcc #'cons))])
#,(markit
(quasisyntax/loc stx
(#%app call-with-values
#,(mark-lambda-as-safe
(quasisyntax/loc stx
(lambda ()
#,(elim-callcc/mark
(lambda (x)
(quasisyntax/loc stx
(with-continuation-mark the-cont-key #,cons-prime #,x)))
#'prod))))
#,cons-prime))))))]
[(#%app w (#%app . stuff))
(with-syntax ([e #'(#%app . stuff)])
(syntax-case #'w (lambda case-lambda)

8
collects/web-server/lang/freevars.ss
View File

@ -29,7 +29,8 @@
(set-diff (free-vars #'ve)
(syntax->list #'(v ...))))]
[(set! v ve)
(free-vars #'ve)]
(union (free-vars #'v)
(free-vars #'ve))]
[(let-values ([(v ...) ve] ...) be ...)
(union (free-vars* (syntax->list #'(ve ...)))
(set-diff (free-vars* (syntax->list #'(be ...)))
@ -84,9 +85,12 @@
[id (identifier? #'id)
(let ([i-bdg (identifier-binding #'id)])
(cond
[(eqv? 'lexical (identifier-binding #'id))
[(eqv? 'lexical i-bdg)
(list #'id)]
[(not i-bdg)
(list #'id)]
[else
#;(printf "Not including id ~S with binding ~S in freevars~n" (syntax-object->datum #'id) i-bdg)
empty]))]
[_
(raise-syntax-error 'freevars "Dropped through:" stx)]))

12
collects/web-server/tests/lang-test.ss
View File

@ -525,6 +525,16 @@
(define-struct posn (x y))
(provide/contract
[struct posn ([x integer?] [y integer?])])))))))
[struct posn ([x integer?] [y integer?])]))))))
(test-case
"define-values error"
(check-not-exn
(lambda ()
(make-module-eval
(module test (lib "lang.ss" "web-server")
(define (show-user)
(define-values (point i) (values #t 1))
i)))))))
)))