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

R6RS: disallow assignment to exported identifier

Browse Source 
svn: r14695
This commit is contained in:
Matthew Flatt 2009-05-03 17:40:31 +00:00
parent 2b4d032701
commit c17c267f48
5 changed files with 62 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/r6rs/main.ss
View File

@ -9,7 +9,8 @@ FIXME:
(require (for-syntax scheme/base
syntax/kerncase
"private/parse-ref.ss"
scheme/provide-transform))
scheme/provide-transform)
"private/no-set.ss")
(provide (rename-out [module-begin #%module-begin]))
@ -232,6 +233,12 @@ FIXME:
orig
ex)])))
exs)
(add-no-set!-identifiers (map (lambda (ex)
(syntax-case ex ()
[(rename (id ex-id))
#'id]
[id ex]))
exs))
(with-syntax ([((ex ...) ...)
(map (lambda (ex)
(syntax-case ex ()

15
collects/r6rs/private/identifier-syntax.ss
View File

@ -1,26 +1,27 @@
#lang scheme/base
(require (for-syntax scheme/base)
(for-template (only-in scheme/base set! #%app)))
(for-template "no-set.ss"
(only-in scheme/base #%app set!)))
(provide identifier-syntax)
(define-syntax (identifier-syntax stx)
(syntax-case* stx (set!) (lambda (a b)
(free-template-identifier=? a b))
(syntax-case* stx (r6rs:set!) (lambda (a b)
(free-template-identifier=? a b))
[(identifier-syntax template)
#'(...
(make-set!-transformer
(lambda (stx)
(syntax-case stx (set!)
[(set! . _) (raise-syntax-error
#f
"cannot assign to identifier macro"
stx)]
#f
"cannot assign to identifier macro"
stx)]
[(_ arg ...) #'(template arg ...)]
[_ #'template]))))]
[(identifier-syntax
[id1 template1]
[(set! id2 pat) template2])
[(r6rs:set! id2 pat) template2])
(and (identifier? #'id1)
(identifier? #'id2))
#'(...

33
collects/r6rs/private/no-set.ss Normal file
View File

@ -0,0 +1,33 @@
#lang scheme/base
(require (for-syntax scheme/base
syntax/boundmap))
(provide (for-syntax add-no-set!-identifiers)
r6rs:set!)
;; Provided identifier cannot be `set!'ed. The list
;; is relevant only within the module being compiled.
(define-for-syntax no-set!-identifiers (make-free-identifier-mapping))
(define-for-syntax (add-no-set!-identifiers ids)
(for ([id (in-list ids)])
(free-identifier-mapping-put! no-set!-identifiers id #t)))
(define-for-syntax (no-set!-identifier? id)
(free-identifier-mapping-get no-set!-identifiers id (lambda () #f)))
;; ----------------------------------------
(define-syntax (r6rs:set! stx)
(syntax-case stx ()
[(_ id rhs)
(identifier? #'id)
(if (no-set!-identifier? #'id)
(raise-syntax-error
#f
"cannot mutate exported identifier"
stx
#'id)
(syntax/loc stx (set! id rhs)))]
[(_ . rest)
(syntax/loc stx (set! . rest))]))

7
collects/rnrs/base-6.ss
View File

@ -7,6 +7,7 @@
scheme/splicing
r6rs/private/qq-gen
r6rs/private/exns
r6rs/private/no-set
(for-syntax r6rs/private/reconstruct)
(prefix-in r5rs: r5rs)
(only-in r6rs/private/readtable rx:number)
@ -28,7 +29,7 @@
(rename-out [r5rs:if if])
;; 11.4.4
set!
(rename-out [r6rs:set! set!])
;; 11.4.5
cond else => case
@ -269,8 +270,8 @@
(lambda (stx)
(if (identifier? stx)
(syntax/loc stx r6rs-/)
(syntax-case stx (set!)
[(set! . _)
(syntax-case stx (r6rs:set!)
[(r6rs:set! . _)
(raise-syntax-error #f
"cannot mutate imported identifier"
stx)]

11
collects/rnrs/syntax-case-6.ss
View File

@ -6,7 +6,9 @@
scheme/mpair
r6rs/private/exns
(for-syntax syntax/template
r6rs/private/check-pattern))
r6rs/private/check-pattern)
(for-template (only-in scheme/base set!)
r6rs/private/no-set))
(provide make-variable-transformer
(rename-out [r6rs:syntax-case syntax-case]
@ -105,7 +107,12 @@
l)])))))
(define (make-variable-transformer proc)
(make-set!-transformer proc))
(make-set!-transformer
(lambda (stx)
(syntax-case* stx (set!) free-template-identifier=?
[(set! . rest)
(proc (syntax/loc stx (r6rs:set! . rest)))]
[else (proc stx)]))))
(define unwrapped-tag (gensym))