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

Simplify internal data for TR classes with kws

Browse Source 
Use keywords instead of literals for communicating
internal information from the TR front-end macro to the
back-end.

original commit: 35af4b726497268957c0a065b473ee9acc13758d
This commit is contained in:
Asumu Takikawa 2014-03-19 01:51:04 -04:00
parent bbb47f45fe
commit 63841ff35a
2 changed files with 28 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt
View File

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

34
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
View File

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