make assignment-before-initialization an error

Recent changes made use-before-initialization an error for
`letrec` bindings, `class` fields, and `unit` definitions.
Now, assignment-before-initialization is also an error.

pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl

@@ -18,7 +18,7 @@ raised instead of producing an @racket[undefined] value.
 
 The @racket[unsafe-undefined] value is always @racket[eq?] to itself.
 
-@history[#:added "6.0.0.6"]
+@history[#:added "6.0.1.2"]
 
 @defthing[unsafe-undefined any/c]{
 
@@ -30,15 +30,27 @@ The unsafe ``undefined'' constant.}
 
 Checks whether @racket[v] is @racket[unsafe-undefined], and raises
 @racket[exn:fail:contract:variable] in that case with an error message
-along the lines of ``@racket[sym]: variable used before its
+along the lines of ``@racket[sym]: undefined; use before
-definition.''  If @racket[v] is not @racket[unsafe-undefined], then
+initialization.''  If @racket[v] is not @racket[unsafe-undefined],
-@racket[v] is returned.}
+then @racket[v] is returned.}
+
+@defproc[(check-not-unsafe-undefined/assign [v any/c] [sym symbol?])
+         (and/c any/c (not/c (one-of/c unsafe-undefined)))]{
+
+The same as @racket[check-not-unsafe-undefined], except that the error
+message (if any) is along the lines of ``@racket[sym]: undefined;
+assignment before initialization.''}
+
 
 @defthing[prop:chaperone-unsafe-undefined struct-type-property?]{
 
 A @tech{structure type property} that causes a structure type's
-constructor to produce a @tech{chaperone} of an instance where every
+constructor to produce a @tech{chaperone} of an instance. Every access
-access of a field in the structure is checked to prevent returning
+
+of a field in the structure is checked to prevent returning
+@racket[unsafe-undefined]. Similarly, every assignment to a field in
+the structure is checked (unless the check disabled as described
+below) to prevent assignment of a field whose current value is
 @racket[unsafe-undefined].
 
 The property value should be a list of symbols used as field names,
@@ -46,4 +58,12 @@ but the list should be in reverse order of the structure's fields.
 When a field access would otherwise produce @racket[unsafe-undefined],
 the @racket[exn:fail:contract:variable] exception is raised if a field
 name is provided by the structure property's value, otherwise the
-@racket[exn:fail:contract] exception is raised.}
+@racket[exn:fail:contract] exception is raised.
+
+The chaperone's field-assignment check is disabled whenever
+@racket[(continuation-mark-set-first #f
+prop:chaperone-unsafe-undefined)] returns @racket[unsafe-undefined].
+Thus, a field-initializing assignment---one that is intended to replace the
+@racket[unsafe-undefined] value of a field---should be wrapped with
+@racket[(with-continuation-mark prop:chaperone-unsafe-undefined
+unsafe-undefined ....)].}

pkgs/racket-pkgs/racket-test/tests/racket/object.rktl

@@ -1937,6 +1937,11 @@
       (define z z)
       (super-new)))
 
