Yuck. On Apr 15, 2014, at 9:20 PM, as...@racket-lang.org wrote:
> asumu has updated `master' from aa43797b63 to 9aaaf98b32. > http://git.racket-lang.org/plt/aa43797b63..9aaaf98b32 > > =====[ One Commit ]===================================================== > Directory summary: > 97.6% pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/ > > ~~~~~~~~~~ > > 9aaaf98 Asumu Takikawa <as...@racket-lang.org> 2014-04-15 21:15 > : > | Fix TR class support for new class expansion > | > | Also add a type for `check-not-unsafe-undefined` which shows > | up in the expanded code now. > : > M .../typed-racket/base-env/base-env.rkt | 4 + > M .../typed-racket/typecheck/check-class-unit.rkt | 100 ++++++++++++------- > > =====[ Overall Diff ]=================================================== > > pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt > ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ > --- > OLD/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt > +++ > NEW/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt > @@ -6,6 +6,7 @@ > (for-template > (except-in racket -> ->* one-of/c class) > racket/unsafe/ops > + racket/unsafe/undefined > ;(only-in rnrs/lists-6 fold-left) > '#%paramz > "extra-procs.rkt" > @@ -2716,6 +2717,9 @@ > [unsafe-struct-set! top-func] > [unsafe-struct*-set! top-func] > > +;; Section 17.4 (Unsafe Undefined) > +[check-not-unsafe-undefined (-poly (a) (-> a -Symbol a))] > + > ;; Section 18.2 (Libraries and Collections) > [find-library-collection-paths (->opt [(-lst -Pathlike) (-lst -Pathlike)] > (-lst -Path))] > [collection-file-path (->* (list -Pathlike) -Pathlike -Path)] > > pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt > ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ > --- > OLD/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt > +++ > NEW/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt > @@ -151,7 +151,7 @@ > :make-methods-body)))) > > (define-syntax-class class-expansion > - #:literals (let-values letrec-syntaxes+values #%plain-app) > + #:literals (let-values letrec-syntaxes+values #%plain-app quote) > #:attributes (superclass-expr > type-parameters > all-init-internals > @@ -176,13 +176,15 @@ > () > ((() ;; residual class: data > :internal-class-data)) > - (let-values (((superclass:id) superclass-expr) > - ((interfaces:id) interface-expr)) > - (#%plain-app > - compose-class:id > - internal:expr ... > - (~and make-methods :make-methods-class) > - (quote #f))))))) > + (#%plain-app > + compose-class:id > + name:expr > + superclass-expr:expr > + interface-expr:expr > + internal:expr ... > + (~and make-methods :make-methods-class) > + (quote :boolean) > + (quote #f)))))) > > ;; This is similar to `type-declaration` from "internal-forms.rkt", but > ;; the expansion is slightly different in a class so we use this instead. > @@ -517,15 +519,20 @@ > #:literals (:-augment) > ;; FIXME: this case seems too loose, many things can match this syntax > ;; we likely need to set a property or match against another > name > - [(let-values ([(obj:id) self]) > - (let-values ([(field:id) initial-value]) > - (#%plain-app setter:id _ _))) > + [(begin > + (quote ((~datum declare-field-assignment) _)) > + (let-values ([(obj:id) self]) > + (let-values ([(field:id) initial-value]) > + (#%plain-app setter:id _ _)))) > ;; only record the first one, which is the one that initializes > ;; the field or private field > (unless (dict-has-key? initializers #'setter) > (free-id-table-set! initializers #'setter #'initial-value)) > other-exprs] > - [:tr:class:super-new^ > + ;; The second part of this pattern ensures that we find the actual > + ;; initialization call, rather than the '(declare-super-new) in > + ;; the expansion. > + [(~and :tr:class:super-new^ (#%plain-app . rst)) > (when super-new > (tc-error/delayed "typed classes must only call super-new a single > time")) > (set! super-new (find-provided-inits expr)) > @@ -830,8 +837,6 @@ > super-call-types > pubment-types augment-types inner-types)) > (values all-names all-types > - ;; FIXME: consider removing method names and types > - ;; from top-level environment to avoid <undefined> > (append all-names > localized-init-names > localized-init-rest-name > @@ -909,7 +914,6 @@ > (syntax-parse form > #:literals (let-values #%plain-app quote) > ;; init with default > - ;; FIXME: undefined can appear here > [(set! internal-init:id > (#%plain-app extract-arg:id > _ > @@ -939,14 +943,16 @@ > (tc-error/delayed "Init argument ~a has no type annotation" > init-name)])] > ;; init-field with default > - [(let-values (((obj1:id) self:id)) > - (let-values (((x:id) > - (#%plain-app extract-arg:id > - _ > - (quote name:id) > - init-args:id > - init-val:expr))) > - (#%plain-app local-setter:id obj2:id y:id))) > + [(begin > + (quote ((~datum declare-field-assignment) _)) > + (let-values (((obj1:id) self:id)) > + (let-values (((x:id) > + (#%plain-app extract-arg:id > + _ > + (quote name:id) > + init-args:id > + init-val:expr))) > + (#%plain-app local-setter:id obj2:id y:id)))) > #:when (free-identifier=? #'x #'y) > #:when (free-identifier=? #'obj1 #'obj2) > (define init-name (syntax-e #'name)) > @@ -965,9 +971,11 @@ > ;; any field or init-field without default > ;; FIXME: could use the local table to make sure the > ;; setter is known as a sanity check > - [(let-values (((obj1:id) self:id)) > - (let-values (((x:id) init-val:expr)) > - (#%plain-app local-setter:id obj2:id y:id))) > + [(begin > + (quote ((~datum declare-field-assignment) _)) > + (let-values (((obj1:id) self:id)) > + (let-values (((x:id) init-val:expr)) > + (#%plain-app local-setter:id obj2:id y:id)))) > #:when (free-identifier=? #'x #'y) > #:when (free-identifier=? #'obj1 #'obj2) > (tc-expr form)] > @@ -994,7 +1002,8 @@ > ;; generated inside the untyped class macro. > (define (construct-local-mapping-tables stx) > (syntax-parse stx > - #:literals (let-values if quote #%plain-app #%plain-lambda values) > + #:literal-sets (kernel-literals) > + #:literals (values) > ;; See base-env/class-prims.rkt to see how this in-syntax > ;; table is constructed at the surface syntax > ;; > @@ -1003,60 +1012,83 @@ > (#%plain-app > values > (#%plain-lambda () > + (quote ((~datum declare-this-escapes))) > (#%plain-app (#%plain-app local-method:id _) _)) > ...)] > [(private:id ...) > (#%plain-app > values > - (#%plain-lambda () (#%plain-app local-private:id _)) > + (#%plain-lambda () > + (quote ((~datum declare-this-escapes))) > + (#%plain-app local-private:id _)) > ...)] > [(field:id ...) > (#%plain-app > values > (#%plain-lambda () > + (quote ((~datum declare-field-use) _)) > (let-values (((_) _)) (#%plain-app local-field-get:id > _)) > - (let-values (((_) _)) > - (let-values (((_) _)) (#%plain-app > local-field-set:id _ _)))) > + (begin > + (quote ((~datum declare-field-assignment) _)) > + (let-values (((_) _)) > + (let-values (((_) _)) (#%plain-app > local-field-set:id _ _))))) > ...)] > [(private-field:id ...) > (#%plain-app > values > (#%plain-lambda () > + (quote ((~datum declare-field-use) _)) > (let-values (((_) _)) (#%plain-app local-private-get:id > _)) > - (let-values (((_) _)) > - (let-values (((_) _)) (#%plain-app > local-private-set:id _ _)))) > + (begin > + (quote ((~datum declare-field-assignment) _)) > + (let-values (((_) _)) > + (let-values (((_) _)) (#%plain-app > local-private-set:id _ _))))) > ...)] > [(inherit-field:id ...) > (#%plain-app > values > (#%plain-lambda () > + (quote ((~datum declare-inherit-use) _)) > (let-values (((_) _)) (#%plain-app local-inherit-get:id > _)) > (let-values (((_) _)) > (let-values (((_) _)) (#%plain-app > local-inherit-set:id _ _)))) > ...)] > [(init:id ...) > - (#%plain-app values (#%plain-lambda () local-init:id) > ...)] > + (#%plain-app > + values > + (#%plain-lambda () > + ;; check-not-unsafe-undefined > + (#%plain-app _ local-init:id _)) ...)] > [(init-rest:id ...) > - (#%plain-app values (#%plain-lambda () > local-init-rest:id) ...)] > + (#%plain-app > + values > + (#%plain-lambda () > + ;; check-not-unsafe-undefined > + (#%plain-app _ local-init-rest:id _)) ...)] > [(inherit:id ...) > (#%plain-app > values > (#%plain-lambda () > + (quote ((~datum declare-this-escapes))) > (#%plain-app (#%plain-app local-inherit:id _) _)) > ...)] > [(override:id ...) > (#%plain-app > values > (#%plain-lambda () > + (quote ((~datum declare-this-escapes))) > (#%plain-app (#%plain-app local-override:id _) _) > + (quote ((~datum declare-this-escapes))) > (#%plain-app local-super:id _)) > ...)] > [(augment:id ...) > (#%plain-app > values > (#%plain-lambda () > + (quote ((~datum declare-this-escapes))) > (~or (#%plain-app local-augment:id _) > (#%plain-app (#%plain-app local-augment:id _) _)) > + (quote ((~datum declare-this-escapes))) > (let-values ([(_) (#%plain-app local-inner:id _)]) > (if _ (#%plain-app _ _) _))) > ...)]) _________________________ Racket Developers list: http://lists.racket-lang.org/dev
