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

Refactoring.

Browse Source 
original commit: 74508210687ad0e415af1f28037357ec2640e3ba
This commit is contained in:
Vincent St-Amour 2010-09-09 18:06:03 -04:00
parent dee0ddc16e
commit 19dcce8809
2 changed files with 22 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/tests/typed-scheme/optimizer/tests/derived-pair.rkt
View File

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

26
collects/typed-scheme/optimizer/pair.rkt
View File

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