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

make defined names always mutable in HtDP advanced

Browse Source 
svn: r4672
This commit is contained in:
Matthew Flatt 2006-10-23 07:05:21 +00:00
parent 1a81d0c5c5
commit a8465ee701
2 changed files with 132 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

207
collects/lang/private/teach.ss
View File

@ -220,9 +220,14 @@
(format "~ard" n)])) (format "~ard" n)]))
;; At the top level, wrap `defn' to first check for ;; At the top level, wrap `defn' to first check for
;; existing definitions of the `names'. The `names' ;; existing definitions of the `names'. The `names'
;; argument is a syntax list of identifiers. ;; argument is a syntax list of identifiers.
(define (check-definitions-new who stx names defn) ;; In a module context, just check the binding
;; at compile time.
;; In either context, if `assign?' is true, then
;; generate an unevaluated assignment that makes
;; the identifier mutable.
(define (check-definitions-new who stx names defn assign)
(cond (cond
[(eq? (syntax-local-context) 'top-level) [(eq? (syntax-local-context) 'top-level)
(with-syntax ([defn defn] (with-syntax ([defn defn]
@ -230,19 +235,24 @@
(with-syntax ([(check ...) (with-syntax ([(check ...)
(map (lambda (name) (map (lambda (name)
(with-syntax ([name name]) (with-syntax ([name name])
;; Make sure each check has the ;; Make sure each check has the
;; source location of the original ;; source location of the original
;; expression: ;; expression:
(syntax/loc stx (syntax/loc stx
(check-top-level-not-defined 'who #'name)))) (check-top-level-not-defined 'who #'name))))
(stx->list names))]) names)])
;; this use of stepper-ignore-checker will behave badly on multiple-name defines: (syntax-property
(stepper-ignore-checker
(syntax/loc stx (syntax/loc stx
(begin (begin
check ... check ...
defn)))))] defn))
[(eq? (syntax-local-context) 'module) 'stepper-skipto
(cons 'syntax-e
(let loop ([l names])
(if (null? l)
`(syntax-e cdr car)
(cons 'cdr (loop (cdr l)))))))))]
[(memq (syntax-local-context) '(module module-begin))
(for-each (lambda (name) (for-each (lambda (name)
(let ([b (identifier-binding name)]) (let ([b (identifier-binding name)])
(when b (when b
@ -254,12 +264,22 @@
"this name was defined previously and cannot be re-defined" "this name was defined previously and cannot be re-defined"
"this name has a built-in meaning and cannot be re-defined"))))) "this name has a built-in meaning and cannot be re-defined")))))
names) names)
defn] (if assign
(with-syntax ([(name ...) (if (eq? assign #t)
names
assign)]
[defn defn])
(stepper-ignore-checker
(syntax/loc stx
(begin
(lambda () (advanced-set! name 10) ...)
defn))))
defn)]
[else defn])) [else defn]))
;; Same as above, but for one name ;; Same as above, but for one name
(define (check-definition-new who stx name defn) (define (check-definition-new who stx name defn assign)
(check-definitions-new who stx (list name) defn)) (check-definitions-new who stx (list name) defn assign))
;; Check context for a `define' before even trying to ;; Check context for a `define' before even trying to
;; expand ;; expand
@ -352,25 +372,27 @@
(define (wrap-func-definitions first-order? kinds names argcs k) (define (wrap-func-definitions first-order? kinds names argcs k)
(if first-order? (if first-order?
(let ([name2s (map (make-name-inventer) names)]) (let ([name2s (map (make-name-inventer) names)])
(quasisyntax (values (quasisyntax
(begin (begin
#,@(map #,@(map
(lambda (name name2 kind argc) (lambda (name name2 kind argc)
#`(define-syntax #,name #`(define-syntax #,name
(make-first-order-function '#,kind (make-first-order-function '#,kind
#,argc #,argc
(quote-syntax #,name2) (quote-syntax #,name2)
(quote-syntax #%app)))) (quote-syntax #%app))))
names name2s kinds argcs) names name2s kinds argcs)
#,(k name2s)))) #,(k name2s)))
(k names))) name2s))
(values (k names)
names)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; define (beginner) ;; define (beginner)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (beginner-or-intermediate-define/proc first-order? stx) (define (define/proc first-order? assign? stx)
(define (wrap-func-definition name argc k) (define (wrap-func-definition name argc k)
(wrap-func-definitions first-order? (wrap-func-definitions first-order?
@ -405,31 +427,38 @@
(syntax-case (syntax expr) (beginner-lambda) (syntax-case (syntax expr) (beginner-lambda)
;; Well-formed lambda def: ;; Well-formed lambda def:
[(beginner-lambda arg-seq lexpr ...) [(beginner-lambda arg-seq lexpr ...)
(begin (begin
(check-function-defn-ok stx) (check-function-defn-ok stx)
(check-definition-new (let-values ([(defn bind-names)
'define (wrap-func-definition
stx #'name
#'name (length (syntax->list #'arg-seq))
(wrap-func-definition (lambda (name)
#'name (with-syntax ([name name])
(length (syntax->list #'arg-seq)) (quasisyntax/loc
(lambda (name) stx
(with-syntax ([name name]) (define name
(quasisyntax/loc #,(syntax-property
stx #`(lambda arg-seq
(define name #,(syntax-property #`make-lambda-generative
#,(syntax-property 'stepper-skip-completely #t)
#`(lambda arg-seq #,(syntax-property #`make-lambda-generative 'stepper-skip-completely #t) lexpr ...) lexpr ...)
'stepper-define-type 'stepper-define-type
'lambda-define))))))))] 'lambda-define))))))])
(check-definition-new
'define
stx
#'name
defn
(and assign? bind-names))))]
;; Constant def ;; Constant def
[_else [_else
(check-definition-new (check-definition-new
'define 'define
stx stx
(syntax name) (syntax name)
(quasisyntax/loc stx (define name expr)))]))] (quasisyntax/loc stx (define name expr))
(and assign? (list (syntax name))))]))]
;; Function definition: ;; Function definition:
[(_ name-seq expr ...) [(_ name-seq expr ...)
(syntax-case (syntax name-seq) () [(name ...) #t][_else #f]) (syntax-case (syntax name-seq) () [(name ...) #t][_else #f])
@ -475,24 +504,27 @@
;; can't local-expand function body, because ;; can't local-expand function body, because
;; not all top-level defns are ready: ;; not all top-level defns are ready:
#f) #f)
(check-definition-new (let-values ([(defn bind-names)
'define (wrap-func-definition
stx (car (syntax-e #'name-seq))
(car names) (length (cdr (syntax->list #'name-seq)))
(wrap-func-definition (lambda (fn)
(car (syntax-e #'name-seq)) (with-syntax ([fn fn]
(length (cdr (syntax->list #'name-seq))) [args (cdr (syntax-e #'name-seq))])
(lambda (fn) (quasisyntax/loc stx (define fn #,(syntax-property
(with-syntax ([fn fn] (syntax-property
[args (cdr (syntax-e #'name-seq))]) #`(lambda args expr ...)
(quasisyntax/loc stx (define fn #,(syntax-property 'stepper-define-type
(syntax-property 'shortened-proc-define)
#`(lambda args expr ...) 'stepper-proc-define-name
'stepper-define-type #`fn))))))])
'shortened-proc-define) (check-definition-new
'stepper-proc-define-name 'define
#`fn))))))))] stx
(car names)
defn
(and assign? bind-names))))]
;; Constant/lambda with too many or too few parts: ;; Constant/lambda with too many or too few parts:
[(_ name expr ...) [(_ name expr ...)
(identifier/non-kw? (syntax name)) (identifier/non-kw? (syntax name))
@ -525,10 +557,10 @@
(bad-use-error 'define stx)])) (bad-use-error 'define stx)]))
(define (beginner-define/proc stx) (define (beginner-define/proc stx)
(beginner-or-intermediate-define/proc #t stx)) (define/proc #t #f stx))
(define (intermediate-define/proc stx) (define (intermediate-define/proc stx)
(beginner-or-intermediate-define/proc #f stx)) (define/proc #f #f stx))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; lambda (beginner; only works with define) ;; lambda (beginner; only works with define)
@ -672,13 +704,8 @@
#f #f
"expected an expression, but found a structure name" "expected an expression, but found a structure name"
stx))))]) stx))))])
(let ([defn (let-values ([(defn0 bind-names)
(quasisyntax/loc stx (wrap-func-definitions
(begin
#,(syntax-property #`(define-syntaxes (name_) compile-info)
'stepper-skip-completely
#t)
#,(wrap-func-definitions
first-order? first-order?
(list* 'constructor (list* 'constructor
'predicate 'predicate
@ -695,11 +722,19 @@
(define-struct name_ (field_ ...) (make-inspector)) (define-struct name_ (field_ ...) (make-inspector))
(values proc-name ...))) (values proc-name ...)))
'stepper-define-struct-hint 'stepper-define-struct-hint
stx))))))]) stx))))])
(check-definitions-new 'define-struct (let ([defn
stx (quasisyntax/loc stx
(cons #'name_ to-define-names) (begin
defn)))))] #,(syntax-property #`(define-syntaxes (name_) compile-info)
'stepper-skip-completely
#t)
#,defn0))])
(check-definitions-new 'define-struct
stx
(cons #'name_ to-define-names)
defn
(and setters? bind-names)))))))]
[(_ name_ something . rest) [(_ name_ something . rest)
(teach-syntax-error (teach-syntax-error
'define-struct 'define-struct
@ -1664,7 +1699,8 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (advanced-define/proc stx) (define (advanced-define/proc stx)
;; Handle the case that doesn't fit into beginner, then dispatch to beginner ;; Handle the case that doesn't fit into intermediate, then dispatch to
;; the common code that it also used by beginner/intermediate.
(syntax-case stx () (syntax-case stx ()
[(_ (name) expr) [(_ (name) expr)
(and (identifier/non-kw? (syntax name)) (and (identifier/non-kw? (syntax name))
@ -1673,19 +1709,20 @@
'define 'define
stx stx
(syntax name) (syntax name)
(syntax/loc stx (define (name) expr)))] (syntax/loc stx (define (name) expr))
(list #'name))]
[(_ (name) expr ...) [(_ (name) expr ...)
(check-single-result-expr (syntax->list (syntax (expr ...))) (check-single-result-expr (syntax->list (syntax (expr ...)))
#f #f
stx stx
(list #'name))] (list #'name))]
[(_ . rest) [(_ . rest)
;; Call transformer beginner-define/proc. ;; Call transformer define/proc.
;; Note that we call the transformer instead of producing ;; Note that we call the transformer instead of producing
;; new syntax object that is a `beginner-define' form; ;; new syntax object that is an `intermediate-define' form;
;; that's important for syntax errors, so that they ;; that's important for syntax errors, so that they
;; report `advanced-define' as the source. ;; report `advanced-define' as the source.
(intermediate-define/proc stx)] (define/proc #f #t stx)]
[_else [_else
(bad-use-error 'define stx)])) (bad-use-error 'define stx)]))

15
collects/tests/mzscheme/advanced.ss
View File

@ -201,14 +201,19 @@
(htdp-test #t 'equal~? (equal~? (box (list 10)) (box (list 10.02)) 0.1)) (htdp-test #t 'equal~? (equal~? (box (list 10)) (box (list 10.02)) 0.1))
(htdp-test #f 'equal~? (equal~? (box (list 10)) (box (list 10.2)) 0.1)) (htdp-test #f 'equal~? (equal~? (box (list 10)) (box (list 10.2)) 0.1))
;; Simulate set! in the repl? ;; Simulate set! in the repl
#|
(module my-advanced-module (lib "htdp-advanced.ss" "lang") (module my-advanced-module (lib "htdp-advanced.ss" "lang")
(define x 10)) (define x 10)
(define (f y) f)
(define-struct s (x y)))
(require my-advanced-module) (require my-advanced-module)
(parameterize ([current-namespace (module->namespace 'my-advanced-module)]) (parameterize ([current-namespace (module->namespace 'my-advanced-module)])
(eval #'(set! x 12))) (eval #'(set! x 12))
|# (eval #'(set! f 12))
(eval #'(set! make-s 12))
(eval #'(set! s-x 12))
(eval #'(set! s? 12))
(eval #'(set! set-s-x! 12)))
;; ---------------------------------------- ;; ----------------------------------------