diff --git a/collects/plai/gc2/mutator.rkt b/collects/plai/gc2/mutator.rkt index b365558a20..554d660431 100644 --- a/collects/plai/gc2/mutator.rkt +++ b/collects/plai/gc2/mutator.rkt @@ -47,6 +47,10 @@ (define-syntax-parameter mutator-tail-call? #t) (define-syntax-parameter mutator-env-roots empty) +(define-syntax-parameter mutator-assignment-allowed? #t) +(define-syntax-rule (no! e) (syntax-parameterize ([mutator-assignment-allowed? #f]) e)) +(define-syntax-rule (yes! e) (syntax-parameterize ([mutator-assignment-allowed? #t]) e)) + ; Sugar Macros (define-syntax-rule (->address e) e) (define-syntax mutator-and @@ -112,7 +116,7 @@ [(_ fe e ...) (let ([tmp (syntax-parameterize ([mutator-tail-call? #f]) - fe)]) + (yes! fe))]) (mutator-begin e ...))])) ; Real Macros @@ -124,13 +128,18 @@ ...)) (define-syntax-rule (mutator-if test true false) (if (syntax-parameterize ([mutator-tail-call? #f]) - (collector:deref (->address test))) + (collector:deref (->address (no! test)))) (->address true) (->address false))) -(define-syntax-rule (mutator-set! id e) - (begin - (set! id (->address e)) - (mutator-app void))) +(define-syntax (mutator-set! stx) + (syntax-case stx () + [(_ id e) + (let () + (if (syntax-parameter-value #'mutator-assignment-allowed?) + #'(begin + (set! id (->address (no! e))) + (mutator-app void)) + (raise-syntax-error 'set! "allowed only inside begin expressions and at the top-level" stx)))])) (define-syntax (mutator-let-values stx) (syntax-case stx () [(_ ([(id ...) expr] @@ -151,7 +160,7 @@ #'expr) (syntax-parameter-value #'mutator-env-roots))] [mutator-tail-call? #f]) - expr)] + (no! expr))] ...) (let-values ([(id ...) (values tmp ...)] ...) @@ -196,7 +205,7 @@ #'body) (list #'free-id ...))] [mutator-tail-call? #t]) - (->address body)))]) + (->address (no! body))))]) closure))]) #,(if (syntax-parameter-value #'mutator-tail-call?) (syntax/loc stx @@ -216,6 +225,8 @@ (local [(define (do-not-expand? exp) (and (identifier? exp) (or (free-identifier=? exp #'empty) + (free-identifier=? exp #'collector:set-first!) + (free-identifier=? exp #'collector:set-rest!) (ormap (λ (x) (free-identifier=? x exp)) prim-ids)))) (define exps (syntax->list #'(e ...))) @@ -238,6 +249,12 @@ (let () (define prim-app? (ormap (λ (x) (free-identifier=? x #'fe)) prim-ids)) + (define is-set-fst? (free-identifier=? #'collector:set-first! #'fe)) + (when (or is-set-fst? (free-identifier=? #'collector:set-rest! #'fe)) + (unless (syntax-parameter-value #'mutator-assignment-allowed?) + (raise-syntax-error (if is-set-fst? 'set-first! 'set-rest!) + "can appear only at the top-level or in a begin" + stx))) (with-syntax ([(env-id ...) (syntax-parameter-value #'mutator-env-roots)] [app-exp (if prim-app? (syntax/loc stx (collector:alloc-flat (fe (collector:deref ae) ...))) @@ -440,14 +457,24 @@ (gc->scheme l)))) (provide (rename-out (mutator-set-first! set-first!))) -(define (mutator-set-first! x y) - (collector:set-first! x y) - (void)) +(define-syntax (mutator-set-first! stx) + (syntax-case stx () + [x + (identifier? #'x) + (raise-syntax-error 'set-first! "must appear immediately following an open paren" stx)] + [(_ args ...) + (begin + #'(mutator-app collector:set-first! args ...))])) (provide (rename-out (mutator-set-rest! set-rest!))) -(define (mutator-set-rest! x y) - (collector:set-rest! x y) - (void)) +(define-syntax (mutator-set-rest! stx) + (syntax-case stx () + [x + (identifier? #'x) + (raise-syntax-error 'set-rest! "must appear immediately following an open paren" stx)] + [(_ args ...) + (begin + #'(mutator-app collector:set-rest! args ...))])) (provide (rename-out [mutator-empty empty])) (define-syntax mutator-empty diff --git a/collects/tests/plai/gc2/set-restriction-test.rkt b/collects/tests/plai/gc2/set-restriction-test.rkt new file mode 100644 index 0000000000..932ba18654 --- /dev/null +++ b/collects/tests/plai/gc2/set-restriction-test.rkt @@ -0,0 +1,60 @@ +#lang racket + +(define-syntax (test stx) + (syntax-case stx () + [(_ exp reg) + (with-syntax ([line (syntax-line stx)]) + #'(test/proc line 'exp reg))])) + +(define ns (make-base-namespace)) +(define tests 0) +(define failed 0) +(define (test/proc line exp reg) + (set! tests (+ tests 1)) + (define err + (with-handlers (((λ (x) + (and (exn:fail:syntax? x) + reg + (let ([m (exn-message x)]) + (regexp-match? reg m)))) + exn-message)) + (parameterize ([current-namespace ns]) + (expand + `(,#'module m plai/gc2/mutator + (allocator-setup "good-collectors/trivial-collector.rkt" 200) + (define x '(1)) + ,exp)) + #f))) + (unless (or (and reg err) + (and (not reg) (not err))) + (set! failed (+ failed 1)) + (eprintf "test on line ~a failed:\n ~s\n expected ~a, got ~a\n" + line + exp + (if reg (format "a syntax error matching ~a" reg) "no error") + (or err "no error")))) + + +(test (+ (set! x 2) 1) #rx"set!") +(test (cons (set! x 3) empty) #rx"set!") +(test (set! x 2) #f) +(test (set! x (set! x 2)) #rx"set!") +(test (begin (begin (set! x 2) 1) 2) #f) +(test (λ () (set! x 1)) #rx"set!") +(test (λ () (set! x 1) 2) #f) +(test (let ([y (begin 1 (set! x 2))]) 1) #rx"set!") +(test (let ([y 2]) (begin 1 (set! x 2))) #f) +(test (+ (set-first! x 2) 3) #rx"set-first!") +(test (begin (set-first! x 2) 3) #f) +(test (+ (set-rest! x 2) 3) #rx"set-rest!") +(test (begin (set-rest! x 2) 3) #f) +(test set-first! #rx"set-first!") +(test set-rest! #rx"set-rest!") +(test (if (set! x 1) 2 3) #rx"set!") +(test (if 1 (set! x 2) (set! x 3)) #f) + +(cond + [(zero? failed) + (printf "passed ~a tests\n" tests)] + [else + (eprintf "failed ~a test~a\n" failed (if (= 1 failed) "" "s"))])