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

make assignment-before-initialization an error

Browse Source 
Recent changes made use-before-initialization an error for
`letrec` bindings, `class` fields, and `unit` definitions.
Now, assignment-before-initialization is also an error.
This commit is contained in:
Matthew Flatt 2014-04-16 11:25:47 -06:00
parent 52ea013f87
commit 22b48e03c8
20 changed files with 273 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl
View File

@ -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
definition.'' If @racket[v] is not @racket[unsafe-undefined], then
@racket[v] is returned.}
along the lines of ``@racket[sym]: undefined; use before
initialization.'' If @racket[v] is not @racket[unsafe-undefined],
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
access of a field in the structure is checked to prevent returning
constructor to produce a @tech{chaperone} of an instance. Every access
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 ....)].}

17
pkgs/racket-pkgs/racket-test/tests/racket/object.rktl
View File

@ -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,12 +2039,8 @@
(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)
;; 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)
(check-opt '(class object% (inherit-field f) (when ? (super-new)) (displayln f)) #f)
(void))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

3
pkgs/racket-pkgs/racket-test/tests/racket/syntax.rktl
View File

@ -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])

1
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
View File

@ -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))]

26
racket/collects/racket/private/class-internal.rkt
View File

@ -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))
e
#'d-v)]
(let* ([ids (syntax->list #'(id ...))]
[assignment
(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))]

43
racket/collects/racket/private/class-undef.rkt
View File

@ -4,11 +4,14 @@
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)
@ -16,12 +19,17 @@
;; 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))
;; A field is used. 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-field-assignment))
;; A field is assigned. If this is after an action that
(free-identifier=? #'decl #'declare-field-initialization))
;; A field is initialized. 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))

17
racket/collects/racket/private/classidmap.rkt
View File

@ -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

1
racket/collects/racket/unsafe/ops.rkt
View File

@ -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

1
racket/collects/racket/unsafe/undefined.rkt
View File

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

58
racket/src/racket/src/cstartup.inc
View File

@ -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,
116,114,101,99,64,108,101,116,42,63,97,110,100,62,111,114,64,119,104,101,110,
72,112,97,114,97,109,101,116,101,114,105,122,101,63,108,101,116,64,99,111,110,
100,66,117,110,108,101,115,115,68,104,101,114,101,45,115,116,120,29,11,11,11,
109,105,110,45,115,116,120,29,11,11,11,72,112,97,114,97,109,101,116,101,114,
105,122,101,63,97,110,100,66,100,101,102,105,110,101,63,108,101,116,66,117,110,
108,101,115,115,64,99,111,110,100,66,108,101,116,114,101,99,64,108,101,116,42,
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,
2,8,2,2,2,11,2,2,2,10,2,2,2,9,2,2,2,12,2,2,97,
20,2,8,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,7,2,2,
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,
0,33,34,36,20,114,144,36,16,1,2,13,16,0,11,16,5,2,8,88,148,
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,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,
36,16,1,2,13,16,1,33,37,11,16,5,2,7,88,148,8,36,37,56,37,
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,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,13,16,0,11,16,5,2,4,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,
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,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,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,13,16,0,11,16,5,2,11,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,
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,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,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,

25
racket/src/racket/src/fun.c
View File

@ -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]);
}

2
racket/src/racket/src/jit.h
View File

@ -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

2
racket/src/racket/src/jit_ts.c
View File

@ -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

49
racket/src/racket/src/jitcommon.c
View File

@ -3227,35 +3227,48 @@ 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;
for (i = 0; i < 2; i++) {
code = jit_get_ip();
sjc.call_check_not_defined_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);
mz_prolog(JIT_R2);
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
JIT_UPDATE_THREAD_RSPTR();
jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
JIT_UPDATE_THREAD_RSPTR();
jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1);
jit_str_p(JIT_RUNSTACK, JIT_R0);
jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1);
jit_str_p(JIT_RUNSTACK, JIT_R0);
CHECK_LIMIT();
jit_movi_i(JIT_R0, 2);
mz_prepare(2);
jit_pusharg_p(JIT_RUNSTACK);
jit_pusharg_i(JIT_R0);
mz_finish_prim_lwe(ts_scheme_check_not_undefined, refr);
CHECK_LIMIT();
jit_movi_i(JIT_R0, 2);
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();
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
JIT_UPDATE_THREAD_RSPTR();
mz_epilog(JIT_R2);
mz_epilog(JIT_R2);
scheme_jit_register_sub_func(jitter, sjc.call_check_not_defined_code, scheme_false);
CHECK_LIMIT();
scheme_jit_register_sub_func(jitter, code, scheme_false);
CHECK_LIMIT();
}
}
return 1;

14
racket/src/racket/src/jitinline.c
View File

@ -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);
ref2 = mz_bnei_t(jit_forward(), JIT_R0, scheme_undefined_type, JIT_R2);
ref = jit_bnei_ul(jit_forward(), JIT_R0, scheme_undefined);
__END_TINY_JUMPS__(1);
scheme_mz_load_retained(jitter, JIT_R1, app->rand2);
(void)jit_calli(sjc.call_check_not_defined_code);
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 {

31
racket/src/racket/src/letrec_check.c
View File

@ -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;
}

2
racket/src/racket/src/schminc.h
View File

@ -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

2
racket/src/racket/src/schpriv.h
View File

@ -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);

4
racket/src/racket/src/schvers.h
View File

@ -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)

54
racket/src/racket/src/struct.c
View File

@ -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;
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");
}
raise_undefined_error(px->val, "undefined", "use", i);
}
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);
}
}
}
}