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

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

@ -222,7 +222,12 @@
;; At the top level, wrap `defn' to first check for
;; existing definitions of the `names'. The `names'
;; 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
[(eq? (syntax-local-context) 'top-level)
(with-syntax ([defn defn]
@ -235,14 +240,19 @@
;; expression:
(syntax/loc stx
(check-top-level-not-defined 'who #'name))))
(stx->list names))])
;; this use of stepper-ignore-checker will behave badly on multiple-name defines:
(stepper-ignore-checker
names)])
(syntax-property
(syntax/loc stx
(begin
check ...
defn)))))]
[(eq? (syntax-local-context) 'module)
defn))
'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)
(let ([b (identifier-binding name)])
(when b
@ -254,12 +264,22 @@
"this name was defined previously and cannot be re-defined"
"this name has a built-in meaning and cannot be re-defined")))))
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]))
;; Same as above, but for one name
(define (check-definition-new who stx name defn)
(check-definitions-new who stx (list name) defn))
(define (check-definition-new who stx name defn assign)
(check-definitions-new who stx (list name) defn assign))
;; Check context for a `define' before even trying to
;; expand
@ -352,7 +372,7 @@
(define (wrap-func-definitions first-order? kinds names argcs k)
(if first-order?
(let ([name2s (map (make-name-inventer) names)])
(quasisyntax
(values (quasisyntax
(begin
#,@(map
(lambda (name name2 kind argc)
@ -362,15 +382,17 @@
(quote-syntax #,name2)
(quote-syntax #%app))))
names name2s kinds argcs)
#,(k name2s))))
(k names)))
#,(k name2s)))
name2s))
(values (k names)
names)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)
(wrap-func-definitions first-order?
@ -407,10 +429,7 @@
[(beginner-lambda arg-seq lexpr ...)
(begin
(check-function-defn-ok stx)
(check-definition-new
'define
stx
#'name
(let-values ([(defn bind-names)
(wrap-func-definition
#'name
(length (syntax->list #'arg-seq))
@ -420,16 +439,26 @@
stx
(define name
#,(syntax-property
#`(lambda arg-seq #,(syntax-property #`make-lambda-generative 'stepper-skip-completely #t) lexpr ...)
#`(lambda arg-seq
#,(syntax-property #`make-lambda-generative
'stepper-skip-completely #t)
lexpr ...)
'stepper-define-type
'lambda-define))))))))]
'lambda-define))))))])
(check-definition-new
'define
stx
#'name
defn
(and assign? bind-names))))]
;; Constant def
[_else
(check-definition-new
'define
stx
(syntax name)
(quasisyntax/loc stx (define name expr)))]))]
(quasisyntax/loc stx (define name expr))
(and assign? (list (syntax name))))]))]
;; Function definition:
[(_ name-seq expr ...)
(syntax-case (syntax name-seq) () [(name ...) #t][_else #f])
@ -476,10 +505,7 @@
;; not all top-level defns are ready:
#f)
(check-definition-new
'define
stx
(car names)
(let-values ([(defn bind-names)
(wrap-func-definition
(car (syntax-e #'name-seq))
(length (cdr (syntax->list #'name-seq)))
@ -492,7 +518,13 @@
'stepper-define-type
'shortened-proc-define)
'stepper-proc-define-name
#`fn))))))))]
#`fn))))))])
(check-definition-new
'define
stx
(car names)
defn
(and assign? bind-names))))]
;; Constant/lambda with too many or too few parts:
[(_ name expr ...)
(identifier/non-kw? (syntax name))
@ -525,10 +557,10 @@
(bad-use-error 'define stx)]))
(define (beginner-define/proc stx)
(beginner-or-intermediate-define/proc #t stx))
(define/proc #t #f stx))
(define (intermediate-define/proc stx)
(beginner-or-intermediate-define/proc #f stx))
(define/proc #f #f stx))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; lambda (beginner; only works with define)
@ -672,13 +704,8 @@
#f
"expected an expression, but found a structure name"
stx))))])
(let ([defn
(quasisyntax/loc stx
(begin
#,(syntax-property #`(define-syntaxes (name_) compile-info)
'stepper-skip-completely
#t)
#,(wrap-func-definitions
(let-values ([(defn0 bind-names)
(wrap-func-definitions
first-order?
(list* 'constructor
'predicate
@ -695,11 +722,19 @@
(define-struct name_ (field_ ...) (make-inspector))
(values proc-name ...)))
'stepper-define-struct-hint
stx))))))])
stx))))])
(let ([defn
(quasisyntax/loc stx
(begin
#,(syntax-property #`(define-syntaxes (name_) compile-info)
'stepper-skip-completely
#t)
#,defn0))])
(check-definitions-new 'define-struct
stx
(cons #'name_ to-define-names)
defn)))))]
defn
(and setters? bind-names)))))))]
[(_ name_ something . rest)
(teach-syntax-error
'define-struct
@ -1664,7 +1699,8 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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 ()
[(_ (name) expr)
(and (identifier/non-kw? (syntax name))
@ -1673,19 +1709,20 @@
'define
stx
(syntax name)
(syntax/loc stx (define (name) expr)))]
(syntax/loc stx (define (name) expr))
(list #'name))]
[(_ (name) expr ...)
(check-single-result-expr (syntax->list (syntax (expr ...)))
#f
stx
(list #'name))]
[(_ . rest)
;; Call transformer beginner-define/proc.
;; Call transformer define/proc.
;; 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
;; report `advanced-define' as the source.
(intermediate-define/proc stx)]
(define/proc #f #t stx)]
[_else
(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 #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")
(define x 10))
(define x 10)
(define (f y) f)
(define-struct s (x y)))
(require 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)))
;; ----------------------------------------