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

racket/unitsig: fix location on indirect reference

Browse Source 
Set the source location of a function call that implements an indirect
import to be the original identifier, so a use-before-definition error
has the right location.

Closes #1324
This commit is contained in:
Matthew Flatt 2021-04-27 20:23:28 -06:00
parent bf4fb553b3
commit 8cea33baa1
2 changed files with 23 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
racket/collects/racket/private/unit-compiletime.rkt
View File

@ -575,16 +575,16 @@
#`(tag #,(link-record-tag lr) #,(link-record-linkid lr)) #`(tag #,(link-record-tag lr) #,(link-record-linkid lr))
(link-record-linkid lr))) (link-record-linkid lr)))
(define (make-id-mappers . unbox-stxes) (define (make-id-mappers . make-unbox-stxes)
(apply values (map make-id-mapper unbox-stxes))) (apply values (map make-id-mapper make-unbox-stxes)))
(define (make-id-mapper unbox-stx) (define (make-id-mapper make-unbox-stx)
(make-set!-transformer (make-set!-transformer
(lambda (sstx) (lambda (sstx)
(syntax-case sstx (set!) (syntax-case sstx (set!)
[x [x
(identifier? #'x) (identifier? #'x)
unbox-stx] (make-unbox-stx sstx)]
[(set! . x) [(set! . x)
(raise-syntax-error (raise-syntax-error
'unit 'unit
@ -593,7 +593,7 @@
[(_ . x) [(_ . x)
(datum->syntax (datum->syntax
sstx sstx
(cons unbox-stx #'x) (cons (make-unbox-stx sstx) #'x)
sstx)])))) sstx)]))))
;; This utility function returns a list of natural numbers for use as a syntax ;; This utility function returns a list of natural numbers for use as a syntax

29
racket/collects/racket/unit.rkt
View File

@ -892,19 +892,26 @@
(cons (car x) (cons (car x)
(signature-siginfo (lookup-signature (cdr x))))) (signature-siginfo (lookup-signature (cdr x)))))
(define-for-syntax (make-import-unboxing var renamings loc ctc) (define-for-syntax (make-import-make-unboxing var renamings loc ctc)
(if ctc (if ctc
(with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)]) (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)])
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (let ([v/c (#,loc)]) (lambda (stx)
(if (pair? v/c) (with-syntax ([app (datum->syntax (quote-syntax here)
(contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) (list (quote-syntax #,loc))
(current-contract-region) stx)])
(quote #,var) (quote-srcloc #,var)) (syntax (let ([v/c app])
(error 'unit "contracted import ~a used before definition" (if (pair? v/c)
(quote #,(syntax->datum var)))))))) (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c)
(current-contract-region)
(quote #,var) (quote-srcloc #,var))
(error 'unit "contracted import ~a used before definition"
(quote #,(syntax->datum var))))))))))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (#,loc))))) (lambda (stx)
(datum->syntax (quote-syntax here)
(list (quote-syntax #,loc))
stx)))))
;; build-unit : syntax-object -> ;; build-unit : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier)) ;; (values syntax-object (listof identifier) (listof identifier))
@ -1009,7 +1016,7 @@
[#,ivs [#,ivs
(make-id-mappers (make-id-mappers
#,@(map (lambda (iv l c) #,@(map (lambda (iv l c)
(make-import-unboxing iv #'renamings l c)) (make-import-make-unboxing iv #'renamings l c))
(syntax->list ivs) (syntax->list ivs)
(syntax->list ils) (syntax->list ils)
ics))]))) ics))])))
@ -1191,7 +1198,7 @@
tmp))) tmp)))
#,(quasisyntax/loc defn-or-expr #,(quasisyntax/loc defn-or-expr
(define-syntax #,id (define-syntax #,id
(make-id-mapper (quote-syntax #,tmp))))) (make-id-mapper (lambda (stx) (quote-syntax #,tmp))))))
(and ctc (and ctc
#`(contract #,ctc #,tmp #`(contract #,ctc #,tmp
(current-contract-region) (current-contract-region)