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

Make TR-generated identifiers have the same name as original identifiers.

Browse Source 
Makes error messages nicer, and makes it easier to correlate with source code.
This commit is contained in:
Vincent St-Amour 2013-02-05 18:11:52 -05:00
parent ff3d785da2
commit 16a75761b0
1 changed files with 9 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/typed-racket/typecheck/provide-handling.rkt
View File

@ -30,6 +30,11 @@
(cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car] (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car]
[else #f])) [else #f]))
(define new-id-introducer (make-syntax-introducer))
(define cnt-id-introducer (make-syntax-introducer))
(define error-id-introducer (make-syntax-introducer))
(define untyped-id-introducer (make-syntax-introducer))
;; generate-contract-defs : dict[id -> def-binding] dict[id -> list[id]] id -> syntax ;; generate-contract-defs : dict[id -> def-binding] dict[id -> list[id]] id -> syntax
;; defs: defines in this module ;; defs: defines in this module
;; provs: provides in this module ;; provs: provides in this module
@ -46,7 +51,7 @@
(define mapping (make-free-id-table)) (define mapping (make-free-id-table))
;; mk : id [id] -> (values syntax id aliases) ;; mk : id [id] -> (values syntax id aliases)
(define (mk internal-id [new-id (generate-temporary internal-id)]) (define (mk internal-id [new-id (new-id-introducer internal-id)])
(define (mk-untyped-syntax b defn-id internal-id) (define (mk-untyped-syntax b defn-id internal-id)
(match b (match b
[(def-struct-stx-binding _ (? struct-info? si)) [(def-struct-stx-binding _ (? struct-info? si))
@ -87,7 +92,7 @@
[(def-binding _ (app (λ (ty) (type->contract ty (λ () #f) #:out #t)) (? values cnt))) [(def-binding _ (app (λ (ty) (type->contract ty (λ () #f) #:out #t)) (? values cnt)))
(values (values
(with-syntax* ([id internal-id] (with-syntax* ([id internal-id]
[cnt-id (generate-temporary #'id)] [cnt-id (cnt-id-introducer #'id)]
[export-id new-id] [export-id new-id]
[module-source pos-blame-id] [module-source pos-blame-id]
[the-contract (generate-temporary 'generated-contract)]) [the-contract (generate-temporary 'generated-contract)])
@ -113,7 +118,7 @@
[(def-binding id ty) [(def-binding id ty)
(values (values
(with-syntax* ([id internal-id] (with-syntax* ([id internal-id]
[error-id (generate-temporary #'id)] [error-id (error-id-introducer #'id)]
[export-id new-id]) [export-id new-id])
#'(begin #'(begin
(define-syntax (error-id stx) (define-syntax (error-id stx)
@ -124,7 +129,7 @@
[(and b (def-stx-binding _)) [(and b (def-stx-binding _))
(with-syntax* ([id internal-id] (with-syntax* ([id internal-id]
[export-id new-id] [export-id new-id]
[untyped-id (generate-temporary #'id)]) [untyped-id (untyped-id-introducer #'id)])
(define-values (d aliases) (define-values (d aliases)
(mk-untyped-syntax b #'untyped-id internal-id)) (mk-untyped-syntax b #'untyped-id internal-id))
(define/with-syntax def d) (define/with-syntax def d)