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))
(link-record-linkid lr)))
(define (make-id-mappers . unbox-stxes)
(apply values (map make-id-mapper unbox-stxes)))
(define (make-id-mappers . make-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
(lambda (sstx)
(syntax-case sstx (set!)
[x
(identifier? #'x)
unbox-stx]
(make-unbox-stx sstx)]
[(set! . x)
(raise-syntax-error
'unit
@ -593,7 +593,7 @@
[(_ . x)
(datum->syntax
sstx
(cons unbox-stx #'x)
(cons (make-unbox-stx sstx) #'x)
sstx)]))))
;; 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)
(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
(with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)])
(quasisyntax/loc (error-syntax)
(quote-syntax (let ([v/c (#,loc)])
(if (pair? v/c)
(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))))))))
(lambda (stx)
(with-syntax ([app (datum->syntax (quote-syntax here)
(list (quote-syntax #,loc))
stx)])
(syntax (let ([v/c app])
(if (pair? v/c)
(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)
(quote-syntax (#,loc)))))
(lambda (stx)
(datum->syntax (quote-syntax here)
(list (quote-syntax #,loc))
stx)))))
;; build-unit : syntax-object ->
;; (values syntax-object (listof identifier) (listof identifier))
@ -1009,7 +1016,7 @@
[#,ivs
(make-id-mappers
#,@(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 ils)
ics))])))
@ -1191,7 +1198,7 @@
tmp)))
#,(quasisyntax/loc defn-or-expr
(define-syntax #,id
(make-id-mapper (quote-syntax #,tmp)))))
(make-id-mapper (lambda (stx) (quote-syntax #,tmp))))))
(and ctc
#`(contract #,ctc #,tmp
(current-contract-region)