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

adjust unit expansion patterns to be more flexible

Browse Source 
Like e707b64db1, but for units.

Also, adjust the `class` change to avoid duplicating patterns
and make it slightly more flexible.
This commit is contained in:
Matthew Flatt 2016-07-31 08:53:21 -06:00
parent e707b64db1
commit 43aa1023c1
2 changed files with 31 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -149,19 +149,21 @@
(pattern (letrec-values () :make-methods-body))
(pattern (#%expression :make-methods-body)))
(define-syntax-class make-methods-under-locals-class
#:literals (let-values #%plain-lambda)
#:attributes (initializer-body initializer-self-id
initializer-args-id)
(pattern (let-values () :make-methods-under-locals-class))
(pattern (let-values ([(field-name:id) accessor-or-mutator] ...)
:make-methods-body)))
(define-syntax-class make-methods-class
#:literals (let-values #%plain-lambda)
#:attributes (initializer-body initializer-self-id
initializer-args-id)
(pattern (#%plain-lambda
(local-accessor:id local-mutator:id local-method-or-field:id ...)
(let-values ([(field-name:id) accessor-or-mutator] ...)
:make-methods-body)))
(pattern (#%plain-lambda
(local-accessor:id local-mutator:id local-method-or-field:id ...)
(let-values ()
(let-values ([(field-name:id) accessor-or-mutator] ...)
:make-methods-body)))))
:make-methods-under-locals-class)))
(define-syntax-class core-class-expansion
#:literals (let-values letrec-syntaxes+values #%plain-app quote)

38
typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt
View File

@ -230,6 +230,26 @@
...))
#:attr export-temp-ids (map syntax->list (syntax->list #'((export-temp-id ...) ...)))))
(define-syntax-class unit-expansion-internals
#:literal-sets (kernel-literals)
#:attributes (body-stx
import-internal-ids
export-temp-ids)
(pattern (let-values (_ ...) :unit-expansion-internals))
(pattern (#%expression :unit-expansion-internals))
(pattern (#%plain-lambda ()
(let-values (((export-temp-id:id) _) ...)
(#%plain-app
values
(#%plain-lambda (import-table:id)
(let-values (((import:id ...) _) ...)
unit-body:expr))
et:export-table
_ ...)))
#:attr export-temp-ids (syntax->list #'(export-temp-id ...))
#:attr import-internal-ids (map syntax->list (syntax->list #'((import ...) ...)))
#:with body-stx #'unit-body))
;; This syntax class matches the whole expansion of unit forms
(define-syntax-class unit-expansion
#:literal-sets (kernel-literals)
@ -246,25 +266,11 @@
import-vector:sig-vector
export-vector:sig-vector
list-dep:init-depend-list
(let-values (_ ...)
(let-values (_ ...)
(#%expression
(#%plain-lambda ()
(let-values (((export-temp-id:id) _) ...)
(#%plain-app
values
(#%plain-lambda (import-table:id)
(let-values (((import:id ...) _) ...)
unit-body:expr))
et:export-table
_ ...)))))))
:unit-expansion-internals)
#:attr import-sigs (syntax->list #'import-vector.sigs)
#:attr import-sig-tags (syntax->list #'import-vector.sig-tags)
#:attr export-sigs (syntax->list #'export-vector.sigs)
#:attr export-temp-ids (syntax->list #'(export-temp-id ...))
#:attr init-depend-tags (syntax->list #'list-dep.init-depend-tags)
#:attr import-internal-ids (map syntax->list (syntax->list #'((import ...) ...)))
#:with body-stx #'unit-body))
#:attr init-depend-tags (syntax->list #'list-dep.init-depend-tags)))
;; Extract the identifiers referenced in unit-from-context and invoke-unit forms
;; in order to typecheck them in the current environment