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

cptypes: add handlers for atan and char-name

Browse Source 
They had a very strange signature, than needs a special case.

original commit: 16d94b6731982f76548fc26c0e3524b253ddbb66
This commit is contained in:
Gustavo Massaccesi 2020-03-20 22:34:57 -03:00
parent f976cec5da
commit a72817e69c
2 changed files with 53 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
s/cptypes.ss
View File

@ -1033,6 +1033,57 @@ Notes:
[else
(values `(call ,preinfo ,pr ,n) ret ntypes #f #f)]))])
(define-specialize 2 atan
[(n) (let ([r (get-type n)])
(cond
[(predicate-implies-not? r 'number)
(values `(call ,preinfo ,pr ,n)
'bottom pred-env-bottom #f #f)]
[else
(values `(call ,preinfo ,pr ,n) ret
(pred-env-add/ref ntypes n 'number plxc) #f #f)]))]
[(x y) (let ([rx (get-type x)]
[ry (get-type y)])
(cond
[(or (predicate-implies-not? rx 'real)
(predicate-implies-not? ry 'real))
(values `(call ,preinfo ,pr ,x ,y)
'bottom pred-env-bottom #f #f)]
[else
(values `(call ,preinfo ,pr ,x ,y) ret
(pred-env-add/ref (pred-env-add/ref ntypes
x 'real plxc)
y 'real plxc)
#f #f)]))])
(define-specialize 2 char-name
[(n) (let ([r (get-type n)]
[ir `(call ,preinfo ,pr ,n)])
(cond
[(predicate-implies? r 'char)
(values ir 'ptr ntypes #f #f)] ; should be maybe-symbol
[(predicate-implies? r 'symbol)
(values ir 'ptr ntypes #f #f)] ; should be maybe-char
[(and (predicate-implies-not? r 'char)
(predicate-implies-not? r 'symbol))
(values ir 'bottom pred-env-bottom #f #f)]
[else
(values ir 'ptr ; should be maybe-(union 'char 'symbol)
(pred-env-add/ref ntypes n 'true plxc) #f #f)]))] ; should be (union 'char 'symbol)
[(n c) (let ([rn (get-type n)]
[rc (get-type c)]
[ir `(call ,preinfo ,pr ,n ,c)])
(cond
[(or (predicate-implies-not? rn 'symbol)
(predicate-implies-not? rc 'ptr)) ; should be maybe-char
(values ir 'bottom pred-env-bottom #f #f)]
[else
(values ir void-rec
(pred-env-add/ref (pred-env-add/ref ntypes
n 'symbol plxc)
c 'ptr plxc) ; should be maybe-char
#f #f)]))])
(define-specialize/unrestricted 2 call-with-values
[(e1 e2) (let-values ([(e1 ret1 types1 t-types1 f-types1)
(Expr/call e1 'value oldtypes oldtypes plxc)])

4
s/primdata.ss
View File

@ -238,7 +238,7 @@
(tan [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(asin [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(acos [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(atan [sig [(number) (real real) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(atan [sig [(number) (real real) -> (number)]] [flags arith-op mifoldable discard cptypes2 ieee r5rs])
(sqrt [sig [(number) -> (number)]] [flags arith-op mifoldable discard ieee r5rs])
(exact-integer-sqrt [sig [(exact-integer) -> (exact-integer exact-integer)]] [flags discard discard]) ; could be mifoldable if multiple values were handled
(expt [sig [(number number) -> (number)]] [flags pure discard true cp02 ieee r5rs]) ; can take too long to fold
@ -1215,7 +1215,7 @@
(char-ci=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard cp03 safeongoodargs]) ; not restricted to 2+ arguments
(char-ci>=? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(char-ci>? [sig [(char char ...) -> (boolean)]] [flags pure mifoldable discard safeongoodargs]) ; not restricted to 2+ arguments
(char-name [sig [(sub-ptr) (sub-symbol maybe-char) -> (ptr)]] [flags])
(char-name [sig [(sub-ptr) (sub-symbol maybe-char) -> (ptr)]] [flags cptypes2])
(char-ready? [sig [() (textual-input-port) -> (boolean)]] [flags ieee r5rs])
(chmod [sig [(pathname sub-ufixnum) -> (void)]] [flags])
(clear-input-port [sig [() (input-port) -> (void)]] [flags true])