From 19dcce8809df34fff138d93f32fbca466fa6d4ba Mon Sep 17 00:00:00 2001
From: Vincent St-Amour <stamourv@racket-lang.org>
Date: Thu, 9 Sep 2010 18:06:03 -0400
Subject: [PATCH] Refactoring.

original commit: 74508210687ad0e415af1f28037357ec2640e3ba
---
 .../optimizer/tests/derived-pair.rkt          | 16 ++++++------
 collects/typed-scheme/optimizer/pair.rkt      | 26 ++++++++++---------
 2 files changed, 22 insertions(+), 20 deletions(-)

diff --git a/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt b/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt
index 26dbab51..575cc1c9 100644
--- a/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt
+++ b/collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt
@@ -1,19 +1,19 @@
 #;
 (
-pair.rkt line 81 col 45 - car - pair
-pair.rkt line 81 col 39 - car - pair
+#f line #f col #f - car - pair
+#f line #f col #f - car - pair
 derived-pair.rkt line 27 col 0 - (#%app caar (#%app cons (#%app cons (quote 1) (quote 2)
 ) (quote 3))) - derived pair                                                           
-pair.rkt line 83 col 45 - cdr - pair
-pair.rkt line 83 col 39 - car - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - car - pair
 derived-pair.rkt line 28 col 0 - (#%app cadr (#%app cons (quote 1) (#%app cons (quote 2)
  (quote 3)))) - derived pair                                                           
-pair.rkt line 85 col 45 - car - pair
-pair.rkt line 85 col 39 - cdr - pair
+#f line #f col #f - car - pair
+#f line #f col #f - cdr - pair
 derived-pair.rkt line 29 col 0 - (#%app cdar (#%app cons (#%app cons (quote 1) (quote 2)
 ) (quote 3))) - derived pair                                                           
-pair.rkt line 87 col 45 - cdr - pair
-pair.rkt line 87 col 39 - cdr - pair
+#f line #f col #f - cdr - pair
+#f line #f col #f - cdr - pair
 derived-pair.rkt line 30 col 0 - (#%app cddr (#%app cons (quote 1) (#%app cons (quote 2)
  (quote 3)))) - derived pair                                                           
 1
diff --git a/collects/typed-scheme/optimizer/pair.rkt b/collects/typed-scheme/optimizer/pair.rkt
index f9e56084..38120a3d 100644
--- a/collects/typed-scheme/optimizer/pair.rkt
+++ b/collects/typed-scheme/optimizer/pair.rkt
@@ -65,8 +65,9 @@
      (define (gen-alt-helper accessors)
        (if (null? accessors)
            #'arg
-           #`(#%plain-app #,(car accessors)
-                          #,(gen-alt-helper (cdr accessors)))))
+           (quasisyntax/loc stx
+             (#%plain-app #,(car accessors)
+                          #,(gen-alt-helper (cdr accessors))))))
      (let ((ty  (type-of stx))
            (obj (gen-alt-helper accessors)))
        ;; we're calling the typechecker, but this is just a shortcut, we're
@@ -75,16 +76,17 @@
        (tc-expr/check obj ty)
        obj)]))
 
-(define-syntax-class pair-derived-expr
-  #:commit
-  (pattern (#%plain-app (~literal caar) x)
-           #:with alt (gen-alt (list #'car #'car) this-syntax))
-  (pattern (#%plain-app (~literal cadr) x)
-           #:with alt (gen-alt (list #'car #'cdr) this-syntax))
-  (pattern (#%plain-app (~literal cdar) x)
-           #:with alt (gen-alt (list #'cdr #'car) this-syntax))
-  (pattern (#%plain-app (~literal cddr) x)
-           #:with alt (gen-alt (list #'cdr #'cdr) this-syntax)))
+(define-syntax-rule (gen-pair-derived-expr name (orig seq ...) ...)
+  (define-syntax-class name
+    #:commit
+    (pattern (#%plain-app (~literal orig) x)
+             #:with alt (gen-alt (list seq ...) this-syntax))
+    ...))
+(gen-pair-derived-expr pair-derived-expr
+ (caar #'car #'car)
+ (cadr #'car #'cdr)
+ (cdar #'cdr #'car)
+ (cddr #'cdr #'cdr))
 
 (define-syntax-class pair-derived-opt-expr
   #:commit