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

Check for unsupported class clauses and error

Browse Source
This commit is contained in:
Asumu Takikawa 2013-10-21 19:03:07 -04:00
parent 661a371434
commit 66c1b10c18
1 changed files with 34 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -47,41 +47,48 @@
(begin-for-syntax (begin-for-syntax
(module+ test (require rackunit)) (module+ test (require rackunit))
;; forms that are not allowed by Typed Racket yet
(define unsupported-forms
(list (quote-syntax init-rest)
(quote-syntax augride)
;; FIXME: see if override contracts are enough
;; to keep these at bay or whether they
;; need to be handled
(quote-syntax public-final)
(quote-syntax override-final)
(quote-syntax augment-final)
(quote-syntax overment)
(quote-syntax abstract)
(quote-syntax rename-super)
(quote-syntax inherit/super)
(quote-syntax inherit/inner)
(quote-syntax rename-inner)))
;; basically the same stop forms that class-internal uses ;; basically the same stop forms that class-internal uses
(define stop-forms (define stop-forms
(append (kernel-form-identifier-list) (append (kernel-form-identifier-list)
unsupported-forms
(list (list
(quote-syntax :) (quote-syntax :)
(quote-syntax #%app) (quote-syntax #%app)
(quote-syntax lambda) (quote-syntax lambda)
(quote-syntax init) (quote-syntax init)
(quote-syntax init-rest)
(quote-syntax field) (quote-syntax field)
(quote-syntax init-field) (quote-syntax init-field)
(quote-syntax inherit-field) (quote-syntax inherit-field)
(quote-syntax private) (quote-syntax private)
(quote-syntax public) (quote-syntax public)
(quote-syntax override) (quote-syntax override)
(quote-syntax augride)
(quote-syntax public-final)
(quote-syntax override-final)
(quote-syntax augment-final)
(quote-syntax pubment) (quote-syntax pubment)
(quote-syntax overment)
(quote-syntax augment) (quote-syntax augment)
(quote-syntax rename-super)
(quote-syntax inherit) (quote-syntax inherit)
(quote-syntax inherit/super)
(quote-syntax inherit/inner)
(quote-syntax rename-inner)
(quote-syntax abstract)
(quote-syntax super) (quote-syntax super)
(quote-syntax inner) (quote-syntax inner)
(quote-syntax this) (quote-syntax this)
(quote-syntax this%) (quote-syntax this%)
(quote-syntax super-new)
(quote-syntax super-instantiate) (quote-syntax super-instantiate)
(quote-syntax super-make-object) (quote-syntax super-make-object)
(quote-syntax super-new)
(quote-syntax inspect))))) (quote-syntax inspect)))))
(begin-for-syntax (begin-for-syntax
@ -201,7 +208,8 @@
(~literal augment-final) (~literal augment-final)
(~literal inherit) (~literal inherit)
(~literal inherit/super) (~literal inherit/super)
(~literal inherit/inner))) (~literal inherit/inner)
(~literal rename-super)))
names:method-decl ...) names:method-decl ...)
form) form)
#:attr data #:attr data
@ -339,6 +347,7 @@
clause? clause?
non-clause?)) non-clause?))
(define name-dict (extract-names clauses)) (define name-dict (extract-names clauses))
(check-unsupported-features name-dict)
(add-names-to-intdef-context def-ctx name-dict) (add-names-to-intdef-context def-ctx name-dict)
(internal-definition-context-seal def-ctx) (internal-definition-context-seal def-ctx)
(define-values (annotated-methods other-top-level private-fields) (define-values (annotated-methods other-top-level private-fields)
@ -467,6 +476,18 @@
(init-clause #'(init [(a b)]) #'init #'([a b]) (list #f)))) (init-clause #'(init [(a b)]) #'init #'([a b]) (list #f))))
(list #'x))) (list #'x)))
;; check-unsupported-features : Dict<Identifier, Names> -> Void
;; Check if features that are not supported were used and
;; raise an error if they are present
(define (check-unsupported-features id-table)
(for ([form unsupported-forms])
(define entry (dict-ref id-table form null))
(unless (null? entry)
(tc-error/stx
(car entry)
"unsupported class clause: ~a"
(syntax-e form)))))
;; This is a neat/horrible trick ;; This is a neat/horrible trick
;; ;;
;; In order to detect the mappings that class-internal.rkt has ;; In order to detect the mappings that class-internal.rkt has