schemify: don't copy uninterned symbols across module boundary
As pointed out by @gus-massa at racket/ChezScheme#15
This commit is contained in:
parent
602c7b0331
commit
db626bde3d
|
@ -3220,6 +3220,36 @@ case of module-leve bindings; it doesn't cover local bindings.
|
|||
(require 'has-a-gensym-that-spans-phases)
|
||||
(test #t eq? the-gensym (expand-to-the-gensym))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Make sure cross-moodule inlining doesn't copy an uninterned symbol
|
||||
;; across a module boundary
|
||||
|
||||
(module exports-a-quoted-uninterned-symbol racket/base
|
||||
(require (for-syntax racket/base))
|
||||
(define-syntax (provide-sym stx)
|
||||
(let ([sym (datum->syntax #f (string->uninterned-symbol "sym"))])
|
||||
#`(begin
|
||||
(define sym '#,sym)
|
||||
(define (get-sym) '#,sym)
|
||||
(provide sym
|
||||
get-sym))))
|
||||
(provide-sym))
|
||||
|
||||
(let ([o (open-output-bytes)])
|
||||
(write (compile `(module imports-a-quoted-uninterned-symbol racket/base
|
||||
(require 'exports-a-quoted-uninterned-symbol)
|
||||
(define (get-sym1) sym)
|
||||
(define (get-sym2) (get-sym))
|
||||
(provide get-sym1
|
||||
get-sym2)))
|
||||
o)
|
||||
(eval (parameterize ([read-accept-compiled #t])
|
||||
(read (open-input-bytes (get-output-bytes o)))))
|
||||
(test (dynamic-require ''exports-a-quoted-uninterned-symbol 'sym)
|
||||
(dynamic-require ''imports-a-quoted-uninterned-symbol 'get-sym1))
|
||||
(test (dynamic-require ''exports-a-quoted-uninterned-symbol 'sym)
|
||||
(dynamic-require ''imports-a-quoted-uninterned-symbol 'get-sym2)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(report-errs)
|
||||
|
|
|
@ -40,10 +40,13 @@
|
|||
[(wrap-pair? v)
|
||||
(cond
|
||||
[(eq? (unwrap (wrap-car v)) 'quote)
|
||||
;; don't copy quoted values other than symbols
|
||||
(if (symbol? (unwrap (wrap-car (wrap-cdr v))))
|
||||
;; don't copy quoted values other than interned or unreadable symbols
|
||||
(let ([v (unwrap (wrap-car (wrap-cdr v)))])
|
||||
(if (and (symbol? v)
|
||||
(or (symbol-interned? v)
|
||||
(symbol-unreadable? v)))
|
||||
(sub1 size)
|
||||
0)]
|
||||
0))]
|
||||
[else
|
||||
(loop (wrap-cdr v) (loop (wrap-car v) size))])]
|
||||
[else (sub1 size)]))))
|
||||
|
|
|
@ -15,7 +15,9 @@
|
|||
(cond
|
||||
[(eq? a 'quote)
|
||||
(let ([u (unwrap (cadr u))])
|
||||
(or (symbol? u)
|
||||
(or (and (symbol? u)
|
||||
(or (symbol-interned? u)
|
||||
(symbol-unreadable? u)))
|
||||
(null? u)
|
||||
(char? u)
|
||||
(void? u)))]
|
||||
|
|
Loading…
Reference in New Issue
Block a user