From 58360f3a169ececa8a3d0890e96c7f288e0158a4 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 16 May 2011 17:56:30 -0400 Subject: [PATCH] Add an arith-expr syntax class, to simplify parts of the optimizer. original commit: ec696f26ae5375b83f4eb8666047e803b19214e4 --- .../typed-scheme/optimizer/numeric-utils.rkt | 37 ++++++++++++++++++- 1 file changed, 36 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/optimizer/numeric-utils.rkt b/collects/typed-scheme/optimizer/numeric-utils.rkt index f1c334a9..6731660d 100644 --- a/collects/typed-scheme/optimizer/numeric-utils.rkt +++ b/collects/typed-scheme/optimizer/numeric-utils.rkt @@ -1,6 +1,7 @@ #lang racket/base -(require syntax/parse +(require syntax/parse racket/dict syntax/id-table + (for-template racket/base racket/flonum racket/fixnum racket/unsafe/ops) "../utils/utils.rkt" (types numeric-tower) (optimizer utils)) @@ -20,3 +21,37 @@ (and (subtypeof? t -Real) (not (subtypeof? t -Rat)) (not (subtypeof? t -Flonum)))) + +(define-syntax-class arith-expr + (pattern (#%plain-app op:arith-op args ...))) +(define-syntax-class arith-op + (pattern + op:id + #:when (dict-ref arith-ops #'op (lambda () #f)))) +;; limited to operation that actually perform arithmeric +;; so, no comparisons, or coercions, or constructors (make-rectangular), accessors, etc. +(define arith-ops + (make-immutable-free-id-table + (map (lambda (x) (list x #t)) + (list #'* #'+ #'- #'/ + #'max #'min #'add1 #'sub1 + #'quotient #'remainder #'modulo + #'arithmetic-shift #'bitwise-and #'bitwise-ior #'bitwise-xor #'bitwise-not + #'abs #'floor #'ceiling #'truncate #'round + #'expt #'sqrt #'integer-sqrt #'log #'exp + #'cos #'sin #'tan #'acos #'asin #'atan + #'gcd #'lcm #'sgn #'sqr #'conjugate + #'sinh #'cosh #'tanh + #'fx+ #'fx- #'fx* #'fxquotient #'fxremainder #'fxmodulo #'fxabs + #'unsafe-fx+ #'unsafe-fx- #'unsafe-fx* #'unsafe-fxquotient #'unsafe-fxremainder #'unsafe-fxmodulo #'unsafe-fxabs + #'fxand #'fxior #'fxxor #'fxnot #'fxlshift #'fxrshift + #'unsafe-fxand #'unsafe-fxior #'unsafe-fxxor #'unsafe-fxnot #'unsafe-fxlshift #'unsafe-fxrshift + #'fxmax #'fxmin #'unsafe-fxmax #'unsafe-fxmin + #'flabs #'fl+ #'fl- #'fl* #'fl/ #'flmin #'flmax + #'unsafe-flabs #'unsafe-fl+ #'unsafe-fl- #'unsafe-fl* #'unsafe-fl/ #'unsafe-flmin #'unsafe-flmax + #'flround #'flfloor #'flceiling #'fltruncate + #'unsafe-flround #'unsafe-flfloor #'unsafe-flceiling #'unsafe-fltruncate + #'flsin #'flcos #'fltan #'flasin #'flacos #'flatan + #'unsafe-flsin #'unsafe-flcos #'unsafe-fltan #'unsafe-flasin #'unsafe-flacos #'unsafe-flatan + #'fllog #'flexp #'flsqrt + #'unsafe-fllog #'unsafe-flexp #'unsafe-flsqrt))))