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

Various fixnum unsafe operations improvements.

Browse Source
This commit is contained in:
Vincent St-Amour 2010-07-09 14:35:59 -04:00
parent 4e6fc3154b
commit b7229487a5
2 changed files with 20 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/typed-scheme/private/base-env-numeric.rkt
View File

@ -46,7 +46,8 @@
(define-for-syntax fx-op (cl->* (-Pos -Pos . -> . -PositiveFixnum) (define-for-syntax fx-op (cl->* (-Pos -Pos . -> . -PositiveFixnum)
(-Nat -Nat . -> . -NonnegativeFixnum) (-Nat -Nat . -> . -NonnegativeFixnum)
(-Integer -Integer . -> . -Fixnum))) (-Integer -Integer . -> . -Fixnum)))
(define-for-syntax fx-intop (-Integer -Integer . -> . -Fixnum)) (define-for-syntax fx-natop (cl->* (-Nat -Nat . -> . -NonnegativeFixnum)
(-Integer -Integer . -> . -Fixnum)))
(define-for-syntax fx-unop (-Integer . -> . -Fixnum)) (define-for-syntax fx-unop (-Integer . -> . -Fixnum))
(define-for-syntax real-comp (->* (list R R) R B)) (define-for-syntax real-comp (->* (list R R) R B))
@ -57,6 +58,8 @@
(-Nat -Pos . -> . -PositiveFixnum) (-Nat -Pos . -> . -PositiveFixnum)
(-Nat -Nat . -> . -NonnegativeFixnum) (-Nat -Nat . -> . -NonnegativeFixnum)
(-Integer -Integer . -> . -Fixnum))) (-Integer -Integer . -> . -Fixnum)))
(define-for-syntax fx--type
(-Integer -Integer . -> . -Fixnum))
(define-for-syntax fx=-type (define-for-syntax fx=-type
(cl->* (cl->*
(-> -Integer (-val 0) B : (-FS (-filter (-val 0) 0) -top)) (-> -Integer (-val 0) B : (-FS (-filter (-val 0) 0) -top))
@ -473,11 +476,11 @@
[unsafe-flimag-part (-InexactComplex . -> . -Flonum)] [unsafe-flimag-part (-InexactComplex . -> . -Flonum)]
[unsafe-fx+ fx+-type] [unsafe-fx+ fx+-type]
[unsafe-fx- fx-intop] [unsafe-fx- fx--type]
[unsafe-fx* fx-op] [unsafe-fx* fx-op]
[unsafe-fxquotient fx-intop] [unsafe-fxquotient fx-natop]
[unsafe-fxremainder fx-intop] [unsafe-fxremainder fx-natop]
[unsafe-fxmodulo fx-intop] [unsafe-fxmodulo fx-natop]
[unsafe-fxabs (-Integer . -> . (Un -PositiveFixnum (-val 0)))] [unsafe-fxabs (-Integer . -> . (Un -PositiveFixnum (-val 0)))]
[unsafe-fxand fx-op] [unsafe-fxand fx-op]
@ -498,11 +501,11 @@
;; scheme/fixnum ;; scheme/fixnum
[fx+ fx+-type] [fx+ fx+-type]
[fx- fx-intop] [fx- fx--type]
[fx* fx-op] [fx* fx-op]
[fxquotient fx-intop] [fxquotient fx-natop]
[fxremainder fx-intop] [fxremainder fx-natop]
[fxmodulo fx-intop] [fxmodulo fx-natop]
[fxabs (-Integer . -> . (Un -PositiveFixnum (-val 0)))] [fxabs (-Integer . -> . (Un -PositiveFixnum (-val 0)))]
[fxand fx-op] [fxand fx-op]

9
collects/typed-scheme/typecheck/tc-app.rkt
View File

@ -22,7 +22,7 @@
(r:infer infer) (r:infer infer)
'#%paramz '#%paramz
(for-template (for-template
racket/unsafe/ops racket/unsafe/ops racket/fixnum racket/flonum
(only-in '#%kernel [apply k:apply]) (only-in '#%kernel [apply k:apply])
"internal-forms.rkt" scheme/base scheme/bool '#%paramz "internal-forms.rkt" scheme/base scheme/bool '#%paramz
(only-in racket/private/class-internal make-object do-make-object))) (only-in racket/private/class-internal make-object do-make-object)))
@ -484,6 +484,13 @@
[(subtype t -NonnegativeFixnum) (ret -Fixnum)] [(subtype t -NonnegativeFixnum) (ret -Fixnum)]
[(subtype t -ExactPositiveInteger) (ret -Nat)] [(subtype t -ExactPositiveInteger) (ret -Nat)]
[else (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)]))] [else (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)]))]
;; idem for fx-
[(#%plain-app (~and op (~or (~literal fx-) (~literal unsafe-fx-))) v (~and arg2 ((~literal quote) 1)))
(add-typeof-expr #'arg2 (ret -PositiveFixnum))
(match-let ([(tc-result1: t) (single-value #'v)])
(cond
[(subtype t -ExactPositiveInteger) (ret -NonnegativeFixnum)]
[else (tc/funapp #'op #'(v arg2) (single-value #'op) (list (ret t) (single-value #'arg2)) expected)]))]
;; call-with-values ;; call-with-values
[(#%plain-app call-with-values prod con) [(#%plain-app call-with-values prod con)
(match (tc/funapp #'prod #'() (single-value #'prod) null #f) (match (tc/funapp #'prod #'() (single-value #'prod) null #f)