+  (define d!%
+    (class c%
+      (define z (set! z 0))
+      (super-new)))
+
   (define e%
     (class d%
       (define q 1)
@@ -1958,6 +1963,9 @@
   (err/rt-test (new d%) (lambda (exn)
                           (and (exn:fail:contract:variable? exn)
                                (eq? 'z (exn:fail:contract:variable-id exn)))))
+  (err/rt-test (new d!%) (lambda (exn)
+                           (and (exn:fail:contract:variable? exn)
+                                (eq? 'z (exn:fail:contract:variable-id exn)))))
   (err/rt-test (new e%) (lambda (exn)
                           (and (exn:fail:contract:variable? exn)
                                (eq? 'z (exn:fail:contract:variable-id exn)))))
@@ -2003,6 +2011,7 @@
   (check-opt '(class object% (init-field [x 1]) (super-new)) #t)
   (check-opt '(class object% (define x (+ 1 2))) #t)
   (check-opt '(class object% (define x (free-var 1))) #t)
+  (check-opt '(class object% (set! y 7) (define x 2) (define y 1) (super-new)) #f)
 
   (check-opt '(class object% (define x x)) #f)
   (check-opt '(class object% (field [x x])) #f)
@@ -2030,11 +2039,7 @@
   (check-opt '(class object% (inherit-field f) (super-new) (displayln f)) #t)
   (check-opt '(class object% (inherit-field f) (displayln f) (super-new)) #f)
   (check-opt '(class object% (inherit-field f) (set! f 10) (super-new)) #t)
-
+  (check-opt '(class object% (inherit-field f) (when ? (super-new)) (displayln f)) #f)
-  ;; Ok to use after explicit assignment that's before the decl:
-  (check-opt '(class object% (set! y 7) (define x y) (define y 1) (super-new)) #t)
-  ;; But not in a branch
-  (check-opt '(class object% (when ? (set! y 7)) (define x y) (define y 1) (super-new)) #f)
   
   (void))
 

pkgs/racket-pkgs/racket-test/tests/racket/syntax.rktl

@@ -89,6 +89,7 @@
 (test 10 add4 6)
 (err/rt-test (let ([x (lambda () (define d d) d)]) (x)) exn:fail:contract:variable?)
 (err/rt-test ((lambda () (define d d) d)) exn:fail:contract:variable?)
+(err/rt-test ((lambda () (define d (set! d #f)) d)) exn:fail:contract:variable?)
 (test '(3 4 5 6) (lambda x x) 3 4 5 6)
 (test '(5 6) (lambda (x y . z) z) 3 4 5 6)
 (test 'second (lambda () (cons 'first 2) 'second))
@@ -645,6 +646,8 @@
 
 (err/rt-test (letrec-values ([(a b c) (values 1 a b)]) (list a b c))
               exn:fail:contract:variable?)
+(err/rt-test (letrec-values ([(a b c) (values (set! a 0) a b)]) (list a b c))
+              exn:fail:contract:variable?)
 
 (test '(10 11) 'letrec-values (letrec-values ([(names kps)
 					       (letrec ([oloop 10])

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt

@@ -2719,6 +2719,7 @@
 
 ;; Section 17.4 (Unsafe Undefined)
 [check-not-unsafe-undefined (-poly (a) (-> a -Symbol a))]
+[check-not-unsafe-undefined/assign (-poly (a) (-> a -Symbol a))]
 
 ;; Section 18.2 (Libraries and Collections)
 [find-library-collection-paths (->opt [(-lst -Pathlike) (-lst -Pathlike)] (-lst -Path))]

racket/collects/racket/private/class-internal.rkt

@@ -1195,9 +1195,20 @@
                                           [(d-v (id ...) expr)
                                            (and (identifier? #'d-v)
                                                 (free-identifier=? #'d-v #'define-values))
-                                           (syntax-track-origin (syntax/loc e (set!-values (id ...) expr))
+                                           (let* ([ids (syntax->list #'(id ...))]
-                                                                e
+                                                  [assignment
-                                                                #'d-v)]
+                                                   (if (= 1 (length ids))
+                                                       ;; Special-case single variable in case the RHS
+                                                       ;; uses the name:
+                                                       (syntax/loc e
+                                                         (set! id ... (field-initialization-value expr)))
+                                                       ;; General case:
+                                                       (with-syntax ([(temp ...) (generate-temporaries ids)])
+                                                         (syntax/loc e
+                                                           (let-values ([(temp ...) expr])
+                                                             (set! id (field-initialization-value temp))
+                                                             ...))))])
+                                             (syntax-track-origin assignment e #'d-v))]
                                           [(_init orig idp ...)
                                            (and (identifier? (syntax _init))
                                                 (ormap (lambda (it) 
@@ -1217,11 +1228,14 @@
                                                                        (with-syntax ([defexp (stx-car (stx-cdr norm))])
                                                                          (syntax (lambda () defexp)))))
                                                                  norms)]
-                                                           [class-name class-name])
+                                                           [class-name class-name]
+                                                           [wrapper (if (free-identifier=? #'_init #'-init-field)
+                                                                        #'field-initialization-value
+                                                                        #'begin)])
                                                (syntax-track-origin
                                                 (syntax/loc e 
                                                   (begin
-                                                    (set! id (extract-arg 'class-name `idpos init-args defval))
+                                                    (set! id (wrapper (extract-arg 'class-name `idpos init-args defval)))
                                                     ...))
                                                 e
                                                 #'_init)))]
@@ -1232,7 +1246,7 @@
                                                           (map normalize-init/field (syntax->list #'(idp ...)))])
                                              (syntax-track-origin
                                               (syntax/loc e (begin 
-                                                              (set! iid expr)
+                                                              (set! iid (field-initialization-value expr))
                                                               ...))
                                               e
                                               #'-fld))]

racket/collects/racket/private/class-undef.rkt

@@ -4,24 +4,32 @@
                      syntax/kerncase))
 
 (provide declare-field-use-start
-         declare-field-assignment
+         declare-field-initialization
          declare-field-use
          declare-inherit-use
+         declare-field-assignment
          declare-this-escapes
          declare-super-new
 
+         field-initialization-value
+         
          detect-field-unsafe-undefined)
 
 ;; The `class` macros inject declarations into expansions
 ;; of the form `(begin (_declare-word _id ...) _expr ...)`
 ;; for each of the following `_declare-word`s:
 (define-syntax declare-field-use-start #f) ; marks start of initialization
-(define-syntax declare-field-assignment #f)
+(define-syntax declare-field-initialization #f)
 (define-syntax declare-field-use #f)
 (define-syntax declare-inherit-use #f)
+(define-syntax declare-field-assignment #f)
 (define-syntax declare-this-escapes #f)
 (define-syntax declare-super-new #f)
 
+;; A wrapper around the RHS of an initlization assignment,
+;; recognized by field identifier macros:
+(define-syntax field-initialization-value #f)
+
 ;; A wrapper macro that runs the `need-undeed-check?` analysis
 ;; and adds a boolean argument to a call to `compose-class`:
 (define-syntax (detect-field-unsafe-undefined stx)
@@ -67,23 +75,11 @@
        (cloop #`(begin . body) (make-module-identifier-mapping) #f)]
       [(begin '(decl id ...) . body)
        (and (identifier? #'decl)
-            (free-identifier=? #'decl #'declare-field-use))
+            (free-identifier=? #'decl #'declare-field-initialization))
-       ;; A field is used. If tracking has started, make sure the
+       ;; A field is initialized. If this is after an action that
-       ;; field is definitely initalized:
-       (or (and ready
-                (ormap (lambda (id)
-                         (not (module-identifier-mapping-get ready id (lambda () #f))))
-                       (syntax->list #'(id ...)))
-                (report #'body)
-                #t)
-           (loop #'(begin . body)))]
-      [(begin '(decl id ...) . body)
-       (and (identifier? #'decl)
-            (free-identifier=? #'decl #'declare-field-assignment))
-       ;; A field is assigned. If this is after an action that
        ;; might read a field externally, it's too late. Otherwise,
        ;; assuming that we're not in a branch, the field is after here
-       ;; assigned (but not before the right-hand side is evaluated):
+       ;; initialized (but not before the right-hand side is evaluated):
        (let ([ids (syntax->list #'(id ...))])
          (or (and ready
                   init-too-late?
@@ -100,6 +96,19 @@
                   (for-each (lambda (id)
                               (module-identifier-mapping-put! ready id #t))
                             ids))))))]
+      [(begin '(decl id ...) . body)
+       (and (identifier? #'decl)
+            (or (free-identifier=? #'decl #'declare-field-use)
+                (free-identifier=? #'decl #'declare-field-assignment)))
+       ;; A field is used or assigned. If tracking has started, make sure the
+       ;; field is definitely initalized:
+       (or (and ready
+                (ormap (lambda (id)
+                         (not (module-identifier-mapping-get ready id (lambda () #f))))
+                       (syntax->list #'(id ...)))
+                (report #'body)
+                #t)
+           (loop #'(begin . body)))]
       [(begin '(decl id ...) . body)
        (and (identifier? #'decl)
             (free-identifier=? #'decl #'declare-inherit-use))

racket/collects/racket/private/classidmap.rkt

@@ -48,6 +48,8 @@
   (if inherited?
       stx
       (quasisyntax/loc src-stx (begin '(declare-field-assignment #,id) #,stx))))
+(define (add-declare-field-initialization id src-stx stx)
+  (quasisyntax/loc src-stx (begin '(declare-field-initialization #,id) #,stx)))
 
 (define (make-this-map orig-id the-finder the-obj)
   (let ([set!-stx (datum->syntax the-finder 'set!)])
@@ -90,7 +92,20 @@
      (lambda (stx)
        (class-syntax-protect
         (with-syntax ([obj-expr (find the-finder the-obj stx)])
-          (syntax-case stx ()
+          (syntax-case stx (field-initialization-value)
+            [(set! id (field-initialization-value expr))
+             (free-identifier=? (syntax set!) set!-stx)
+             (add-declare-field-initialization
+              #'id
+              #'id
+              (with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [id expr]))]
+                            [set (quasisyntax/loc stx
+                                   ;; This continuation mark disables the chaperone on field assignement
+                                   ;; (if any) installed via `prop:chaperone-unsafe-undefined`:
+                                   (with-continuation-mark prop:chaperone-unsafe-undefined unsafe-undefined
+                                     #,(quasisyntax/loc stx
+                                         ((unsyntax field-mutator) obj id))))])
+                (syntax/loc (choose-src stx #'id) (let* bindings set))))]
             [(set! id expr)
              (free-identifier=? (syntax set!) set!-stx)
              (add-declare-field-assignment

racket/collects/racket/unsafe/ops.rkt

@@ -6,6 +6,7 @@
 (provide (except-out (all-from-out '#%unsafe)
                      unsafe-undefined
                      check-not-unsafe-undefined
+                     check-not-unsafe-undefined/assign
                      prop:chaperone-unsafe-undefined)
          (prefix-out unsafe-
                      (combine-out flsin flcos fltan

racket/collects/racket/unsafe/undefined.rkt

@@ -2,5 +2,6 @@
 (require '#%unsafe)
 
 (provide check-not-unsafe-undefined
+         check-not-unsafe-undefined/assign
          unsafe-undefined
          prop:chaperone-unsafe-undefined)

racket/src/racket/src/cstartup.inc

@@ -1,15 +1,15 @@
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,0,51,0,0,0,1,0,0,10,0,14,0,
-21,0,28,0,33,0,37,0,40,0,45,0,58,0,62,0,67,0,74,0,83,
+27,0,31,0,38,0,42,0,49,0,54,0,61,0,66,0,69,0,74,0,83,
 0,87,0,93,0,107,0,121,0,124,0,130,0,134,0,136,0,147,0,149,0,
 163,0,170,0,192,0,194,0,208,0,19,1,48,1,59,1,70,1,96,1,129,
 1,162,1,224,1,24,2,105,2,161,2,166,2,187,2,84,3,105,3,158,3,
 225,3,114,4,2,5,56,5,67,5,150,5,0,0,115,7,0,0,69,35,37,
-109,105,110,45,115,116,120,29,11,11,11,66,100,101,102,105,110,101,66,108,101,
+109,105,110,45,115,116,120,29,11,11,11,72,112,97,114,97,109,101,116,101,114,
-116,114,101,99,64,108,101,116,42,63,97,110,100,62,111,114,64,119,104,101,110,
+105,122,101,63,97,110,100,66,100,101,102,105,110,101,63,108,101,116,66,117,110,
-72,112,97,114,97,109,101,116,101,114,105,122,101,63,108,101,116,64,99,111,110,
+108,101,115,115,64,99,111,110,100,66,108,101,116,114,101,99,64,108,101,116,42,
-100,66,117,110,108,101,115,115,68,104,101,114,101,45,115,116,120,29,11,11,11,
+62,111,114,64,119,104,101,110,68,104,101,114,101,45,115,116,120,29,11,11,11,
 65,113,117,111,116,101,29,94,2,15,68,35,37,107,101,114,110,101,108,11,29,
 94,2,15,68,35,37,112,97,114,97,109,122,11,62,105,102,65,98,101,103,105,
 110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101,115,61,120,73,
@@ -17,10 +17,10 @@
 20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,
 61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,
 18,88,0,0,95,144,2,17,36,36,144,2,16,36,36,144,2,16,36,36,16,
-20,2,3,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,2,
+20,2,8,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,2,
-2,8,2,2,2,11,2,2,2,10,2,2,2,9,2,2,2,12,2,2,97,
+2,10,2,2,2,3,2,2,2,9,2,2,2,11,2,2,2,12,2,2,97,
 37,11,8,240,18,88,0,0,93,144,2,16,36,37,16,2,2,13,146,2,2,
-37,2,13,2,2,2,13,96,38,11,8,240,18,88,0,0,16,0,96,11,11,
+37,2,13,2,2,2,13,96,11,11,8,240,18,88,0,0,16,0,96,38,11,
 8,240,18,88,0,0,16,0,18,98,64,104,101,114,101,13,16,6,36,2,14,
 2,2,11,11,11,8,32,8,31,8,30,8,29,27,248,22,164,4,195,249,22,
 157,4,80,143,39,36,251,22,90,2,18,248,22,102,199,12,249,22,80,2,19,
@@ -28,13 +28,13 @@
 2,18,248,22,102,199,249,22,80,2,19,248,22,104,201,12,27,248,22,82,248,
 22,164,4,196,28,248,22,88,193,20,14,144,37,36,37,28,248,22,88,248,22,
 82,194,248,22,144,18,193,249,22,157,4,80,143,39,36,251,22,90,2,18,248,
-22,144,18,199,249,22,80,2,6,248,22,145,18,201,11,18,100,10,13,16,6,
+22,144,18,199,249,22,80,2,4,248,22,145,18,201,11,18,100,10,13,16,6,
 36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11,11,2,
 20,3,1,8,101,110,118,49,55,54,55,55,16,4,11,11,2,21,3,1,8,
 101,110,118,49,55,54,55,56,27,248,22,82,248,22,164,4,196,28,248,22,88,
 193,20,14,144,37,36,37,28,248,22,88,248,22,82,194,248,22,144,18,193,249,
 22,157,4,80,143,39,36,250,22,90,2,22,248,22,90,249,22,90,248,22,90,
-2,23,248,22,144,18,201,251,22,90,2,18,2,23,2,23,249,22,80,2,7,
+2,23,248,22,144,18,201,251,22,90,2,18,2,23,2,23,249,22,80,2,11,
 248,22,145,18,204,18,100,11,13,16,6,36,2,14,2,2,11,11,11,8,32,
 8,31,8,30,8,29,16,4,11,11,2,20,3,1,8,101,110,118,49,55,54,
 56,48,16,4,11,11,2,21,3,1,8,101,110,118,49,55,54,56,49,248,22,
@@ -52,7 +52,7 @@
 37,47,11,9,222,33,43,248,22,164,4,248,22,81,201,248,22,145,18,198,27,
 248,22,82,248,22,164,4,196,27,248,22,164,4,248,22,81,195,249,22,157,4,
 80,143,40,36,28,248,22,88,195,250,22,91,2,22,9,248,22,82,199,250,22,
-90,2,10,248,22,90,248,22,81,199,250,22,91,2,5,248,22,145,18,201,248,
+90,2,6,248,22,90,248,22,81,199,250,22,91,2,10,248,22,145,18,201,248,
 22,82,202,27,248,22,82,248,22,164,4,23,197,1,27,249,22,1,22,94,249,
 22,2,22,164,4,248,22,164,4,248,22,81,199,248,22,185,4,249,22,157,4,
 80,143,41,36,251,22,90,1,22,119,105,116,104,45,99,111,110,116,105,110,117,
@@ -63,10 +63,10 @@
 204,27,248,22,82,248,22,164,4,196,28,248,22,88,193,20,14,144,37,36,37,
 249,22,157,4,80,143,39,36,27,248,22,164,4,248,22,81,197,28,249,22,167,
 9,62,61,62,248,22,158,4,248,22,102,196,250,22,90,2,22,248,22,90,249,
-22,90,21,93,2,27,248,22,81,199,250,22,91,2,11,249,22,90,2,27,249,
+22,90,21,93,2,27,248,22,81,199,250,22,91,2,8,249,22,90,2,27,249,
 22,90,248,22,111,203,2,27,248,22,82,202,251,22,90,2,18,28,249,22,167,
 9,248,22,158,4,248,22,81,200,64,101,108,115,101,10,248,22,144,18,197,250,
-22,91,2,22,9,248,22,145,18,200,249,22,80,2,11,248,22,82,202,99,13,
+22,91,2,22,9,248,22,145,18,200,249,22,80,2,8,248,22,82,202,99,13,
 16,6,36,2,14,2,2,11,11,11,8,32,8,31,8,30,8,29,16,4,11,
 11,2,20,3,1,8,101,110,118,49,55,55,48,51,16,4,11,11,2,21,3,
 1,8,101,110,118,49,55,55,48,52,18,143,94,10,64,118,111,105,100,8,48,
@@ -82,25 +82,25 @@
 2,11,2,12,36,46,37,16,0,36,16,1,2,13,37,11,11,11,16,0,16,
 0,16,0,36,36,11,12,11,11,16,0,16,0,16,0,36,36,16,11,16,5,
 11,20,15,16,2,20,14,144,36,36,37,80,143,36,36,36,20,114,144,36,16,
-1,2,13,16,1,33,33,10,16,5,2,12,88,148,8,36,37,53,37,9,223,
+1,2,13,16,1,33,33,10,16,5,2,7,88,148,8,36,37,53,37,9,223,
-0,33,34,36,20,114,144,36,16,1,2,13,16,0,11,16,5,2,8,88,148,
+0,33,34,36,20,114,144,36,16,1,2,13,16,0,11,16,5,2,12,88,148,
 8,36,37,53,37,9,223,0,33,35,36,20,114,144,36,16,1,2,13,16,0,
-11,16,5,2,6,88,148,8,36,37,53,37,9,223,0,33,36,36,20,114,144,
+11,16,5,2,4,88,148,8,36,37,53,37,9,223,0,33,36,36,20,114,144,
-36,16,1,2,13,16,1,33,37,11,16,5,2,7,88,148,8,36,37,56,37,
+36,16,1,2,13,16,1,33,37,11,16,5,2,11,88,148,8,36,37,56,37,
 9,223,0,33,38,36,20,114,144,36,16,1,2,13,16,1,33,39,11,16,5,
-2,10,88,148,8,36,37,58,37,9,223,0,33,42,36,20,114,144,36,16,1,
+2,6,88,148,8,36,37,58,37,9,223,0,33,42,36,20,114,144,36,16,1,
-2,13,16,0,11,16,5,2,4,88,148,8,36,37,53,37,9,223,0,33,44,
+2,13,16,0,11,16,5,2,9,88,148,8,36,37,53,37,9,223,0,33,44,
-36,20,114,144,36,16,1,2,13,16,0,11,16,5,2,5,88,148,8,36,37,
+36,20,114,144,36,16,1,2,13,16,0,11,16,5,2,10,88,148,8,36,37,
 54,37,9,223,0,33,45,36,20,114,144,36,16,1,2,13,16,0,11,16,5,
-2,9,88,148,8,36,37,56,37,9,223,0,33,46,36,20,114,144,36,16,1,
+2,3,88,148,8,36,37,56,37,9,223,0,33,46,36,20,114,144,36,16,1,
-2,13,16,0,11,16,5,2,11,88,148,8,36,37,58,37,9,223,0,33,47,
+2,13,16,0,11,16,5,2,8,88,148,8,36,37,58,37,9,223,0,33,47,
-36,20,114,144,36,16,1,2,13,16,1,33,49,11,16,5,2,3,88,148,8,
+36,20,114,144,36,16,1,2,13,16,1,33,49,11,16,5,2,5,88,148,8,
 36,37,54,37,9,223,0,33,50,36,20,114,144,36,16,1,2,13,16,0,11,
 16,0,94,2,16,2,17,93,2,16,9,9,36,9,0};
     EVAL_ONE_SIZED_STR((char *)expr, 2051);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,0,187,0,0,0,1,0,0,8,0,21,0,
 26,0,43,0,55,0,77,0,106,0,150,0,156,0,165,0,172,0,187,0,205,
 0,217,0,233,0,247,0,13,1,32,1,39,1,73,1,90,1,107,1,130,1,
@@ -559,7 +559,7 @@
 22,131,15,10,22,132,15,10,22,135,15,10,22,134,15,11,22,136,15,10,22,
 133,15,10,22,137,15,10,22,138,15,10,22,139,15,10,22,140,15,10,22,141,
 15,11,22,142,15,10,22,128,15,11,247,23,193,1,250,22,176,11,2,8,2,
-52,23,196,1,248,22,8,20,20,94,88,148,36,37,8,43,16,4,8,128,6,
+52,23,196,1,248,22,9,20,20,94,88,148,36,37,8,43,16,4,8,128,6,
 8,128,104,8,240,0,64,0,0,36,9,224,1,2,33,144,2,23,195,1,0,
 7,35,114,120,34,47,43,34,28,248,22,151,7,23,195,2,27,249,22,154,16,
 2,146,2,23,197,2,28,23,193,2,28,249,22,128,4,248,22,101,23,196,2,
@@ -1017,7 +1017,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 19187);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,0,14,0,0,0,1,0,0,15,0,40,0,
 57,0,75,0,97,0,120,0,140,0,162,0,171,0,180,0,187,0,196,0,203,
 0,0,0,231,1,0,0,74,35,37,112,108,97,99,101,45,115,116,114,117,99,
@@ -1047,7 +1047,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 557);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,0,106,0,0,0,1,0,0,7,0,18,0,
 45,0,51,0,60,0,67,0,89,0,102,0,128,0,145,0,167,0,175,0,187,
 0,202,0,218,0,236,0,0,1,12,1,28,1,51,1,75,1,87,1,118,1,
@@ -1529,7 +1529,7 @@
     EVAL_ONE_SIZED_STR((char *)expr, 10046);
   }
   {
-    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,51,84,0,0,0,0,0,0,0,0,0,0,
+    SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,48,46,49,46,52,84,0,0,0,0,0,0,0,0,0,0,
 0,0,0,0,0,0,0,0,0,0,11,0,0,0,1,0,0,10,0,16,0,
 29,0,44,0,58,0,78,0,90,0,104,0,118,0,170,0,0,0,101,1,0,
 0,69,35,37,98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2,

racket/src/racket/src/fun.c

@@ -87,6 +87,7 @@ READ_ONLY Scheme_Object *scheme_procedure_p_proc;
 READ_ONLY Scheme_Object *scheme_procedure_arity_includes_proc;
 READ_ONLY Scheme_Object *scheme_void_proc;
 READ_ONLY Scheme_Object *scheme_check_not_undefined_proc;
+READ_ONLY Scheme_Object *scheme_check_assign_not_undefined_proc;
 READ_ONLY Scheme_Object *scheme_apply_proc;
 READ_ONLY Scheme_Object *scheme_call_with_values_proc; /* the function bound to `call-with-values' */
 READ_ONLY Scheme_Object *scheme_reduced_procedure_struct;
@@ -678,6 +679,12 @@ scheme_init_unsafe_fun (Scheme_Env *env)
   SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
   scheme_add_global_constant("check-not-unsafe-undefined", o, env);
 
+  REGISTER_SO(scheme_check_assign_not_undefined_proc);
+  o = scheme_make_prim_w_arity(scheme_check_assign_not_undefined, "check-not-unsafe-undefined/assign", 2, 2);
+  scheme_check_assign_not_undefined_proc = o;
+  SCHEME_PRIM_PROC_FLAGS(o) |= scheme_intern_prim_opt_flags(SCHEME_PRIM_IS_BINARY_INLINED);
+  scheme_add_global_constant("check-not-unsafe-undefined/assign", o, env);
+
   scheme_add_global_constant("unsafe-undefined", scheme_undefined, env);
 
   REGISTER_SO(scheme_chaperone_undefined_property);
@@ -2552,7 +2559,23 @@ scheme_check_not_undefined (int argc, Scheme_Object *argv[])
   if (SAME_OBJ(argv[0], scheme_undefined)) {
     scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
                      argv[1],
-                     "%S: variable used before its definition",
+                     "%S: undefined;\n cannot use before initialization",
+                     argv[1]);
+  }
+
+  return argv[0];
+}
+
+Scheme_Object *
+scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[])
+{
+  if (!SCHEME_SYMBOLP(argv[1]))
+    scheme_wrong_contract("check-not-unsafe-undefined/assign", "symbol?", 1, argc, argv);
+
+  if (SAME_OBJ(argv[0], scheme_undefined)) {
+    scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
+                     argv[1],
+                     "%S: assignment disallowed;\n cannot assign before initialization",
                      argv[1]);
   }
 

racket/src/racket/src/jit.h

@@ -367,7 +367,7 @@ struct scheme_jit_common_record {
 # endif
 #endif
   void *make_rest_list_code, *make_rest_list_clear_code;
-  void *call_check_not_defined_code;
+  void *call_check_not_defined_code, *call_check_assign_not_defined_code;
 
   Continuation_Apply_Indirect continuation_apply_indirect_code;
 #ifdef MZ_USE_LWC

racket/src/racket/src/jit_ts.c

@@ -107,6 +107,7 @@ define_ts_iS_s(scheme_checked_integer_to_char, FSRC_MARKS)
 define_ts_iSi_s(scheme_build_list_offset, FSRC_OTHER)
 # endif
 define_ts_iS_s(scheme_check_not_undefined, FSRC_MARKS)
+define_ts_iS_s(scheme_check_assign_not_undefined, FSRC_MARKS)
 #endif
 
 #ifdef JITCALL_TS_PROCS
@@ -240,4 +241,5 @@ define_ts_s_s(scheme_box, FSRC_OTHER)
 # define ts_scheme_checked_char_to_integer scheme_checked_char_to_integer
 # define ts_scheme_checked_integer_to_char scheme_checked_integer_to_char
 # define ts_scheme_check_not_undefined scheme_check_not_undefined
+# define ts_scheme_check_assign_not_undefined scheme_check_assign_not_undefined
 #endif

racket/src/racket/src/jitcommon.c

@@ -3227,12 +3227,20 @@ static int common11(mz_jit_state *jitter, void *_data)
 
 static int common12(mz_jit_state *jitter, void *_data)
 {
-  /* call_check_not_defined_code */
+  /* call_check_[assign_]not_defined_code */
   /* ares are in R0 and R1 */
   {
     GC_CAN_IGNORE jit_insn *refr USED_ONLY_FOR_FUTURES;
+    void *code;
+    int i;
     
-    sjc.call_check_not_defined_code = jit_get_ip();
+    for (i = 0; i < 2; i++) {
+      code = jit_get_ip();
+
+      if (!i)
+        sjc.call_check_not_defined_code = code;
+      else
+        sjc.call_check_assign_not_defined_code = code;
 
       mz_prolog(JIT_R2);
 
@@ -3247,16 +3255,21 @@ static int common12(mz_jit_state *jitter, void *_data)
       mz_prepare(2);
       jit_pusharg_p(JIT_RUNSTACK);
       jit_pusharg_i(JIT_R0);
+      if (!i) {
         mz_finish_prim_lwe(ts_scheme_check_not_undefined, refr);
+      } else {
+        mz_finish_prim_lwe(ts_scheme_check_assign_not_undefined, refr);
+      }
 
       jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
       JIT_UPDATE_THREAD_RSPTR();
 
       mz_epilog(JIT_R2);
 
-    scheme_jit_register_sub_func(jitter, sjc.call_check_not_defined_code, scheme_false);
+      scheme_jit_register_sub_func(jitter, code, scheme_false);
       CHECK_LIMIT();
     }
+  }
 
   return 1;
 }

racket/src/racket/src/jitinline.c

@@ -3527,9 +3527,10 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
       jit_movr_p(dest, JIT_R0);
 
       return 1;
-    } else if (IS_NAMED_PRIM(rator, "check-not-unsafe-undefined")) {
+    } else if (IS_NAMED_PRIM(rator, "check-not-unsafe-undefined")
+               || IS_NAMED_PRIM(rator, "check-not-unsafe-undefined/assign")) {
       if (SCHEME_SYMBOLP(app->rand2)) {
-        GC_CAN_IGNORE jit_insn *ref, *ref2;
+        GC_CAN_IGNORE jit_insn *ref;
 
         LOG_IT(("inlined check-not-unsafe-undefined\n"));
 
@@ -3541,17 +3542,18 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
         mz_rs_sync_fail_branch();
 
         __START_TINY_JUMPS__(1);
-        ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1);
+        ref = jit_bnei_ul(jit_forward(), JIT_R0, scheme_undefined);
-        ref2 = mz_bnei_t(jit_forward(), JIT_R0, scheme_undefined_type, JIT_R2);
         __END_TINY_JUMPS__(1);
 
         scheme_mz_load_retained(jitter, JIT_R1, app->rand2);
+        if (IS_NAMED_PRIM(rator, "check-not-unsafe-undefined"))
           (void)jit_calli(sjc.call_check_not_defined_code);
+        else
+          (void)jit_calli(sjc.call_check_assign_not_defined_code);
         /* never returns */
 
         __START_TINY_JUMPS__(1);
         mz_patch_branch(ref);
-        mz_patch_branch(ref2);
         __END_TINY_JUMPS__(1);
         CHECK_LIMIT();
       } else {

racket/src/racket/src/letrec_check.c

@@ -1265,15 +1265,42 @@ static Scheme_Object *letrec_check_set(Scheme_Object *o, Letrec_Check_Frame *fra
 {
   Scheme_Set_Bang *sb;
   Scheme_Object *val;
+  int position;
 
   sb = (Scheme_Set_Bang *)o;
   val = sb->val;
 
-
-
   val = letrec_check_expr(val, frame, uvars, pvars, pos);
   sb->val = val;
 
+  if (SAME_TYPE(SCHEME_TYPE(sb->var), scheme_local_type)) {
+    /* We may need to insert a definedness check before the assignment */
+    position = SCHEME_LOCAL_POS(sb->var);
+    if (lookup_var(position, uvars, frame) ||
+        lookup_var(position, pvars, frame)) {
+      /* Insert the check: */
+      Scheme_App3_Rec *app3;
+      Scheme_Object *name;
+      Scheme_Sequence *seq;
+      
+      name = record_checked((Scheme_Local *)sb->var, frame);
+      
+      app3 = MALLOC_ONE_TAGGED(Scheme_App3_Rec);
+      app3->iso.so.type = scheme_application3_type;
+      app3->rator = scheme_check_assign_not_undefined_proc;
+      app3->rand1 = sb->var;
+      app3->rand2 = name;
+      
+      seq = scheme_malloc_sequence(2);
+      seq->so.type = scheme_sequence_type;
+      seq->count = 2;
+      seq->array[0] = (Scheme_Object *)app3;
+      seq->array[1] = (Scheme_Object *)sb;
+
+      return (Scheme_Object *)seq;
+    }
+  }
+
   return o;
 }
 

racket/src/racket/src/schminc.h

@@ -15,7 +15,7 @@
 #define USE_COMPILED_STARTUP 1
 
 #define EXPECTED_PRIM_COUNT 1116
-#define EXPECTED_UNSAFE_COUNT 104
+#define EXPECTED_UNSAFE_COUNT 105
 #define EXPECTED_FLFXNUM_COUNT 69
 #define EXPECTED_EXTFL_COUNT 45
 #define EXPECTED_FUTURES_COUNT 15

racket/src/racket/src/schpriv.h

@@ -437,6 +437,7 @@ extern Scheme_Object *scheme_procedure_p_proc;
 extern Scheme_Object *scheme_procedure_arity_includes_proc;
 extern Scheme_Object *scheme_void_proc;
 extern Scheme_Object *scheme_check_not_undefined_proc;
+extern Scheme_Object *scheme_check_assign_not_undefined_proc;
 extern Scheme_Object *scheme_pair_p_proc;
 extern Scheme_Object *scheme_mpair_p_proc;
 extern Scheme_Object *scheme_unsafe_cons_list_proc;
@@ -3993,6 +3994,7 @@ Scheme_Object *scheme_checked_char_to_integer (int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_checked_integer_to_char (int argc, Scheme_Object *argv[]);
 
 Scheme_Object *scheme_check_not_undefined (int argc, Scheme_Object *argv[]);
+Scheme_Object *scheme_check_assign_not_undefined (int argc, Scheme_Object *argv[]);
 
 Scheme_Object *scheme_chaperone_vector_copy(Scheme_Object *obj);
 Scheme_Object *scheme_chaperone_hash_table_copy(Scheme_Object *obj);

racket/src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "6.0.1.3"
+#define MZSCHEME_VERSION "6.0.1.4"
 
 #define MZSCHEME_VERSION_X 6
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 1
-#define MZSCHEME_VERSION_W 3
+#define MZSCHEME_VERSION_W 4
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

racket/src/racket/src/struct.c

@@ -1993,6 +1993,30 @@ static Scheme_Object *chaperone_struct_ref_overflow(const char *who, Scheme_Obje
   return scheme_handle_stack_overflow(chaperone_struct_ref_k);
 }
 
+static void raise_undefined_error(Scheme_Object *val, const char *short_error, const char *mode, int i)
+{
+  int len;
+  Scheme_Object *o;
+
+  o = scheme_struct_type_property_ref(scheme_chaperone_undefined_property, val);
+  len = (o ? scheme_proper_list_length(o) : 0);
+  if (i < len) {
+    for (i = len - i; --i; ) {
+      o = SCHEME_CDR(o);
+    }
+    o = SCHEME_CAR(o);
+    scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
+                     o,
+                     "%S: %s;\n cannot %s field before initialization",
+                     o, short_error, mode);
+  } else {
+    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
+                     "%s;\n cannot %s field before initialization",
+                     short_error, mode);
+  }
+
+}
+
 static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, int i)
 {
   while (1) {
@@ -2014,22 +2038,7 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, in
           orig = chaperone_struct_ref(who, o, i);
 
         if (SAME_OBJ(orig, scheme_undefined)) {
-          int len;
+          raise_undefined_error(px->val, "undefined", "use", i);
-          o = scheme_struct_type_property_ref(scheme_chaperone_undefined_property, px->val);
-          len = (o ? scheme_proper_list_length(o) : 0);
-          if (i < len) {
-            for (i = len - i; --i; ) {
-              o = SCHEME_CDR(o);
-            }
-            o = SCHEME_CAR(o);
-            scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
-                             o,
-                             "%S: field used before its initialization",
-                             o);
-          } else {
-            scheme_raise_exn(MZEXN_FAIL_CONTRACT,
-                             "field used before its initialization");
-          }
         }
 
         return orig;
@@ -2118,6 +2127,19 @@ static void chaperone_struct_set(const char *who, Scheme_Object *o, int i, Schem
             if (!SAME_OBJ(v, a[1]) && !scheme_chaperone_of(v, a[1]))
               scheme_wrong_chaperoned(who, "value", a[1], v);
         } 
+      } if (SCHEME_VECTORP(px->redirects)
+            && !(SCHEME_VEC_SIZE(px->redirects) & 1)
+            && SAME_OBJ(SCHEME_VEC_ELS(px->redirects)[1], scheme_undefined)) {
+        /* chaperone on every field: check that current value is not undefined
+           --- unless check is disabled by a mark (bit it's faster to check
+           for `undefined` before checking the mark) */
+        if (SAME_OBJ(scheme_undefined, ((Scheme_Structure *)px->val)->slots[i])) {
+          Scheme_Object *m;
+          
+          m = scheme_extract_one_cc_mark(NULL, scheme_chaperone_undefined_property);
+          if (!m || !SAME_OBJ(m, scheme_undefined))
+            raise_undefined_error(px->val, "assignment disallowed", "assign", i);
+        }
       }
     }
   }