schemify: don't copy uninterned symbols across module boundary

As pointed out by @gus-massa at racket/ChezScheme#15
This commit is contained in:
Matthew Flatt 2019-12-08 06:22:20 -07:00
parent 602c7b0331
commit db626bde3d
3 changed files with 40 additions and 5 deletions

View File

@ -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)

View File

@ -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)]))))

View File

@ -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)))]