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

Use subtype test, just in case.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-03-12 17:09:30 -05:00
parent 17afa91c09
commit d06bf0de91
2 changed files with 12 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/typed-scheme/optimizer/float-complex.rkt
View File

@ -37,7 +37,7 @@
c1:unboxed-float-complex-opt-expr c1:unboxed-float-complex-opt-expr
c2:unboxed-float-complex-opt-expr c2:unboxed-float-complex-opt-expr
cs:unboxed-float-complex-opt-expr ...) cs:unboxed-float-complex-opt-expr ...)
#:when (isoftype? this-syntax -FloatComplex) #:when (subtypeof? this-syntax -FloatComplex)
#:with real-binding (unboxed-gensym "unboxed-real-") #:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-") #:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...) #:with (bindings ...)
@ -62,7 +62,7 @@
c1:unboxed-float-complex-opt-expr c1:unboxed-float-complex-opt-expr
c2:unboxed-float-complex-opt-expr c2:unboxed-float-complex-opt-expr
cs:unboxed-float-complex-opt-expr ...) cs:unboxed-float-complex-opt-expr ...)
#:when (isoftype? this-syntax -FloatComplex) #:when (subtypeof? this-syntax -FloatComplex)
#:with real-binding (unboxed-gensym "unboxed-real-") #:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-") #:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...) #:with (bindings ...)
@ -89,7 +89,7 @@
c1:unboxed-float-complex-opt-expr c1:unboxed-float-complex-opt-expr
c2:unboxed-float-complex-opt-expr c2:unboxed-float-complex-opt-expr
cs:unboxed-float-complex-opt-expr ...) cs:unboxed-float-complex-opt-expr ...)
#:when (or (isoftype? this-syntax -FloatComplex) (isoftype? this-syntax -Number)) #:when (or (subtypeof? this-syntax -FloatComplex) (subtypeof? this-syntax -Number))
#:with real-binding (unboxed-gensym "unboxed-real-") #:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-") #:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...) #:with (bindings ...)
@ -138,7 +138,7 @@
c1:unboxed-float-complex-opt-expr c1:unboxed-float-complex-opt-expr
c2:unboxed-float-complex-opt-expr c2:unboxed-float-complex-opt-expr
cs:unboxed-float-complex-opt-expr ...) cs:unboxed-float-complex-opt-expr ...)
#:when (or (isoftype? this-syntax -FloatComplex) (isoftype? this-syntax -Number)) #:when (or (subtypeof? this-syntax -FloatComplex) (subtypeof? this-syntax -Number))
#:with real-binding (unboxed-gensym "unboxed-real-") #:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-") #:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with reals (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0)) #:with reals (syntax-map (lambda (x) (if (syntax->datum x) x #'0.0))
@ -206,7 +206,7 @@
res)])))))))) res)]))))))))
(pattern (#%plain-app (~and op (~literal conjugate)) c:unboxed-float-complex-opt-expr) (pattern (#%plain-app (~and op (~literal conjugate)) c:unboxed-float-complex-opt-expr)
#:when (isoftype? this-syntax -FloatComplex) #:when (subtypeof? this-syntax -FloatComplex)
#:with real-binding #'c.real-binding #:with real-binding #'c.real-binding
#:with imag-binding (unboxed-gensym "unboxed-imag-") #:with imag-binding (unboxed-gensym "unboxed-imag-")
#:with (bindings ...) #:with (bindings ...)
@ -311,7 +311,7 @@
(exact->inexact (syntax->datum #'n))))))) (exact->inexact (syntax->datum #'n)))))))
(pattern e:expr (pattern e:expr
#:when (isoftype? #'e -FloatComplex) #:when (subtypeof? #'e -FloatComplex)
#:with e* (unboxed-gensym) #:with e* (unboxed-gensym)
#:with real-binding (unboxed-gensym "unboxed-real-") #:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-") #:with imag-binding (unboxed-gensym "unboxed-imag-")
@ -321,7 +321,7 @@
((real-binding) (unsafe-flreal-part e*)) ((real-binding) (unsafe-flreal-part e*))
((imag-binding) (unsafe-flimag-part e*))))) ((imag-binding) (unsafe-flimag-part e*)))))
(pattern e:expr (pattern e:expr
#:when (isoftype? #'e -Number) ; complex, maybe exact, maybe not #:when (subtypeof? #'e -Number) ; complex, maybe exact, maybe not
#:with e* (unboxed-gensym) #:with e* (unboxed-gensym)
#:with real-binding (unboxed-gensym "unboxed-real-") #:with real-binding (unboxed-gensym "unboxed-real-")
#:with imag-binding (unboxed-gensym "unboxed-imag-") #:with imag-binding (unboxed-gensym "unboxed-imag-")
@ -332,7 +332,7 @@
((imag-binding) (exact->inexact (imag-part e*)))))) ((imag-binding) (exact->inexact (imag-part e*))))))
(pattern e:expr (pattern e:expr
#:with (bindings ...) #:with (bindings ...)
(error "non exhaustive pattern match") (error (format "non exhaustive pattern match" #'e))
#:with real-binding #f #:with real-binding #f
#:with imag-binding #f)) #:with imag-binding #f))
@ -354,7 +354,7 @@
(define-syntax-class float-complex-expr (define-syntax-class float-complex-expr
#:commit #:commit
(pattern e:expr (pattern e:expr
#:when (isoftype? #'e -FloatComplex) #:when (subtypeof? #'e -FloatComplex)
#:with opt ((optimize) #'e))) #:with opt ((optimize) #'e)))
(define-syntax-class float-complex-opt-expr (define-syntax-class float-complex-opt-expr
@ -382,7 +382,7 @@
#'(op.unsafe n.opt))) #'(op.unsafe n.opt)))
(pattern (#%plain-app (~and op (~literal make-polar)) r theta) (pattern (#%plain-app (~and op (~literal make-polar)) r theta)
#:when (isoftype? this-syntax -FloatComplex) #:when (subtypeof? this-syntax -FloatComplex)
#:with exp*:unboxed-float-complex-opt-expr this-syntax #:with exp*:unboxed-float-complex-opt-expr this-syntax
#:with opt #:with opt
(begin (log-optimization "make-polar" #'op) (begin (log-optimization "make-polar" #'op)
@ -420,7 +420,7 @@
real-binding))) real-binding)))
(pattern (#%plain-app op:float-complex-op e:expr ...) (pattern (#%plain-app op:float-complex-op e:expr ...)
#:when (isoftype? this-syntax -FloatComplex) #:when (subtypeof? this-syntax -FloatComplex)
#:with exp*:unboxed-float-complex-opt-expr this-syntax #:with exp*:unboxed-float-complex-opt-expr this-syntax
#:with real-binding #'exp*.real-binding #:with real-binding #'exp*.real-binding
#:with imag-binding #'exp*.imag-binding #:with imag-binding #'exp*.imag-binding

2
collects/typed-scheme/optimizer/unboxed-let.rkt
View File

@ -59,7 +59,7 @@
;; clauses of form ((v) rhs), currently only supports 1 lhs var ;; clauses of form ((v) rhs), currently only supports 1 lhs var
(partition (partition
(lambda (p) (lambda (p)
(and (isoftype? (cadr p) -FloatComplex) (and (subtypeof? (cadr p) -FloatComplex)
(could-be-unboxed-in? (car (syntax-e (car p))) (could-be-unboxed-in? (car (syntax-e (car p)))
#'(begin body ...)))) #'(begin body ...))))
(syntax-map syntax->list #'(clause ...)))) (syntax-map syntax->list #'(clause ...))))