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

adjust contract-out.rkt to work when it is compiled

Browse Source
This commit is contained in:
Robby Findler 2013-08-10 09:24:18 -05:00
parent 33db12f146
commit 847016b86c
1 changed files with 26 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
pkgs/racket-pkgs/racket-test/tests/racket/contract/contract-out.rkt
View File

@ -624,15 +624,23 @@
;; drop-var-info : syntax -> syntax ;; drop-var-info : syntax -> syntax
;; strips the lexical content from the syntax object, but preserves the source locations ;; strips the lexical content from the syntax object, but preserves the source locations
(define (drop-var-info stx) (define-syntax (drop-var-info stx)
(let loop ([stx stx]) (syntax-case stx ()
(cond [(_ arg)
[(syntax? stx) (let loop ([stx #'arg])
(datum->syntax #f (loop (syntax-e stx)) stx)] (cond
[(pair? stx) [(syntax? stx)
(cons (loop (car stx)) #`(datum->syntax #f
(loop (cdr stx)))] #,(loop (syntax-e stx))
[else stx]))) (vector #,(syntax-source stx)
#,(syntax-line stx)
#,(syntax-column stx)
#,(syntax-position stx)
#,(syntax-span stx)))]
[(pair? stx)
#`(cons #,(loop (car stx))
#,(loop (cdr stx)))]
[else #`'#,stx]))]))
;; WARNING: do not add or remove lines between here-line and the two modules ;; WARNING: do not add or remove lines between here-line and the two modules
;; below it, unless you also revise the expected result of the test case. ;; below it, unless you also revise the expected result of the test case.
@ -641,25 +649,25 @@
(contract-eval (contract-eval
(compile/wash (compile/wash
(drop-var-info (drop-var-info
#'(module provide/contract-35/m racket/base (module provide/contract-35/m racket/base
(require racket/contract) (require racket/contract)
(define (f x) x) (define (f x) x)
(provide/contract [f (-> integer? integer?)]))))) (provide/contract [f (-> integer? integer?)])))))
(contract-eval (contract-eval
(compile/wash (compile/wash
(drop-var-info (drop-var-info
#'(module provide/contract-35/n racket/base (module provide/contract-35/n racket/base
(require 'provide/contract-35/m) (require 'provide/contract-35/m)
(f #f))))) (f #f)))))
(test (format "contract-out.rkt:~a.30" (test (format "contract-out.rkt:~a.28"
(+ here-line 8)) (+ here-line 8))
'provide/contract-compiled-source-locs 'provide/contract-compiled-source-locs
(with-handlers ((exn:fail? (with-handlers ((exn:fail?
(λ (x) (λ (x)
(define m (define m
(regexp-match #rx"contract-out[.]rkt[^ ]*.30" (exn-message x))) (regexp-match #rx"contract-out[.]rkt[^ ]*.28" (exn-message x)))
(if m (if m
(car m) (car m)
(list 'regexp-match-failed (exn-message x)))))) (list 'regexp-match-failed (exn-message x))))))