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

fix acc/mut error msgs from `define-struct' in teaching languages

Browse Source 
Merge to 5.0.1
 Closes PR 11062
This commit is contained in:
Matthew Flatt 2010-07-30 11:04:50 -06:00
parent 14de7399bd
commit 0e8af6bc5d
3 changed files with 32 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/lang/private/teach.rkt
View File

@ -116,13 +116,13 @@
(define-for-syntax (stepper-ignore-checker stx) (define-for-syntax (stepper-ignore-checker stx)
(stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car))) (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car)))
(define-for-syntax (map-with-index proc list) (define-for-syntax (map-with-index proc . lists)
(let loop ([i 0] [list list] [rev-result '()]) (let loop ([i 0] [lists lists] [rev-result '()])
(if (null? list) (if (null? (car lists))
(reverse rev-result) (reverse rev-result)
(loop (+ 1 i) (loop (+ 1 i)
(cdr list) (map cdr lists)
(cons (proc i (car list)) rev-result))))) (cons (apply proc i (map car lists)) rev-result)))))
;; build-struct-names is hard to handle ;; build-struct-names is hard to handle
(define-for-syntax (make-struct-names name fields stx) (define-for-syntax (make-struct-names name fields stx)
@ -855,16 +855,28 @@
;; give `check-struct-wraps!' access ;; give `check-struct-wraps!' access
(make-inspector))) (make-inspector)))
#,@(map-with-index (lambda (i name) #,@(map-with-index (lambda (i name field-name)
#`(define (#,name r) #`(define #,name
(raw-generic-access r #,i) ; error checking (let ([raw (make-struct-field-accessor
raw-generic-access
#,i
'#,field-name)])
(lambda (r)
(raw r) ; error checking
(check-struct-wraps! r) (check-struct-wraps! r)
(raw-generic-access r #,i))) (raw r)))))
getter-names) getter-names
#,@(map-with-index (lambda (i name) fields)
#`(define (#,name r v) #,@(map-with-index (lambda (i name field-name)
(raw-generic-mutate r #,i v))) #`(define #,name
setter-names) (let ([raw (make-struct-field-mutator
raw-generic-mutate
#,i
'#,field-name)])
(lambda (r v)
(raw r v)))))
setter-names
fields)
(define #,predicate-name raw-predicate) (define #,predicate-name raw-predicate)
(define #,constructor-name raw-constructor) (define #,constructor-name raw-constructor)

4
collects/tests/racket/advanced.rktl
View File

@ -285,6 +285,10 @@
(htdp-test #t 'hash-eqv? (htdp-test #t 'hash-eqv?
(hash-eqv? (make-hasheqv (list (list 'a 1))))) (hash-eqv? (make-hasheqv (list (list 'a 1)))))
;; Check set...! error message:
(htdp-top (define-struct a1 (b)))
(htdp-err/rt-test (set-a1-b! 1 2) #rx"set-a1-b!")
(htdp-top-pop 1)
;; Simulate set! in the repl ;; Simulate set! in the repl
(module my-advanced-module (lib "htdp-advanced.rkt" "lang") (module my-advanced-module (lib "htdp-advanced.rkt" "lang")

1
collects/tests/racket/beg-adv.rktl
View File

@ -77,6 +77,7 @@
(htdp-test #t 'a3? (a3? (make-a3 1 2 3))) (htdp-test #t 'a3? (a3? (make-a3 1 2 3)))
(htdp-test #f 'a1? (a1? (make-a3 1 2 3))) (htdp-test #f 'a1? (a1? (make-a3 1 2 3)))
(htdp-test #f 'a3? (a3? (make-a1 1))) (htdp-test #f 'a3? (a3? (make-a1 1)))
(htdp-err/rt-test (a1-b 10) #rx"a1-b")
(htdp-syntax-test #'cond) (htdp-syntax-test #'cond)
(htdp-syntax-test #'(cond)) (htdp-syntax-test #'(cond))