From 63841ff35a85cf773ce4cf3e76d2988dc68b97f5 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Wed, 19 Mar 2014 01:51:04 -0400 Subject: [PATCH] Simplify internal data for TR classes with kws Use keywords instead of literals for communicating internal information from the TR front-end macro to the back-end. original commit: 35af4b726497268957c0a065b473ee9acc13758d --- .../typed-racket/base-env/class-prims.rkt | 34 +++++++------------ .../typecheck/check-class-unit.rkt | 34 ++++++++----------- 2 files changed, 28 insertions(+), 40 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt index 3e832cc8..51bbd8a7 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt @@ -31,20 +31,12 @@ class ;; for use in ~literal clauses class-internal - optional-init - private-field :-augment) ;; give it a binding, but it shouldn't be used directly (define-syntax (class-internal stx) (raise-syntax-error 'class "should only be used internally")) -(define-syntax (optional-init stx) - (raise-syntax-error 'class "should only be used internally")) - -(define-syntax (private-field stx) - (raise-syntax-error 'class "should only be used internally")) - (define-syntax (:-augment stx) (raise-syntax-error 'class "should only be used internally")) @@ -485,19 +477,19 @@ #`(class-internal (#:forall #,@foralls) (#:all-inits #,@ordered-inits) - (init #,@(dict-ref name-dict #'init '())) - (init-field #,@(dict-ref name-dict #'init-field '())) - (init-rest #,@(dict-ref name-dict #'init-rest '())) - (optional-init #,@optional-inits) - (field #,@(dict-ref name-dict #'field '())) - (public #,@(dict-ref name-dict #'public '())) - (override #,@(dict-ref name-dict #'override '())) - (private #,@(dict-ref name-dict #'private '())) - (private-field #,@private-fields) - (inherit #,@(dict-ref name-dict #'inherit '())) - (inherit-field #,@(dict-ref name-dict #'inherit-field '())) - (augment #,@(dict-ref name-dict #'augment '())) - (pubment #,@(dict-ref name-dict #'pubment '())))) + (#:init #,@(dict-ref name-dict #'init '())) + (#:init-field #,@(dict-ref name-dict #'init-field '())) + (#:init-rest #,@(dict-ref name-dict #'init-rest '())) + (#:optional-init #,@optional-inits) + (#:field #,@(dict-ref name-dict #'field '())) + (#:public #,@(dict-ref name-dict #'public '())) + (#:override #,@(dict-ref name-dict #'override '())) + (#:private #,@(dict-ref name-dict #'private '())) + (#:private-field #,@private-fields) + (#:inherit #,@(dict-ref name-dict #'inherit '())) + (#:inherit-field #,@(dict-ref name-dict #'inherit-field '())) + (#:augment #,@(dict-ref name-dict #'augment '())) + (#:pubment #,@(dict-ref name-dict #'pubment '())))) ;; This is a neat/horrible trick ;; diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index 086eda81..db3bd346 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -16,7 +16,6 @@ "tc-metafunctions.rkt" "tc-funapp.rkt" "tc-subst.rkt" - (prefix-in c: racket/class) (private parse-type syntax-properties type-annotation) (base-env class-prims) (env lexical-env tvar-env) @@ -26,7 +25,6 @@ (rep type-rep) (for-syntax racket/base) (for-template racket/base - (prefix-in c: racket/class) (base-env class-prims) (typecheck internal-forms))) @@ -67,27 +65,25 @@ (pattern (internal:id external:id))) (define-syntax-class internal-class-data - #:literals (#%plain-app quote-syntax class-internal begin - values c:init c:init-field c:init-rest optional-init c:field - c:public c:override c:private c:inherit c:inherit-field - private-field c:augment c:pubment) + #:literal-sets (kernel-literals) + #:literals (class-internal values) (pattern (begin (quote-syntax (class-internal (#:forall type-parameter:id ...) (#:all-inits all-init-names:id ...) - (c:init init-names:name-pair ...) - (c:init-field init-field-names:name-pair ...) - (c:init-rest (~optional init-rest-name:id)) - (optional-init optional-names:id ...) - (c:field field-names:name-pair ...) - (c:public public-names:name-pair ...) - (c:override override-names:name-pair ...) - (c:private privates:id ...) - (private-field private-fields:id ...) - (c:inherit inherit-names:name-pair ...) - (c:inherit-field inherit-field-names:name-pair ...) - (c:augment augment-names:name-pair ...) - (c:pubment pubment-names:name-pair ...))) + (#:init init-names:name-pair ...) + (#:init-field init-field-names:name-pair ...) + (#:init-rest (~optional init-rest-name:id)) + (#:optional-init optional-names:id ...) + (#:field field-names:name-pair ...) + (#:public public-names:name-pair ...) + (#:override override-names:name-pair ...) + (#:private privates:id ...) + (#:private-field private-fields:id ...) + (#:inherit inherit-names:name-pair ...) + (#:inherit-field inherit-field-names:name-pair ...) + (#:augment augment-names:name-pair ...) + (#:pubment pubment-names:name-pair ...))) (#%plain-app values)) #:with type-parameters #'(type-parameter ...) #:with all-init-internals #'(all-init-names ...)