[racket-dev] Closes PR 11062

Robby, this fix does NOT change the problematic coverage of structures. Fields are still colored as if they had never been evaluated. 


On Jul 30, 2010, at 1:16 PM, mflatt at racket-lang.org wrote:

> mflatt has updated `master' from 14de7399bd to 0e8af6bc5d.
>  http://git.racket-lang.org/plt/14de7399bd..0e8af6bc5d
> 
> =====[ 1 Commits ]======================================================
> 
> Directory summary:
>  93.3% collects/lang/private/
>   6.6% collects/tests/racket/
> 
> ~~~~~~~~~~
> 
> 0e8af6b Matthew Flatt <mflatt at racket-lang.org> 2010-07-30 11:04
> :
> | fix acc/mut error msgs from `define-struct' in teaching languages
> |  Merge to 5.0.1
> |  Closes PR 11062
> :
>  M collects/lang/private/teach.rkt     |   42 ++++++++++++++++++++-----------
>  M collects/tests/racket/advanced.rktl |    4 +++
>  M collects/tests/racket/beg-adv.rktl  |    1 +
> 
> =====[ Overall Diff ]===================================================
> 
> collects/lang/private/teach.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/lang/private/teach.rkt
> +++ NEW/collects/lang/private/teach.rkt
> @@ -116,13 +116,13 @@
>   (define-for-syntax (stepper-ignore-checker stx)
>     (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car)))
> 
> -  (define-for-syntax (map-with-index proc list)
> -    (let loop ([i 0] [list list] [rev-result '()])
> -      (if (null? list)
> +  (define-for-syntax (map-with-index proc . lists)
> +    (let loop ([i 0] [lists lists] [rev-result '()])
> +      (if (null? (car lists))
> 	  (reverse rev-result)
> 	  (loop (+ 1 i)
> -		(cdr list)
> -		(cons (proc i (car list)) rev-result)))))
> +		(map cdr lists)
> +		(cons (apply proc i (map car lists)) rev-result)))))
> 
>   ;; build-struct-names is hard to handle
>   (define-for-syntax (make-struct-names name fields stx)
> @@ -855,16 +855,28 @@
> 							       ;; give `check-struct-wraps!' access
> 							       (make-inspector)))
> 
> -					   #,@(map-with-index (lambda (i name)
> -								#`(define (#,name r)
> -								    (raw-generic-access r #,i) ; error checking
> -								    (check-struct-wraps! r)
> -								    (raw-generic-access r #,i)))
> -							      getter-names)
> -					   #,@(map-with-index (lambda (i name)
> -								#`(define (#,name r v)
> -								    (raw-generic-mutate r #,i v)))
> -							      setter-names)
> +					   #,@(map-with-index (lambda (i name field-name)
> +								#`(define #,name
> +                                                                    (let ([raw (make-struct-field-accessor
> +                                                                                raw-generic-access
> +                                                                                #,i
> +                                                                                '#,field-name)])
> +                                                                      (lambda (r)
> +                                                                        (raw r) ; error checking
> +                                                                        (check-struct-wraps! r)
> +                                                                        (raw r)))))
> +							      getter-names
> +                                                              fields)
> +					   #,@(map-with-index (lambda (i name field-name)
> +								#`(define #,name 
> +                                                                    (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 #,constructor-name raw-constructor)
> 
> 
> collects/tests/racket/advanced.rktl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/racket/advanced.rktl
> +++ NEW/collects/tests/racket/advanced.rktl
> @@ -285,6 +285,10 @@
> (htdp-test #t 'hash-eqv?
>            (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
> (module my-advanced-module (lib "htdp-advanced.rkt" "lang")
> 
> collects/tests/racket/beg-adv.rktl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/tests/racket/beg-adv.rktl
> +++ NEW/collects/tests/racket/beg-adv.rktl
> @@ -77,6 +77,7 @@
> (htdp-test #t 'a3? (a3? (make-a3 1 2 3)))
> (htdp-test #f 'a1? (a1? (make-a3 1 2 3)))
> (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))