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

move internal undefined to unsafe-undefined

Browse Source
This commit is contained in:
Matthew Flatt 2014-04-07 11:10:03 -06:00
parent f8813474d4
commit 574b8a5d3b
24 changed files with 1796 additions and 1212 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt
View File

@ -4496,7 +4496,6 @@
(if (null? v)
(send bug-icon show #f)
(send bug-icon show #t)))
(set-bug-label (preferences:get 'drracket:saved-bug-reports))
(define remove-bug-icon-callback
(preferences:add-callback
'drracket:saved-bug-reports
@ -4608,6 +4607,7 @@
(λ (l)
(cons btn (remq* (list btn) l))))
btn))
(set-bug-label (preferences:get 'drracket:saved-bug-reports))
(set! func-defs-canvas (new func-defs-canvas%
(parent name-panel)

33
pkgs/racket-pkgs/racket-doc/scribblings/reference/data.scrbl
View File

@ -1,6 +1,5 @@
#lang scribble/doc
@(require "mz.rkt"
(for-label racket/undefined))
@(require "mz.rkt")
@title[#:style 'toc #:tag "data"]{Datatypes}
@ -170,33 +169,5 @@ The @|void-const| value is always @racket[eq?] to itself.
@defproc[(void [v any/c] ...) void?]{Returns the constant @|void-const|. Each
@racket[v] argument is ignored.}
@; ----------------------------------------------------------------------
@section[#:tag "undefined"]{Undefined}
@note-lib[racket/undefined]
The constant @racket[undefined] is conceptually used as a placeholder
value for a binding, so that a reference to a binding before its
definition can be detected. Such references are normally protected
implicitly via @racket[check-not-undefined], so that an expression does
not normally produce an @racket[undefined] value.
The @racket[undefined] value is always @racket[eq?] to itself.
@history[#:added "6.0.0.6"]
@defproc[(undefined? [v any/c]) boolean?]{Returns @racket[#t] if @racket[v] is the
constant @racket[undefined], @racket[#f] otherwise.}
@defthing[undefined undefined?]{The ``undefined'' constant.}
@defproc[(check-not-undefined [v any/c] [sym symbol?]) (and/c any/c (not/c undefined?))]{
Checks whether @racket[v] is @racket[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[undefined], then @racket[v] is returned.
}
@include-section["undefined.scrbl"]

23
pkgs/racket-pkgs/racket-doc/scribblings/reference/undefined.scrbl Normal file
View File

@ -0,0 +1,23 @@
#lang scribble/doc
@(require "mz.rkt"
(for-label racket/undefined))
@title[#:tag "undefined"]{Undefined}
@note-lib[racket/undefined]
The constant @racket[undefined] can be used as a placeholder value for
a value to be installed later, especially for cases where premature
access of the value is either difficult or impossible to detect or
prevent.
The @racket[undefined] value is always @racket[eq?] to itself.
@history[#:added "6.0.0.6"]
@defproc[(undefined? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is the constant @racket[undefined],
@racket[#f] otherwise.}
@defthing[undefined undefined?]{The ``undefined'' constant.}

55
pkgs/racket-pkgs/racket-doc/scribblings/reference/unsafe-undefined.scrbl Normal file
View File

@ -0,0 +1,55 @@
#lang scribble/doc
@(require "mz.rkt"
(for-label racket/unsafe/undefined))
@title[#:tag "unsafe-undefined"]{Unsafe Undefined}
@note-lib[racket/unsafe/undefined]
The constant @racket[unsafe-undefined] is used internally as a
placeholder value. For example, it is used by @racket[letrec] as a
value for a variable that has not yet been assigned a value. Unlike
the @racket[undefined] value exported by @racket[racket/undefined],
however, the @racket[unsafe-undefined] value should not leak as the
result of a safe expression. Expression results that potentially
produce @racket[unsafe-undefined] can be guarded by
@racket[check-not-unsafe-undefined], so that an exception can be
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"]
@defproc[(unsafe-undefined? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is the constant
@racket[unsafe-undefined], @racket[#f] otherwise.}
@defthing[unsafe-undefined unsafe-undefined?]{
The unsafe ``undefined'' constant.}
@defproc[(check-not-unsafe-undefined [v any/c] [sym symbol?])
(and/c any/c (not/c unsafe-undefined?))]{
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.}
@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
@racket[unsafe-undefined].
The property value should be a list of symbols used as field names,
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.}

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

@ -418,3 +418,7 @@ Unchecked versions of @racket[extflvector-length], @racket[extflvector-ref], and
@racket[extflvector-set!]. A @tech{extflvector}'s size can never be larger than a
@tech{fixnum} (so even @racket[extflvector-length] always returns a
fixnum).}
@; ------------------------------------------------------------------------
@include-section["unsafe-undefined.scrbl"]

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

@ -1922,6 +1922,122 @@
(test 5 'send-generic (send-generic (new c%) (generic c% m) 5))
(test 6 'send-generic-interface (send-generic (new c/i%) (generic i<%> m) 6))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; check error reporting for variable use before assignment
(let ()
(define c%
(class object%
(define x 7)
(field [h 10])
(super-new)))
(define d%
(class c%
(define z z)
(super-new)))
(define e%
(class d%
(define q 1)
(field [s 1])
(super-new)))
(define d2%
(class c%
(define z 1)
(field [f f])
(super-new)))
(define e2%
(class d2%
(define q 1)
(field [s 1])
(super-new)))
(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)))))
(err/rt-test (new d2%) (lambda (exn)
(and (exn:fail:contract:variable? exn)
(eq? 'f (exn:fail:contract:variable-id exn)))))
(err/rt-test (new e2%) (lambda (exn)
(and (exn:fail:contract:variable? exn)
(eq? 'f (exn:fail:contract:variable-id exn))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; check optimization to omit use-before-definition chaperone:
;; Relies on expansion where the next-to-last argument of `compose-class`
;; is #t when the chaperone is needed.
(let ()
(define (check-opt e opt?)
(test #t
`(,opt? ,e)
(let ([e (expand e)])
(let loop ([e e])
(cond
[(and (pair? e)
(pair? (cdr e))
(eq? (syntax-e (car e)) 'compose-class))
(eq? opt? (syntax-case (list-ref e (- (length e) 2)) (quote)
[(quote #f) #t]
[(quote #t) #f]
[_ 'unknown]))]
[(syntax? e)
(loop (syntax-e e))]
[(pair? e)
(and (loop (car e)) (loop (cdr e)))]
[else #t])))))
(check-opt '(class object%) #t)
(check-opt '(class object% (super-new)) #t)
(check-opt '(class object% (define x 1)) #t)
(check-opt '(class object% (define x 1) (super-new)) #t)
(check-opt '(class object% (field [x 1]) (super-new)) #t)
(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% (define x x)) #f)
(check-opt '(class object% (field [x x])) #f)
(check-opt '(class object% (init-field [x x])) #f)
(check-opt '(class object% (super-new) (define x 1)) #f)
(check-opt '(class object% (super-make-object) (define x 1)) #f)
(check-opt '(class object% (super-instantiate ()) (define x 1)) #f)
(check-opt '(class object% (displayln this) (define x 1)) #f)
(check-opt '(class object% (inherit m) (m) (define x 1)) #f)
(check-opt '(class object% (define/override (m) x) (super m) (define x 1)) #f)
(check-opt '(class object% (define x 1) (define y 1) (super-new)) #t)
(check-opt '(class object% (define x 1) (define y x) (super-new)) #t)
(check-opt '(class object% (field [x 1] [y x]) (super-new)) #t)
(check-opt '(class object% (field [x 1] [y x]) (super-make-object)) #t)
(check-opt '(class object% (init-field [x 1] [y x]) (super-new)) #t)
(check-opt '(class object% (init-field [x 1]) (define y x) (super-new)) #t)
(check-opt '(class object% (define x 1) (define y (list x)) (super-new)) #t)
(check-opt '(class object% (define/public (m) x) (define x 1) (super-new)) #t)
(check-opt '(class object% (define/override (m) x) (define x 1) (super-new)) #t)
(check-opt '(class object% (define x y) (define y 1) (super-new)) #f)
(check-opt '(class object% (init-field [x y] [y 1])) #f)
(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)
(void))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

10
racket/collects/racket/private/class-c-old.rkt
View File

@ -236,6 +236,7 @@
field-pub-width
field-ht
(class-field-ids cls)
(class-all-field-ids cls)
'struct:object 'object? 'make-object
'field-ref 'field-set!
@ -247,6 +248,8 @@
(class-orig-cls cls)
#f #f ; serializer is never set
(class-check-undef? cls)
#f)]
[obj-name (if name
(string->symbol (format "object:~a" name))
@ -500,6 +503,7 @@
field-pub-width
field-ht
(class-field-ids cls)
(class-all-field-ids cls)
'struct:object 'object? 'make-object
'field-ref 'field-set!
@ -511,6 +515,9 @@
(class-orig-cls cls)
#f #f ; serializer is never set
(class-check-undef? cls)
#f)]
[obj-name (if name
(string->symbol (format "object:~a" name))
@ -1249,6 +1256,7 @@
field-pub-width
field-ht
(class-field-ids cls)
(class-all-field-ids cls)
'struct:object 'object? 'make-object
'field-ref 'field-set!
@ -1259,6 +1267,8 @@
(class-orig-cls cls)
#f #f ; serializer is never set
(class-check-undef? cls)
#f)]
[obj-name (if name
(string->symbol (format "wrapper-object:~a" name))

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

@ -9,7 +9,8 @@
(only-in "../contract/region.rkt" current-contract-region)
"../contract/base.rkt"
"../contract/combinator.rkt"
racket/undefined
racket/unsafe/undefined
"class-undef.rkt"
(for-syntax racket/stxparam
syntax/kerncase
syntax/stx
@ -1220,7 +1221,6 @@
(syntax-track-origin
(syntax/loc e
(begin
1 ; to ensure a non-empty body
(set! id (extract-arg 'class-name `idpos init-args defval))
...))
e
@ -1232,7 +1232,6 @@
(map normalize-init/field (syntax->list #'(idp ...)))])
(syntax-track-origin
(syntax/loc e (begin
1 ; to ensure a non-empty body
(set! iid expr)
...))
e
@ -1247,7 +1246,8 @@
#'id/rename
(stx-car #'id/rename))])
(syntax-track-origin
(syntax/loc e (set! id (extract-rest-args n init-args)))
(syntax/loc e
(set! id (extract-rest-args n init-args)))
e
#'-i-r))]
[(-i-r)
@ -1348,14 +1348,16 @@
public-final-name ...
pubment-name ...)
(values
(make-field-map (quote-syntax the-finder)
(make-field-map #t
(quote-syntax the-finder)
(quote the-obj)
(quote-syntax inherit-field-name)
(quote-syntax inherit-field-name-localized)
(quote-syntax inherit-field-accessor)
(quote-syntax inherit-field-mutator))
...
(make-field-map (quote-syntax the-finder)
(make-field-map #f
(quote-syntax the-finder)
(quote the-obj)
(quote-syntax local-field)
(quote-syntax local-field-localized)
@ -1486,18 +1488,22 @@
[inspector (if (pair? inspect-decls)
(stx-car (stx-cdr (car inspect-decls)))
#'(current-inspector))]
[deserialize-id-expr deserialize-id-expr])
[deserialize-id-expr deserialize-id-expr]
[private-field-names private-field-names])
(add-decl-props
(quasisyntax/loc stx
(let ([superclass super-expression]
[interfaces (list interface-expression ...)])
(compose-class
'name superclass interfaces inspector deserialize-id-expr #,any-localized?
(detect-field-unsafe-undefined
compose-class
'name
super-expression
(list interface-expression ...)
inspector deserialize-id-expr #,any-localized?
;; Field count:
num-fields
;; Field names:
`field-names
`inherit-field-names
`private-field-names ; for undefined-checking property
;; Method names:
`(rename-super-name ... rename-super-extra-name ...)
`(rename-inner-name ... rename-inner-extra-name ...)
@ -1620,42 +1626,54 @@
(syntax-case stx ()
[(_ (arg (... ...)) (kw kwarg) (... ...))
(with-syntax ([stx stx])
(syntax (-instantiate super-go stx #f (the-obj si_c si_inited?
si_leftovers)
(list arg (... ...))
(kw kwarg) (... ...))))]))]
(syntax
(begin
`(declare-super-new)
(-instantiate super-go stx #f (the-obj si_c si_inited?
si_leftovers)
(list arg (... ...))
(kw kwarg) (... ...)))))]))]
[super-new-param
(lambda (stx)
(syntax-case stx ()
[(_ (kw kwarg) (... ...))
(with-syntax ([stx stx])
(syntax (-instantiate super-go stx #f (the-obj si_c si_inited?
si_leftovers)
null
(kw kwarg) (... ...))))]))]
(syntax
(begin
`(declare-super-new)
(-instantiate super-go stx #f (the-obj si_c si_inited?
si_leftovers)
null
(kw kwarg) (... ...)))))]))]
[super-make-object-param
(lambda (stx)
(let ([code
(quote-syntax
(lambda args
(super-go the-obj si_c si_inited? si_leftovers args null)))])
(if (identifier? stx)
code
(datum->syntax
code
(cons code
(cdr (syntax-e stx)))))))])
#`(begin
`(declare-super-new)
#,(if (identifier? stx)
code
(datum->syntax
code
(cons code
(cdr (syntax-e stx))))))))])
(letrec-syntaxes+values
([(plain-init-name) (make-init-redirect
(quote-syntax set!)
(quote-syntax #%plain-app)
(quote-syntax local-plain-init-name)
(quote-syntax plain-init-name-localized))] ...)
([(local-plain-init-name) undefined] ...)
([(local-plain-init-name) unsafe-undefined] ...)
(void) ; in case the body is empty
. exprs)))))))))))))
(begin
'(declare-field-use-start) ; see "class-undef.rkt"
. exprs))))))))))))))
;; Extra argument added here by `detect-field-unsafe-undefined`
#; check-undef?
;; Not primitive:
#f)))))))))))))))))
#f))))))))))))))))
;; The class* and class entry points:
(values
@ -1746,7 +1764,6 @@
()
defn-or-expr ...))]))
(define-syntaxes (private* public* pubment* override* overment* augride* augment*
public-final* override-final* augment-final*)
(let ([mk
@ -1969,6 +1986,7 @@
field-pub-width ; total number of public fields
field-ht ; maps public field names to field-infos (see make-field-info above)
field-ids ; list of public field names
all-field-ids ; list of field names in reverse order, used for `undefined` error reporting
[struct:object ; structure type for instances
#:mutable]
@ -2001,6 +2019,8 @@
[fixup ; for deserialization
#:mutable]
check-undef? ; objects need an unsafe-undefined guarding chaperone?
no-super-init?); #t => no super-init needed
#:inspector insp)
@ -2044,6 +2064,7 @@ last few projections.
num-fields ; total fields (public & private)
public-field-names ; list of symbols (shorter than num-fields)
inherit-field-names ; list of symbols (not included in num-fields)
private-field-names ; list of symbols (the rest of num-fields)
rename-super-names ; list of symbols
rename-inner-names
@ -2063,6 +2084,9 @@ last few projections.
init-mode ; 'normal, 'stop, or 'list
make-methods ; takes field and method accessors
check-undef?
make-struct:prim) ; see "primitive classes", below
(define (make-method proc meth-name)
(procedure-rename
@ -2288,11 +2312,15 @@ last few projections.
methods super-methods int-methods beta-methods meth-flags
inner-projs dynamic-idxs dynamic-projs
field-width field-pub-width field-ht field-names
(append (reverse private-field-names)
(reverse public-field-names)
(class-all-field-ids super))
'struct:object 'object? 'make-object 'field-ref 'field-set!
init-args
init-mode
'init
#f #f #f ; serializer is set later
(or check-undef? (class-check-undef? super))
(and make-struct:prim #t))]
[obj-name (if name
(string->symbol (format "object:~a" name))
@ -2347,10 +2375,14 @@ last few projections.
(add-properties (class-struct:object super) interfaces)
0 ;; No init fields
;; Fields for new slots:
num-fields undefined
num-fields unsafe-undefined
;; Map object property to class:
(append
(list (cons prop:object c))
(if (class-check-undef? c)
(list (cons prop:chaperone-unsafe-undefined
(class-all-field-ids c)))
null)
(if deserialize-id
(list
(cons prop:serializable
@ -3078,7 +3110,7 @@ An example
(vector) (vector) (vector)
0 0 (make-hasheq) null
0 0 (make-hasheq) null null
'struct:object object? 'make-object
'field-ref-not-needed 'field-set!-not-needed
@ -3095,6 +3127,8 @@ An example
(lambda (obj) #(())) ; serialize
(lambda (obj args) (void)) ; deserialize-fixup
#f ; no chaperone to guard against unsafe-undefined
#t)) ; no super-init
(vector-set! (class-supers object%) 0 object%)
@ -3242,6 +3276,7 @@ An example
field-pub-width
field-ht
(class-field-ids cls)
(class-all-field-ids cls)
'struct:object 'object? 'make-object
'field-ref 'field-set!
@ -3252,6 +3287,8 @@ An example
(class-orig-cls cls)
#f #f ; serializer is never set
(class-check-undef? cls)
#f)]
[obj-name (if name
(string->symbol (format "wrapper-object:~a" name))
@ -3265,7 +3302,7 @@ An example
(class-struct:object cls)
0 ;; No init fields
0 ;; No new fields in this class replacement
undefined
unsafe-undefined
;; Map object property to class:
(list (cons prop:object c)))])
(set-class-struct:object! c struct:object)
@ -4261,7 +4298,7 @@ An example
#f
#f
0 null null ; no fields
0 null null null ; no fields
null ; no rename-supers
null ; no rename-inners
@ -4290,6 +4327,8 @@ An example
(extract-primitive-args this name init-arg-names init-args)
init-args)))))
#f
make-struct:prim))
(define (extract-primitive-args this class-name init-arg-names init-args)

201
racket/collects/racket/private/class-undef.rkt Normal file
View File

@ -0,0 +1,201 @@
#lang racket/base
(require (for-syntax racket/base
syntax/private/boundmap
syntax/kerncase))
(provide declare-field-use-start
declare-field-assignment
declare-field-use
declare-inherit-use
declare-this-escapes
declare-super-new
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-use #f)
(define-syntax declare-inherit-use #f)
(define-syntax declare-this-escapes #f)
(define-syntax declare-super-new #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)
(syntax-case stx ()
[(_ compose-class arg ... proc final)
(let-values ([(exp exp-proc) (syntax-local-expand-expression #'proc)])
(with-syntax ([exp-proc exp-proc]
[need-undef? (need-undefined-check? exp)])
(syntax/loc stx
(compose-class arg ... proc need-undef? final))))]))
;; Analysis to detect whether any field can be referenced while
;; its value is `unsafe-undefined`, based on `declare-...` annotations
;; inserted by macros.
(define-for-syntax (need-undefined-check? exp)
;; All local fields need to be initialized (i.e., assigned)
;; before a method call or `super-new`
(define init-too-late? #f)
;; It's ok to use inherited fields only after `super-new` has
;; definitely been called:
(define super-new? #f)
;; cloop returns #t if access-before-definition looks possible:
(let cloop ([exp exp]
[ready #f] ; table of initializations, after start
[in-branch? #f])
(define (loop e) (cloop e ready in-branch?))
(kernel-syntax-case exp #f
[_
(identifier? exp)
#f]
;; ----------------------------------------
;; Handle annotations at start of `begin`:
[(begin) #f]
[(begin '(decl) . body)
(and (identifier? #'decl)
(free-identifier=? #'decl #'declare-field-use-start))
;; Beginning of the class body; start tracking initialization
;; creating the `ready` table:
(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
;; 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):
(let ([ids (syntax->list #'(id ...))])
(or (and ready
init-too-late?
(ormap (lambda (id)
(not (module-identifier-mapping-get ready id (lambda () #f))))
ids)
(report #'body)
#t)
;; field is ready after RHS is evaluated:
(begin0
(loop #'(begin . body))
(when ready
(unless in-branch?
(for-each (lambda (id)
(module-identifier-mapping-put! ready id #t))
ids))))))]
[(begin '(decl id ...) . body)
(and (identifier? #'decl)
(free-identifier=? #'decl #'declare-inherit-use))
;; It's ok to use an inherited field only if `super-new` has
;; definitely been called.
(or (and ready
(not super-new?)
(report #'body)
#t)
(loop #'(begin . body)))]
[(begin '(decl) . body)
(and (identifier? #'decl)
(free-identifier=? #'decl #'declare-this-escapes))
;; Any method call or explicit use of `this` means a field
;; might be accessed outside of the `class` declaration,
;; so any initialization afterward is too late:
(begin
(when ready (set! init-too-late? #t))
(loop #'(begin . body)))]
[(begin '(decl) . body)
(and (identifier? #'decl)
(free-identifier=? #'decl #'declare-super-new))
;; As long as we're not in a branch, `super-new` is definitely
;; called after here.
(begin
(when (and ready (not in-branch?)) (set! super-new? #t))
(loop #'(begin '(declare-this-escapes) . body)))]
;; ----------------------------------------
;; Abstract interpretation of core forms.
;; We model order by calling `cloop` in order, which can mutate
;; `init-too-late?`, `super-new?` and `ready`. (Those could
;; have been threaded through, but local mutation is easier.)
;; We model both branches and delayed computation (via closures)
;; by recurring with a true `in-branch?`. In a branch, we
;; pessimistically ignore initialization (via local-field
;; assignment) and super-new`, and pessimistcally assume all
;; references, method calls, and inherite-field assignemtnt.
;; [Room for improvement: use a functional table in place of
;; `ready`, etc., and suitably split and merge.]
[(begin exp . body)
(or (loop #'exp)
(loop #'(begin . body)))]
[(#%plain-lambda _ exp ...)
(cloop #'(begin exp ...) ready #t)]
[(case-lambda clause ...)
(ormap (lambda (clause)
(cloop #`(#%plain-lambda . #,clause) ready #t))
(syntax->list #'(clause ...)))]
[(if tst thn els)
(or (loop #'tst)
(cloop #'thn ready #t)
(cloop #'els ready #t))]
[(begin0 exp ...)
(loop #'(begin exp ...))]
[(let-values ([(id ...) exp] ...) body-exp ...)
(loop #'(begin exp ... body-exp ...))]
[(letrec-values ([(id ...) exp] ...) body-exp ...)
(loop #'(begin exp ... body-exp ...))]
[(letrec-syntaxes+values _ ([(id ...) exp] ...) body-exp ...)
(loop #'(begin exp ... body-exp ...))]
[(set! id exp)
(loop #'exp)]
[(quote . _) #f]
[(quote-syntax . _) #f]
[(with-continuation-mark key val exp)
(loop #'(begin key val exp))]
[(#%plain-app exp ...)
(loop #'(begin exp ...))]
[(#%top . _) #f]
[(#%variable-reference . _) #f]
[(#%expression expr) (loop #'expr)]
[_else (raise-syntax-error #f "unrecognized expression form" exp)])))
(define-for-syntax (report exprs)
(when (pair? (syntax->list exprs))
(define expr (car (syntax->list exprs)))
(define s (srcloc->string (srcloc (syntax-source expr)
(syntax-line expr)
(syntax-column expr)
(syntax-position expr)
(syntax-span expr))))
(log-message (make-logger 'optimizer (current-logger))
'debug
(format "chaperoning to prevent undefined access due to: ~.s~a~a"
(syntax->datum expr)
(if s " at: " "")
(or s ""))
#f)))

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

@ -3,8 +3,9 @@
(require syntax/stx
(for-syntax racket/base)
(for-template racket/base
racket/undefined
"class-wrapped.rkt"))
racket/unsafe/undefined
"class-wrapped.rkt"
"class-undef.rkt"))
(define insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
@ -35,6 +36,18 @@
(define (binding from to stx)
stx)
;; Declarations used to determine whether a chaperone is
;; needed to protect against unsafe-undefined access
(define (add-declare-this-escapes src-stx stx)
(quasisyntax/loc src-stx (begin '(declare-this-escapes) #,stx)))
(define (add-declare-field-use id inherited? src-stx stx)
(if inherited?
(quasisyntax/loc src-stx (begin '(declare-inherit-use #,id) #,stx))
(quasisyntax/loc src-stx (begin '(declare-field-use #,id) #,stx))))
(define (add-declare-field-assignment id inherited? src-stx stx)
(if inherited?
stx
(quasisyntax/loc src-stx (begin '(declare-field-assignment #,id) #,stx))))
(define (make-this-map orig-id the-finder the-obj)
(let ([set!-stx (datum->syntax the-finder 'set!)])
@ -46,11 +59,13 @@
(free-identifier=? (syntax set!) set!-stx)
(raise-syntax-error 'class "cannot mutate object identifier" stx)]
[(id . args)
(datum->syntax
(add-declare-this-escapes
stx
(cons (find the-finder the-obj stx) (syntax args))
stx)]
[id (find the-finder the-obj stx)])))))
(datum->syntax
stx
(cons (find the-finder the-obj stx) (syntax args))
stx))]
[id (add-declare-this-escapes stx (find the-finder the-obj stx))])))))
(define (make-this%-map replace-stx the-finder)
(let ([set!-stx (datum->syntax the-finder 'set!)])
@ -66,9 +81,10 @@
[(f . args)
(quasisyntax/loc stx (#,replace-stx . args))])))))
(define (make-field-map the-finder the-obj the-binder the-binder-localized
(define (make-field-map inherited? the-finder the-obj the-binder the-binder-localized
field-accessor field-mutator)
(let ([set!-stx (datum->syntax the-finder 'set!)])
(define (choose-src a b) (if (syntax-source a) a b))
(mk-set!-trans
the-binder-localized
(lambda (stx)
@ -77,20 +93,32 @@
(syntax-case stx ()
[(set! id expr)
(free-identifier=? (syntax set!) set!-stx)
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [id expr]))]
[set (quasisyntax/loc stx
((unsyntax field-mutator) obj id))])
(syntax/loc stx (let* bindings set)))]
(add-declare-field-assignment
#'id
inherited?
#'id
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [id expr]))]
[set (quasisyntax/loc stx
((unsyntax field-mutator) obj id))])
(syntax/loc (choose-src stx #'id) (let* bindings set))))]
[(id . args)
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))]
[call (quasisyntax/loc stx
((check-not-undefined ((unsyntax field-accessor) obj) 'id) . args))])
(syntax/loc stx (let* bindings call)))]
(add-declare-field-use
#'id
inherited?
#'id
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))]
[call (quasisyntax/loc stx
(((unsyntax field-accessor) obj) . args))])
(syntax/loc (choose-src stx #'id) (let* bindings call))))]
[id
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))]
[get (quasisyntax/loc stx
(check-not-undefined ((unsyntax field-accessor) obj) 'id))])
(syntax/loc stx (let* bindings get)))])))))))
(add-declare-field-use
#'id
inherited?
stx
(with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))]
[get (quasisyntax/loc stx
((unsyntax field-accessor) obj))])
(syntax/loc (choose-src stx #'id) (let* bindings get))))])))))))
(define (make-method-map the-finder the-obj the-binder the-binder-localized method-accessor)
(let ([set!-stx (datum->syntax the-finder 'set!)])
@ -103,15 +131,17 @@
(free-identifier=? (syntax set!) set!-stx)
(raise-syntax-error 'class "cannot mutate method" stx)]
[(id . args)
(binding
the-binder (syntax id)
(datum->syntax
the-finder
(make-method-apply
(list method-accessor (find the-finder the-obj stx))
(find the-finder the-obj stx)
(syntax args))
stx))]
(add-declare-this-escapes
stx
(binding
the-binder (syntax id)
(datum->syntax
the-finder
(make-method-apply
(list method-accessor (find the-finder the-obj stx))
(find the-finder the-obj stx)
(syntax args))
stx)))]
[_else
(raise-syntax-error
'class
@ -131,12 +161,14 @@
(free-identifier=? (syntax set!) set!-stx)
(raise-syntax-error 'class "cannot mutate method" stx)]
[(id . args)
(binding
the-binder (syntax id)
(datum->syntax
the-finder
(make-method-apply (find the-finder new-name stx) (find the-finder the-obj stx) (syntax args))
stx))]
(add-declare-this-escapes
stx
(binding
the-binder (syntax id)
(datum->syntax
the-finder
(make-method-apply (find the-finder new-name stx) (find the-finder the-obj stx) (syntax args))
stx)))]
[_else
(raise-syntax-error
'class
@ -154,12 +186,14 @@
(free-identifier=? (syntax set!) set!-stx)
(raise-syntax-error 'class "cannot mutate super method" stx)]
[(id . args)
(binding
the-binder (syntax id)
(datum->syntax
the-finder
(make-method-apply (find the-finder rename-temp stx) (find the-finder the-obj stx) (syntax args))
stx))]
(add-declare-this-escapes
stx
(binding
the-binder (syntax id)
(datum->syntax
the-finder
(make-method-apply (find the-finder rename-temp stx) (find the-finder the-obj stx) (syntax args))
stx)))]
[_else
(raise-syntax-error
'class
@ -180,13 +214,15 @@
[(id (lambda () default) . args)
(free-identifier=? (syntax lambda) lambda-stx)
(let ([target (find the-finder the-obj stx)])
(binding
the-binder (syntax id)
(datum->syntax
the-finder
(make-method-apply (list (find the-finder rename-temp stx) target #'default)
target (syntax args))
stx)))]
(add-declare-this-escapes
stx
(binding
the-binder (syntax id)
(datum->syntax
the-finder
(make-method-apply (list (find the-finder rename-temp stx) target #'default)
target (syntax args))
stx))))]
[(id (lambda largs default) . args)
(free-identifier=? (syntax lambda) lambda-stx)
(raise-syntax-error
@ -211,27 +247,31 @@
stx)]))))))
(define (generate-super-call stx the-finder the-obj rename-temp args)
(class-syntax-protect
(datum->syntax
the-finder
(make-method-apply (find the-finder rename-temp stx)
(find the-finder the-obj stx)
args)
stx)))
(add-declare-this-escapes
stx
(class-syntax-protect
(datum->syntax
the-finder
(make-method-apply (find the-finder rename-temp stx)
(find the-finder the-obj stx)
args)
stx))))
(define (generate-inner-call stx the-finder the-obj default-expr rename-temp args)
(class-syntax-protect
(datum->syntax
the-finder
(let ([target (find the-finder the-obj stx)])
(datum->syntax
the-finder
`(let ([i (,(find the-finder rename-temp stx) ,target)])
(if i
,(make-method-apply 'i target args)
,default-expr))
stx))
stx)))
(add-declare-this-escapes
stx
(class-syntax-protect
(datum->syntax
the-finder
(let ([target (find the-finder the-obj stx)])
(datum->syntax
the-finder
`(let ([i (,(find the-finder rename-temp stx) ,target)])
(if i
,(make-method-apply 'i target args)
,default-expr))
stx))
stx))))
(define (make-init-error-map localized-id)
(mk-set!-trans
@ -253,14 +293,22 @@
(with-syntax ([local-id local-id])
(syntax/loc stx (set! local-id expr)))]
[(id . args)
(with-syntax ([local-id local-id]
(with-syntax ([local-id (datum->syntax
local-id
(syntax-e local-id)
#'id
#'id)]
[#%app #%app-stx])
(syntax/loc stx (#%app local-id . args)))]
[_else (datum->syntax
local-id
(syntax-e local-id)
stx
stx)])))))
(syntax/loc stx (#%app (#%app check-not-unsafe-undefined local-id 'id) . args)))]
[id (quasisyntax/loc stx
(#,#%app-stx
check-not-unsafe-undefined
#,(datum->syntax
local-id
(syntax-e local-id)
stx
stx)
'id))])))))
(define super-error-map
(lambda (stx)

3
racket/collects/racket/private/pre-base.rkt
View File

@ -179,8 +179,7 @@
procedure->method procedure-rename
chaperone-procedure impersonate-procedure
assq assv assoc
prop:incomplete-arity prop:method-arity-error
check-not-undefined undefined)
prop:incomplete-arity prop:method-arity-error)
(all-from "reqprov.rkt")
(all-from-except "for.rkt"
define-in-vector-like

8
racket/collects/racket/undefined.rkt
View File

@ -1,8 +1,10 @@
#lang racket/base
(require '#%kernel)
(provide check-not-undefined
undefined
(provide undefined
undefined?)
(define-values (struct:undef make-undef undef? undef-ref undef-set!)
(make-struct-type 'undefined #f 0 0))
(define undefined (make-undef))
(define (undefined? v) (eq? v undefined))

13
racket/collects/racket/unit.rkt
View File

@ -17,7 +17,7 @@
"private/unit-syntax.rkt"))
(require racket/block
racket/undefined
racket/unsafe/undefined
racket/contract/base
racket/contract/region
racket/stxparam
@ -967,7 +967,7 @@
(list (cons 'dept depr) ...)
(syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))])
(lambda ()
(let ([eloc (box undefined)] ... ...)
(let ([eloc (box unsafe-undefined)] ... ...)
(values
(lambda (import-table)
(let-values ([(iloc ...)
@ -1005,7 +1005,10 @@
(define-values (e-post-id ...)
(letrec-syntaxes+values (post-renames ...) ()
e-post-rhs)) ... ...)))))
(unit-export ((export-key ...) (vector-immutable (λ () (unbox eloc)) ...)) ...)))))))
(unit-export ((export-key ...)
(vector-immutable (λ () (check-not-unsafe-undefined (unbox eloc) 'int-evar))
...))
...)))))))
import-tagged-sigids
export-tagged-sigids
dep-tagged-sigids))))))
@ -1187,8 +1190,8 @@
(lambda (int/ext-name index ctc)
(bound-identifier-mapping-put! def-table
(car int/ext-name)
#`(check-not-undefined (vector-ref #,v #,index)
'#,(car int/ext-name)))
#`(check-not-unsafe-undefined (vector-ref #,v #,index)
'#,(car int/ext-name)))
(bound-identifier-mapping-put! ctc-table
(car int/ext-name)
ctc)

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

@ -3,7 +3,10 @@
'#%flfxnum
'#%extfl)
(provide (all-from-out '#%unsafe)
(provide (except-out (all-from-out '#%unsafe)
unsafe-undefined
check-not-unsafe-undefined
prop:chaperone-unsafe-undefined)
(prefix-out unsafe-
(combine-out flsin flcos fltan
flasin flacos flatan

9
racket/collects/racket/unsafe/undefined.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang racket/base
(require '#%unsafe)
(provide check-not-unsafe-undefined
unsafe-undefined
unsafe-undefined?
prop:chaperone-unsafe-undefined)
(define (unsafe-undefined? v) (eq? v unsafe-undefined))

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

File diff suppressed because it is too large Load Diff

1
racket/src/racket/src/env.c
View File

@ -328,6 +328,7 @@ static void init_unsafe(Scheme_Env *env)
scheme_init_unsafe_numcomp(unsafe_env);
scheme_init_unsafe_list(unsafe_env);
scheme_init_unsafe_vector(unsafe_env);
scheme_init_unsafe_fun(unsafe_env);
scheme_init_extfl_unsafe_number(unsafe_env);
scheme_init_extfl_unsafe_numarith(unsafe_env);

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

@ -93,6 +93,7 @@ READ_ONLY Scheme_Object *scheme_reduced_procedure_struct;
READ_ONLY Scheme_Object *scheme_tail_call_waiting;
READ_ONLY Scheme_Object *scheme_inferred_name_symbol;
READ_ONLY Scheme_Object *scheme_default_prompt_tag;
READ_ONLY Scheme_Object *scheme_chaperone_undefined_property;
/* READ ONLY SHARABLE GLOBALS */
@ -190,6 +191,7 @@ static Scheme_Object *current_prompt_read(int, Scheme_Object **);
static Scheme_Object *current_read(int, Scheme_Object **);
static Scheme_Object *current_get_read_input_port(int, Scheme_Object **);
static Scheme_Object *chaperone_not_undefined (int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_wrap_cc_guard(Scheme_Object *obj, Scheme_Object *proc);
static Scheme_Object *do_cc_guard(Scheme_Object *v, Scheme_Object *cc_guard, Scheme_Object *chaperone);
@ -491,16 +493,6 @@ scheme_init_fun (Scheme_Env *env)
| SCHEME_PRIM_IS_OMITABLE);
scheme_add_global_constant("void?", o, env);
/* adds the new primitive check-undefined to the kernel langauge
check-undefined has an arity of 1 and no flags */
REGISTER_SO(scheme_check_not_undefined_proc);
o = scheme_make_prim_w_arity(scheme_check_not_undefined, "check-not-undefined", 2, 2);
scheme_check_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-undefined", o, env);
scheme_add_global_constant("undefined", scheme_undefined, env);
#ifdef TIME_SYNTAX
scheme_add_global_constant("time-apply",
scheme_make_prim_w_arity2(time_apply,
@ -677,6 +669,25 @@ scheme_init_fun (Scheme_Env *env)
original_default_prompt->tag = scheme_default_prompt_tag;
}
void
scheme_init_unsafe_fun (Scheme_Env *env)
{
Scheme_Object *o, *a[1];
REGISTER_SO(scheme_check_not_undefined_proc);
o = scheme_make_prim_w_arity(scheme_check_not_undefined, "check-not-unsafe-undefined", 2, 2);
scheme_check_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", o, env);
scheme_add_global_constant("unsafe-undefined", scheme_undefined, env);
REGISTER_SO(scheme_chaperone_undefined_property);
o = scheme_make_struct_type_property(scheme_intern_symbol("chaperone-unsafe-undefined"));
scheme_chaperone_undefined_property = o;
scheme_add_global_constant("prop:chaperone-unsafe-undefined", o, env);
}
void
scheme_init_fun_places()
{
@ -2538,7 +2549,7 @@ Scheme_Object *
scheme_check_not_undefined (int argc, Scheme_Object *argv[])
{
if (!SCHEME_SYMBOLP(argv[1]))
scheme_wrong_contract("check-not-undefined", "symbol?", 1, argc, argv);
scheme_wrong_contract("check-not-unsafe-undefined", "symbol?", 1, argc, argv);
if (SAME_OBJ(argv[0], scheme_undefined)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE,
@ -2550,6 +2561,11 @@ scheme_check_not_undefined (int argc, Scheme_Object *argv[])
return argv[0];
}
Scheme_Object *
chaperone_not_undefined (int argc, Scheme_Object *argv[])
{
return scheme_chaperone_not_undefined(argv[0]);
}
static Scheme_Object *
procedure_p (int argc, Scheme_Object *argv[])

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

@ -3527,11 +3527,11 @@ 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-undefined")) {
} else if (IS_NAMED_PRIM(rator, "check-not-unsafe-undefined")) {
if (SCHEME_SYMBOLP(app->rand2)) {
GC_CAN_IGNORE jit_insn *ref, *ref2;
LOG_IT(("inlined check-not-undefined\n"));
LOG_IT(("inlined check-not-unsafe-undefined\n"));
mz_runstack_skipped(jitter, 2);
scheme_generate_non_tail(app->rand1, jitter, 0, 1, 0); /* no sync... */

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

@ -14,8 +14,8 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1118
#define EXPECTED_UNSAFE_COUNT 101
#define EXPECTED_PRIM_COUNT 1116
#define EXPECTED_UNSAFE_COUNT 104
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45
#define EXPECTED_FUTURES_COUNT 15

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

@ -308,6 +308,7 @@ void scheme_init_promise(Scheme_Env *env);
void scheme_init_struct(Scheme_Env *env);
void scheme_init_reduced_proc_struct(Scheme_Env *env);
void scheme_init_fun(Scheme_Env *env);
void scheme_init_unsafe_fun(Scheme_Env *env);
void scheme_init_compile(Scheme_Env *env);
void scheme_init_symbol(Scheme_Env *env);
void scheme_init_char(Scheme_Env *env);
@ -527,6 +528,8 @@ extern Scheme_Object *scheme_app_mark_impersonator_property;
extern Scheme_Object *scheme_no_arity_property;
extern Scheme_Object *scheme_chaperone_undefined_property;
extern Scheme_Object *scheme_reduced_procedure_struct;
/* recycle some constants that can't appear in code: */
@ -1003,6 +1006,8 @@ Scheme_Object *scheme_chaperone_hash_get(Scheme_Object *table, Scheme_Object *ke
Scheme_Object *scheme_chaperone_hash_traversal_get(Scheme_Object *table, Scheme_Object *key, Scheme_Object **alt_key);
void scheme_chaperone_hash_set(Scheme_Object *table, Scheme_Object *key, Scheme_Object *val);
Scheme_Object *scheme_chaperone_not_undefined(Scheme_Object *orig_val);
/*========================================================================*/
/* syntax objects */
/*========================================================================*/

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

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

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

@ -2002,7 +2002,38 @@ static Scheme_Object *chaperone_struct_ref(const char *who, Scheme_Object *o, in
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[2], *red, *orig;
if (!SCHEME_VECTORP(px->redirects)
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 result is not undefined */
o = px->prev;
if (!SCHEME_CHAPERONEP(o))
orig = ((Scheme_Structure *)o)->slots[i];
else
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");
}
}
return orig;
} else if (!SCHEME_VECTORP(px->redirects)
|| (SCHEME_VEC_SIZE(px->redirects) & 1)
|| SCHEME_FALSEP(SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + i])) {
o = px->prev;
@ -2065,7 +2096,8 @@ static void chaperone_struct_set(const char *who, Scheme_Object *o, int i, Schem
o = px->prev;
if (SCHEME_VECTORP(px->redirects)
&& !(SCHEME_VEC_SIZE(px->redirects) & 1)) {
&& !(SCHEME_VEC_SIZE(px->redirects) & 1)
&& !SAME_OBJ(SCHEME_VEC_ELS(px->redirects)[1], scheme_undefined)) {
half = (SCHEME_VEC_SIZE(px->redirects) - PRE_REDIRECTS) >> 1;
red = SCHEME_VEC_ELS(px->redirects)[PRE_REDIRECTS + half + i];
if (SCHEME_TRUEP(red)) {
@ -2102,7 +2134,8 @@ void scheme_struct_set(Scheme_Object *sv, int pos, Scheme_Object *v)
}
}
static Scheme_Object **apply_guards(Scheme_Struct_Type *stype, int argc, Scheme_Object **args)
static Scheme_Object **apply_guards(Scheme_Struct_Type *stype, int argc, Scheme_Object **args,
int *_chaperone_undefined)
{
Scheme_Object **guard_argv = NULL, *v, *prev_guards = NULL, *guard;
int p, gcount;
@ -2131,7 +2164,9 @@ static Scheme_Object **apply_guards(Scheme_Struct_Type *stype, int argc, Scheme_
guard = scheme_false;
}
if (!SCHEME_FALSEP(guard)) {
if (SAME_OBJ(guard, scheme_undefined))
*_chaperone_undefined = 1;
else if (!SCHEME_FALSEP(guard)) {
gcount = stype->parent_types[p]->num_islots;
guard_argv[argc] = guard_argv[gcount];
guard_argv[gcount] = stype->name;
@ -2173,6 +2208,7 @@ scheme_make_struct_instance(Scheme_Object *_stype, int argc, Scheme_Object **arg
Scheme_Structure *inst;
Scheme_Struct_Type *stype;
int p, i, j, nis, ns, c;
int chaperone_undefined = 0;
stype = (Scheme_Struct_Type *)_stype;
@ -2185,7 +2221,7 @@ scheme_make_struct_instance(Scheme_Object *_stype, int argc, Scheme_Object **arg
inst->stype = stype;
/* Apply guards, if any: */
args = apply_guards(stype, argc, args);
args = apply_guards(stype, argc, args, &chaperone_undefined);
/* Fill in fields: */
j = c;
@ -2213,7 +2249,10 @@ scheme_make_struct_instance(Scheme_Object *_stype, int argc, Scheme_Object **arg
}
}
return (Scheme_Object *)inst;
if (chaperone_undefined)
return scheme_chaperone_not_undefined((Scheme_Object *)inst);
else
return (Scheme_Object *)inst;
}
Scheme_Object *scheme_make_blank_prefab_struct_instance(Scheme_Struct_Type *stype)
@ -2609,7 +2648,7 @@ static Scheme_Object *struct_info_chaperone(Scheme_Object *o, Scheme_Object *si,
if (SCHEME_VECTORP(px->redirects)
&& !(SCHEME_VEC_SIZE(px->redirects) & 1)) {
proc = SCHEME_VEC_ELS(px->redirects)[1];
if (SCHEME_TRUEP(proc)) {
if (SCHEME_TRUEP(proc) && !SAME_OBJ(proc, scheme_undefined)) {
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR)
proc = scheme_box(proc);
procs = scheme_make_pair(proc, procs);
@ -4289,7 +4328,7 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
Scheme_Object *guard)
{
Scheme_Struct_Type *struct_type, *parent_type;
int j, depth, checked_proc = 0;
int j, depth, checked_proc = 0, chaperone_undefined = 0;
if (parent && SCHEME_NP_CHAPERONEP(parent))
parent_type = (Scheme_Struct_Type *)SCHEME_CHAPERONE_VAL(parent);
@ -4432,6 +4471,8 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
if (SAME_OBJ(prop, scheme_checked_proc_property))
checked_proc = 1;
if (SAME_OBJ(prop, scheme_chaperone_undefined_property))
chaperone_undefined = 1;
propv = guard_property(prop, SCHEME_CDR(a), struct_type);
@ -4489,6 +4530,8 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
if (SAME_OBJ(prop, scheme_checked_proc_property))
checked_proc = 1;
if (SAME_OBJ(prop, scheme_chaperone_undefined_property))
chaperone_undefined = 1;
propv = guard_property(prop, SCHEME_CDR(a), struct_type);
@ -4554,6 +4597,8 @@ static Scheme_Object *_make_struct_type(Scheme_Object *base,
}
struct_type->guard = guard;
} else if (chaperone_undefined) {
struct_type->guard = scheme_undefined;
}
if (parent && SCHEME_NP_CHAPERONEP(parent)) {
@ -5666,6 +5711,40 @@ static Scheme_Object *impersonate_struct(int argc, Scheme_Object **argv)
return do_chaperone_struct("impersonate-struct", 1, argc, argv);
}
Scheme_Object *scheme_chaperone_not_undefined (Scheme_Object *orig_val)
{
Scheme_Chaperone *px;
Scheme_Object *val, *redirects;
Scheme_Hash_Tree *props;
val = orig_val;
if (SCHEME_CHAPERONEP(val)) {
props = ((Scheme_Chaperone *)val)->props;
val = SCHEME_CHAPERONE_VAL(val);
} else
props = NULL;
redirects = scheme_make_vector(PRE_REDIRECTS, scheme_false);
SCHEME_VEC_ELS(redirects)[0] = scheme_false;
SCHEME_VEC_ELS(redirects)[1] = scheme_undefined; /* special handing in struct_ref */
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
if (SCHEME_PROCP(val))
px->iso.so.type = scheme_proc_chaperone_type;
else
px->iso.so.type = scheme_chaperone_type;
px->val = val;
px->prev = orig_val;
px->props = props;
px->redirects = redirects;
return (Scheme_Object *)px;
}
static Scheme_Object *do_chaperone_struct_type(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{
Scheme_Chaperone *px;

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

@ -163,7 +163,7 @@ scheme_init_type ()
set_name(scheme_double_type, "<inexact-number>");
set_name(scheme_long_double_type, "<extflonum>");
set_name(scheme_float_type, "<inexact-number*>");
set_name(scheme_undefined_type, "<undefined>");
set_name(scheme_undefined_type, "<unsafe-undefined>");
set_name(scheme_eof_type, "<eof>");
set_name(scheme_input_port_type, "<input-port>");
set_name(scheme_output_port_type, "<output-port>");