From 43aa1023c14e83c261d93650f13ef87452394a57 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sun, 31 Jul 2016 08:53:21 -0600
Subject: [PATCH] adjust `unit` expansion patterns to be more flexible

Like e707b64db1, but for units.

Also, adjust the `class` change to avoid duplicating patterns
and make it slightly more flexible.
---
 .../typecheck/check-class-unit.rkt            | 16 ++++----
 .../typecheck/check-unit-unit.rkt             | 38 +++++++++++--------
 2 files changed, 31 insertions(+), 23 deletions(-)

diff --git a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
index 26d04627..d9d01911 100644
--- a/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
@@ -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)
diff --git a/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt b/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt
index 46481203..c18abe8f 100644
--- a/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt
+++ b/typed-racket-lib/typed-racket/typecheck/check-unit-unit.rkt
@@ -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